LCPQ/quantum_package
10
0
Fork 0
mirror of https://github.com/LCPQ/quantum_package synced 2024-07-11 13:53:44 +02:00
Code Issues Releases Wiki Activity

merge with scemama/develop

Browse Source
This commit is contained in:
Yann Garniron 2016-07-27 16:06:44 +02:00
commit e2e28fb301
112 changed files with 7492 additions and 1988 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
README.md
View File

@ -1,11 +1,7 @@
Quantum package ![QP](https://raw.githubusercontent.com/LCPQ/quantum_package/master/data/qp.png)
===============
[![Build Status](https://travis-ci.org/LCPQ/quantum_package.svg?branch=master)](https://travis-ci.org/LCPQ/quantum_package) [![Build Status](https://travis-ci.org/LCPQ/quantum_package.svg?branch=master)](https://travis-ci.org/LCPQ/quantum_package)
[![Gitter](https://badges.gitter.im/Join%20Chat.svg)](https://gitter.im/LCPQ/quantum_package?utm_source=badge&utm_medium=badge&utm_campaign=pr-badge&utm_content=badge) [![Gitter](https://badges.gitter.im/Join%20Chat.svg)](https://gitter.im/LCPQ/quantum_package?utm_source=badge&utm_medium=badge&utm_campaign=pr-badge&utm_content=badge)
Set of quantum chemistry programs and libraries. Set of quantum chemistry programs and libraries.
(under GNU GENERAL PUBLIC LICENSE v2) (under GNU GENERAL PUBLIC LICENSE v2)

11
config/ifort.cfg
View File

@ -6,7 +6,7 @@
# --align=32 : Align all provided arrays on a 32-byte boundary # --align=32 : Align all provided arrays on a 32-byte boundary
# #
[COMMON] [COMMON]
FC : ifort -g FC : ifort
LAPACK_LIB : -mkl=parallel LAPACK_LIB : -mkl=parallel
IRPF90 : irpf90 IRPF90 : irpf90
IRPF90_FLAGS : --ninja --align=32 IRPF90_FLAGS : --ninja --align=32
@ -31,13 +31,14 @@ OPENMP : 1 ; Append OpenMP flags
# -ftz : Flushes denormal results to zero # -ftz : Flushes denormal results to zero
# #
[OPT] [OPT]
FCFLAGS : -xSSE4.2 -O2 -ip -ftz -g FC : -traceback
FCFLAGS : -xHost -O2 -ip -ftz -g
# Profiling flags # Profiling flags
################# #################
# #
[PROFILE] [PROFILE]
FC : -p -g FC : -p -g -traceback
FCFLAGS : -xSSE4.2 -O2 -ip -ftz FCFLAGS : -xSSE4.2 -O2 -ip -ftz
# Debugging flags # Debugging flags
@ -51,13 +52,13 @@ FCFLAGS : -xSSE4.2 -O2 -ip -ftz
# #
[DEBUG] [DEBUG]
FC : -g -traceback FC : -g -traceback
FCFLAGS : -xAVX -C -fpe0 FCFLAGS : -xSSE2 -C -fpe0
IRPF90_FLAGS : --openmp IRPF90_FLAGS : --openmp
# OpenMP flags # OpenMP flags
################# #################
# #
[OPENMP] [OPENMP]
FC : -openmp FC : -qopenmp
IRPF90_FLAGS : --openmp IRPF90_FLAGS : --openmp

32
data/pseudo/tm Normal file
View File

@ -0,0 +1,32 @@
Ag GEN 36 2
4
11.074 1 1.712
-166.201 2 1.391
255.676 2 1.194
-91.757 2 1.033
3
11.074 1 0.897
-22.6472 2 1.226
16.8557 2 0.9789
4
9.524 1 12.668
227.659 2 1.662
-363.576 2 1.4
150.286 2 1.205
Au GEN 68 2
4
10.881 1 2.286
-97.386 2 1.088
270.134 2 1.267
-171.733 2 1.499
3
10.721 1 1.38
-63.222 2 1.111
60.634 2 0.987
4
9.383 1 11.
225.822 2 1.66
286.233 2 1.342
-497.561 2 1.437

806
data/pseudo/tn_df Normal file
View File

@ -0,0 +1,806 @@
H GEN 0 2
6
1.00000000 1 34.44662515
-0.89096601 2 40.13885591
-4.35250792 2 24.66307521
-11.58011743 2 20.49225491
12.58011743 2 30.23909011
34.44662515 3 22.28419700
6
-262.22422461 2 17.87367530
258.22981252 2 28.75598991
5613.63467960 2 19.10096571
-4192.30569417 2 18.88256059
-1341.04802395 2 20.95302325
-79.28421640 2 34.10653707
6
-199.48848662 2 37.85954681
197.31066276 2 28.79454664
4870247.22276531 2 40.22839783
-5277181.77014563 2 40.34690459
-196566.81095176 2 39.13989706
603502.35555458 2 40.91315002
He GEN 0 2
6
2.00000000 1 22.64777484
-0.00700692 2 23.54196640
-8.90169316 2 18.71556903
113.56926776 2 15.15150658
-112.56926776 2 13.80465850
45.29554968 3 12.54192267
6
747.63794984 2 13.33611411
-753.70091072 2 23.45392111
-397.08293819 2 12.23651194
10.35341837 2 14.87987639
-1430.53848568 2 18.32138342
1818.26602949 2 21.24054054
6
305.67933642 2 21.32319132
-307.98355807 2 12.22370696
5957.66379729 2 14.11720170
-6099.62872267 2 14.41269814
523.59639310 2 17.66028106
-380.63505659 2 21.52626637
Li GEN 2 2
6
1.00000000 1 0.78732101
-2.23999912 2 0.79224763
0.10376190 2 1.79622268
4.27489122 2 1.83637465
-3.27489122 2 1.91213904
0.78732101 3 0.79291624
6
256.80790655 2 1.78312879
-255.81956741 2 0.95553059
90.30361668 2 0.87617279
272.13155048 2 1.09621549
-180.73373018 2 1.43900642
-180.70146573 2 1.83085147
6
-4.80714862 2 1.53942961
3.36281864 2 0.84742021
-305.38012622 2 0.78976831
-509.40184487 2 0.98031681
436.16121675 2 0.81548364
379.61797456 2 1.02582853
Be GEN 2 2
6
2.00000000 1 1.20639978
-5.40313229 2 1.18425537
1.72394027 2 2.81826911
2.83884922 2 2.37513515
-1.83884922 2 2.82920954
2.41279956 3 1.18219335
6
-1045.63679908 2 2.59240356
1047.85482764 2 1.41685787
-1899.15859219 2 1.48536566
1398.06780686 2 1.70076501
-696.13481389 2 2.03898674
1198.22571139 2 2.57766211
6
630.90931326 2 1.84421403
-632.78437074 2 1.13419132
441.35012255 2 1.13393716
435.97021325 2 1.22419150
-353.63284449 2 1.39760436
-522.69065435 2 1.88595068
B GEN 2 2
6
3.00000000 1 2.72292969
-11.78419674 2 2.41356794
5.22993640 2 4.60628004
0.42834165 2 3.81569642
0.57165835 2 4.75281449
8.16878907 3 2.42655010
6
-260.26050710 2 2.55536939
265.37594882 2 4.54575013
76.89512909 2 2.14992133
-57.25691791 2 2.71845869
4293.37943873 2 3.54567059
-4312.01708538 2 3.65811356
6
236.98381086 2 3.86703012
-239.59777090 2 2.15409783
4347.09682018 2 2.51320631
-4637.07702775 2 2.58243237
786.10765740 2 3.15459528
-495.13181880 2 3.69673537
C GEN 2 2
6
4.00000000 1 6.85914037
-69.31783111 2 7.66877502
58.73619595 2 8.89164866
-5.11066199 2 4.63398124
6.11066199 2 5.40104250
27.43656147 3 6.79273179
6
430.61454744 2 8.62389774
-421.35054055 2 5.03244470
-33212.40034531 2 6.89861917
44.12655159 2 3.96628687
96.39927700 2 5.01313881
33072.87650778 2 6.85964729
6
-104389.58452246 2 4.75057662
104386.03365951 2 8.95366858
690570.92310077 2 7.84605551
105067.78650436 2 4.75435948
-142604.06718444 2 8.80450514
-653033.64724842 2 7.81116996
N GEN 2 2
6
5.00000000 1 11.01983025
-747.65378590 2 7.70260962
731.28815439 2 7.83791198
-3.54162255 2 8.41784728
4.54162255 2 12.53426384
55.09915125 3 6.76845507
6
189.29450948 2 10.95064006
-174.81483163 2 7.48980682
148422.74289741 2 6.18035270
-167161.90534269 2 6.21695388
34280.43140051 2 6.81408633
-15540.26812247 2 7.23413705
6
-5338.70218681 2 6.15987128
5334.35386770 2 7.49726635
-1839.21100223 2 8.80963870
16010.85000728 2 6.52067091
-16722.95522386 2 6.97790252
2552.31199840 2 8.37871646
O GEN 2 2
6
6.00000000 1 8.86932353
-28.04199287 2 6.05326172
11.15704031 2 5.51480979
180.82432510 2 10.77878397
-179.82432510 2 10.23693413
53.21594115 3 7.90462675
6
-9212.20980516 2 7.28893859
9226.86567950 2 6.05971190
58203.26727502 2 10.83143357
-5120.48607364 2 5.75281092
-93321.50266843 2 10.51155711
40239.72318888 2 9.72227746
6
10001.55649464 2 7.43321349
-10012.86801601 2 5.85047476
8554.95973537 2 5.79011164
-20342.33136146 2 8.08750969
11739.44079236 2 8.43229920
48.92837040 2 4.71055456
F GEN 2 2
6
7.00000000 1 16.52048840
-10.46754024 2 13.26693551
-11.21567917 2 18.77563836
-32.41582195 2 10.96778594
33.41582195 2 21.09729680
115.64341877 3 13.46927525
6
1201.43391413 2 19.92490215
-1182.60889584 2 11.77163137
-8770.99026936 2 12.30043337
5336.21358848 2 11.63810105
8729.77565724 2 14.12189391
-5293.99672165 2 16.53091209
6
92.58757506 2 8.66992000
-108.46085404 2 9.40009036
-319.30686222 2 9.08633595
524.57586653 2 9.90194004
-443.63347077 2 13.57164540
239.36118945 2 16.47995554
Ne GEN 2 2
6
8.00000000 1 21.64664513
1794.02959527 2 14.45731213
-1828.03241002 2 14.11697591
23.90491418 2 14.10774236
-22.90491418 2 20.42359560
173.17316107 3 11.93940404
6
-5911.13460210 2 12.24993716
5941.26076308 2 20.24332306
2840.09993994 2 12.20646543
1742.40556167 2 11.50431394
8834.09207695 2 16.82066882
-13415.59681607 2 18.72208419
6
53626.32637171 2 20.56468824
-53639.90888359 2 19.92390926
-576.65341012 2 13.02834964
1907.80575476 2 15.43385134
5623.71426075 2 18.06950435
-6953.86800222 2 22.66963993
K GEN 18 2
6
1.00000000 1 0.50008727
1416.76952428 2 0.63134777
-1419.89095139 2 0.60241926
-302.74307268 2 0.68724573
303.74307268 2 0.55624069
0.50008727 3 0.50008691
6
-854959.33457742 2 0.55297829
854960.96236303 2 0.59508099
-2735051.37932036 2 0.55136787
-797902.82136562 2 0.59254779
-90621.33409241 2 0.60683509
3623576.53510235 2 0.55188848
6
5366450.44923246 2 0.56834617
-5366449.39460951 2 0.57395202
506392.75510780 2 0.65188562
1065012.45735119 2 0.60395254
-764583.36396565 2 0.55451976
-806820.84832728 2 0.64359720
Ca GEN 18 2
6
2.00000000 1 0.74758765
308735.40641498 2 0.72269274
-308740.90975833 2 0.72197603
7202.81432103 2 0.70435779
-7201.81432103 2 0.73462875
1.49517531 3 0.98521314
6
3358.40551562 2 0.85820603
-3354.33378202 2 0.50055931
645.82930380 2 0.77593512
-4032.30085432 2 0.85197466
3315.68514964 2 0.50005881
71.78714429 2 1.01826143
6
3797.10880911 2 0.54666026
-3794.15970380 2 0.55760964
1988.78457523 2 0.66771019
13912.48066729 2 0.71662858
-408.96685813 2 0.50701325
-15491.29677996 2 0.71335086
Sc GEN 18 2
6
3.00000000 1 6.99258598
-124.50237230 2 4.24128187
97.21802227 2 1.68870852
-87.09390293 2 1.51321231
88.09390293 2 5.62659050
20.97775795 3 2.67617421
6
375.73920548 2 5.45654024
-350.54708476 2 5.82486421
-11.58800164 2 0.51173797
12.31935173 2 0.56805032
20.80334597 2 0.78399590
-20.53480959 2 1.25273408
6
6092.78689761 2 1.30970450
-6068.65474455 2 6.97688197
6074.16548241 2 6.96312742
-2.71306889 2 0.50000000
562.44223581 2 1.09627007
-6632.89448781 2 1.28901234
Ti GEN 18 2
6
4.00000000 1 4.58962911
29.78882355 2 12.99080675
-64.03604684 2 6.47044482
4.09908827 2 7.32890448
-3.09908827 2 0.86508310
18.35851644 3 11.66884823
6
204.54741131 2 6.98984163
-173.26765359 2 1.14387234
-179.62280834 2 7.98041969
81.98571631 2 1.30274954
-105.23530836 2 0.79373704
203.87378660 2 0.87617820
6
47.21398743 2 4.46327869
-17.03315162 2 12.03758238
-1.80345968 2 1.82986618
-67.65022794 2 0.85432599
83.23157126 2 0.75234069
-12.77614240 2 0.56466795
V GEN 18 2
6
5.00000000 1 4.80344323
22.35774108 2 18.78787979
-64.07198704 2 7.13216682
4.33388926 2 9.27213879
-3.33388926 2 0.97989891
24.01721615 3 16.08839186
6
180.61077610 2 8.25076842
-142.94184574 2 0.97905818
-150.64642751 2 9.92043295
-6.71407277 2 0.62363714
176.09329684 2 0.95148528
-17.73131270 2 1.07801133
6
57.45110361 2 5.32960287
-20.81111514 2 14.24980571
-8.29286428 2 1.85925508
-5.73287020 2 0.58593750
29.10022105 2 0.79878530
-14.07269455 2 1.00225258
Cr GEN 18 2
6
6.00000000 1 12.84308988
-3.09604991 2 0.99382054
-44.89504234 2 7.58819115
-170.55613293 2 14.51774012
171.55613293 2 16.43682827
77.05853926 3 12.82491986
6
-18202.34922306 2 1.98782159
18244.42867028 2 31.32646602
30868.09979612 2 30.37846452
17868.98085600 2 1.97809129
-49114.96837018 2 30.73273877
378.88775116 2 2.67913288
6
29.20236180 2 19.25203633
12.37319603 2 0.97567458
4072.48148684 2 17.43196546
-17623.52674725 2 16.30880219
0.00000000 2 1.00000000
13552.04578438 2 15.92770430
Mn GEN 18 2
6
7.00000000 1 15.05016398
76.06668034 2 15.84783194
-134.18719488 2 9.80426007
5.15310013 2 22.40715541
-4.15310013 2 1.28870598
105.35114786 3 9.24698903
6
5.29793560 2 36.81344701
46.23395617 2 10.22325416
-60.32817992 2 19.40077237
47.36691946 2 10.31192728
-593.48022661 2 0.82035751
607.44155846 2 0.82499832
6
43.56050065 2 39.11191097
6.67450664 2 5.89010993
273.74198710 2 12.39309544
-27.45450618 2 46.10455298
-256.40166892 2 15.13448958
11.11513392 2 0.96513012
Fe GEN 18 2
6
8.00000000 1 15.22430826
44.74166498 2 23.61492800
-111.48295214 2 10.92989564
4.87905385 2 34.25190536
-3.87905385 2 1.33822720
121.79446608 3 12.33553803
6
-19.50464924 2 30.77395752
78.13974335 2 10.21396062
-93.51149367 2 7.16717891
-5331.00729306 2 2.86167947
2973.12062964 2 2.65030718
2452.39961633 2 3.20024669
6
24692.89537881 2 35.68878072
-24635.37117467 2 1.90446408
67.20321584 2 9.50100295
-24719.85685234 2 35.67756831
155.45498669 2 2.48480944
24498.19947049 2 1.90126047
Co GEN 18 2
6
9.00000000 1 16.99448342
49.13807967 2 27.18614115
-125.28324533 2 12.21218102
5.11388765 2 39.14513799
-4.11388765 2 1.47717612
152.95035078 3 13.67966454
6
-14.42629264 2 42.14707531
80.80701231 2 9.38147677
-241.37463154 2 5.80599555
-2375.49390008 2 3.20236619
1470.87516654 2 3.85735739
1146.99509265 2 2.77670509
6
136.98013925 2 35.88691706
-71.59603354 2 2.32679268
69.29537053 2 14.47120857
-182.97334302 2 33.48566094
53.73921710 2 5.03596368
60.93980797 2 1.71252673
Ni GEN 18 2
6
10.00000000 1 22.08639324
-144.93688782 2 14.51813938
58.56151708 2 31.72005545
5.46467869 2 46.47610840
-4.46467869 2 1.64348434
220.86393239 3 17.23929992
6
-1037.96291767 2 23.63013626
1112.68285967 2 22.54579447
-202.88667032 2 10.67846148
-1992.46747856 2 2.78611652
261.70081349 2 7.26891690
1934.65478930 2 2.71695433
6
-53.30731307 2 26.78098186
127.09013633 2 3.54449677
-4806.85555998 2 9.97427088
4887.04372410 2 10.06368893
-212.17359382 2 2.46160888
132.98697057 2 1.97486742
Cu GEN 18 2
6
11.00000000 1 2.82733696
-34.48196386 2 1.92614044
-60.25585479 2 16.36117816
95.74606505 2 26.07073787
-94.74606505 2 15.23964803
31.10070652 3 2.17204001
6
-45.62927216 2 31.69953680
125.91417027 2 1.14930323
-14.54702824 2 1.62190112
4.20903863 2 5.04037704
108.15433753 2 13.02666762
-96.81611101 2 1.08245080
6
95.22440516 2 11.30741812
-15.05535618 2 0.88219501
50.51809351 2 1.10244974
-44.11033096 2 1.38963093
24.77977412 2 1.74927941
-30.18619193 2 36.48037929
Zn GEN 18 2
6
12.00000000 1 31.07239014
-200.01988966 2 17.28158695
92.10229536 2 34.39655496
5.98135501 2 49.89939973
-4.98135501 2 1.96865590
372.86868168 3 19.34259724
6
-36.14038802 2 38.52109994
128.37782465 2 12.00212013
-1.61496737 2 1.07625274
-1.83786181 2 49.67118376
65.46563590 2 2.17772473
-61.01291439 2 3.24812913
6
-65.64354860 2 18.09701361
156.02859885 2 36.00255883
172.20201747 2 14.96596000
-192.17040837 2 36.71242576
4.39165632 2 5.39429237
16.57829500 2 1.49031308
Ga GEN 28 2
6
3.00000000 1 1.13608798
164.07678897 2 1.26217688
-167.28328999 2 1.14858151
-669.79177234 2 1.15353581
670.79177234 2 1.12952095
3.40826394 3 1.10744970
6
2326.37321481 2 0.75031475
-2323.38047364 2 0.75000124
386.83516033 2 2.39556890
3373.92258044 2 1.92296729
-3444.97340674 2 2.01243025
-314.78429931 2 1.54022372
6
-49.00749762 2 0.97248539
49.23559677 2 1.12030491
13.15736344 2 1.17799318
125.85888665 2 1.43966818
-194.32447492 2 1.61975153
56.31063114 2 1.96345236
Ge GEN 28 2
6
4.00000000 1 1.37803409
19.62241898 2 1.39153725
-23.72148814 2 1.27769848
2.49161805 2 1.59279926
-1.49161805 2 0.64699203
5.51213636 3 0.92923210
6
-2.74466220 2 0.87224298
6.62035166 2 1.17293014
-2420.40847648 2 1.99495027
-82306.43955717 2 2.42954180
6740.23721390 2 2.16484262
77987.61073589 2 2.43883104
6
-2107.38453991 2 1.16911036
2108.21076604 2 1.46731756
1481.43044167 2 1.13494844
-5605.67944848 2 1.57427397
1698.46708565 2 1.69705377
2426.78290985 2 1.49642085
As GEN 28 2
6
5.00000000 1 1.43022249
-9.34297986 2 1.49610460
4.21498088 2 6.47107540
10.09813510 2 3.25241162
-9.09813510 2 5.07144325
7.15111245 3 1.33657021
6
13218.94379269 2 1.93743539
-13214.39886844 2 1.06114866
-12968.43207956 2 1.94924972
13915.97822491 2 1.06566409
-954.00698285 2 1.23265097
7.46088753 2 4.89271387
6
1464.46500602 2 1.99905491
-1463.07044815 2 1.47578217
368.93680276 2 1.30626554
-20015.22902646 2 1.76510607
-4931.41969774 2 1.62454622
24578.71284776 2 1.71245824
Se GEN 28 2
6
6.00000000 1 1.51096144
18985.66456772 2 2.92355341
-18994.15945825 2 2.92032845
-67662.27071451 2 3.11248219
67663.27071451 2 3.11189793
9.06576863 3 1.65761092
6
9.98441274 2 1.51889669
-2.50844675 2 1.97738476
-180236.05319146 2 2.70806322
388717.66809223 2 2.76186155
-395809.31847294 2 2.85646715
187328.70401255 2 2.90992434
6
-0.64003892 2 1.60286011
4.75615253 2 1.39335643
-1221.08696720 2 2.09669307
-10412.15615824 2 2.41527013
11345.50935270 2 2.36453165
288.73492615 2 3.03391531
Br GEN 28 2
6
7.00000000 1 1.41289916
-7.52651514 2 1.15658370
-0.55005317 2 2.42725255
32.50767838 2 2.88316202
-31.50767838 2 2.65601102
9.89029412 3 1.40346702
6
28526.73706896 2 2.34791729
-28520.73498833 2 2.45113975
-99003.29767895 2 2.50553756
749850.19071550 2 2.81179865
-1128475.81390516 2 2.78141408
477629.92118992 2 2.68265676
6
17.76908748 2 1.31119911
-15.01578842 2 1.60289186
-18723.09651802 2 2.55330648
-655.15159005 2 2.02749820
16349.83148583 2 2.49321553
3029.41777740 2 2.76331597
Kr GEN 28 2
6
8.00000000 1 8.52108317
-122698.81335772 2 3.24264497
122687.31930993 2 3.40822193
-118092.31104849 2 3.40804203
118093.31104849 2 3.23631062
68.16866536 3 4.68396906
6
-494.70169718 2 5.76331362
503.25343741 2 2.73098609
-367021.57369848 2 3.66759371
-1529686.47073208 2 3.83008505
1834642.13235417 2 3.78655002
62066.91317383 2 4.17980892
6
-73.83484449 2 5.20603747
79.00632901 2 4.70236432
1062.70264892 2 4.15470411
-40873.21549348 2 3.08586486
43280.45283221 2 3.10363880
-3468.93856436 2 3.63224008
Al GEN 10 2
6
3.00000000 1 0.91821413
-12.79791788 2 1.10715442
7.32796626 2 2.03989390
-52053.92058080 2 2.04204466
52054.92058080 2 2.04199047
2.75464240 3 0.94029840
6
-42.72903905 2 1.99445589
47.15203530 2 1.12469986
3231.39534748 2 1.72843552
-398.06113457 2 1.37872018
6652.21368423 2 1.92811339
-9484.54780105 2 1.87995009
6
830.07508675 2 1.87943518
-827.97758021 2 1.42508183
-1235.04705829 2 1.80941062
-21.40768628 2 0.95469299
154.21154335 2 1.20079877
1103.24388863 2 1.53169350
Si GEN 10 2
6
4.00000000 1 1.22418085
40.72596063 2 2.05337336
-48.11509746 2 1.71412850
-37.28006653 2 2.41395005
38.28006653 2 2.32084434
4.89672339 3 1.35299631
6
-7.68509694 2 1.13070385
13.98411213 2 1.16859753
-116498.38332824 2 2.36994226
-9121.48068622 2 2.16734100
31941.11999828 2 2.44879942
93679.74429067 2 2.32322104
6
41248.64599856 2 1.86811003
-41245.51022334 2 2.10179754
-60.37864776 2 1.33467919
4180.55486914 2 2.29835912
-142125.41164262 2 1.93345601
138006.23630568 2 1.99192523
P GEN 10 2
6
5.00000000 1 3.71332384
-13724.87406260 2 3.31759335
13714.20593187 2 3.65850189
-19470.81568886 2 3.61426447
19471.81568886 2 3.37579099
18.56661922 3 2.21831587
6
-1411.99322697 2 3.20289077
1421.31824558 2 2.14807352
576236.74902855 2 2.65372234
-397754.23263905 2 2.69778221
-194403.08693812 2 2.58386669
15921.57087605 2 2.99361065
6
64.03084909 2 2.59482433
-58.63734715 2 3.43313766
365.80442210 2 2.95557705
-12.13895471 2 1.75387879
158.27628825 2 3.69699906
-510.94109430 2 3.15077203
S GEN 10 2
6
6.00000000 1 2.51977085
-84.83332404 2 3.22007986
70.54487302 2 4.71655238
3581.56671658 2 4.39998291
-3580.56671658 2 4.41784559
15.11862509 3 2.54586294
6
-231.72652822 2 4.61819246
244.26248418 2 2.30938314
-920.53494189 2 2.65072450
2410.83323256 2 3.31119070
-2429.46016726 2 3.80226712
940.16251250 2 4.46824294
6
957.88712772 2 4.48874898
-950.12559451 2 3.37845034
6481.05990210 2 3.83307173
-157.23448173 2 1.92699416
186.18956071 2 1.98946862
-6509.01396292 2 3.99439281
Cl GEN 10 2
6
7.00000000 1 6.06473582
-454.17116717 2 5.57110302
436.13184861 2 5.26917938
-712.97599461 2 4.62455647
713.97599461 2 4.94326867
42.45315074 3 3.47635853
6
3561.38023524 2 4.48278574
-3545.84042135 2 3.43372818
-348465.51723117 2 3.74855830
12627.08188052 2 3.20650110
404246.19776785 2 3.70673786
-68406.76197098 2 3.45681590
6
19.30024745 2 3.79400952
-9.26766424 2 3.06020678
508.81151546 2 4.47438492
-7.59455659 2 2.43219723
-757.15587217 2 4.97983429
256.93953188 2 5.71145786
Ar GEN 10 2
6
8.00000000 1 3.61306766
326.13269394 2 4.01911273
-346.66642426 2 5.31624938
-7083.13498801 2 4.62848435
7084.13498801 2 4.70295676
28.90454131 3 3.84612203
6
323.59441180 2 3.28236424
-306.35028843 2 3.72212609
-6283.46399338 2 4.23452843
435312.63926384 2 4.90386840
20087.00527001 2 5.30220051
-449115.17955704 2 4.93088566
6
-2470.88386165 2 5.66191962
2481.68427537 2 4.62960722
48097.69821672 2 2.45115265
-48060.46858390 2 2.45082141
-1386.79918148 2 4.23753203
1350.57102634 2 6.12344921
Ag GEN 36 2
6
11.00000000 1 7.02317516
178.71479273 2 1.36779344
-206.54166000 2 1.85990342
92.80009949 2 2.70385827
-91.80009949 2 1.21149868
77.25492677 3 2.46247055
6
-19159.46923372 2 2.56205947
19178.09022506 2 3.28075183
-19956.12207989 2 3.86486918
12405.48540805 2 2.42437953
-8569.95659418 2 5.14643113
16121.59197935 2 4.79642660
6
-1054.66284551 2 1.92427691
1072.38275494 2 1.94184452
-1.15533162 2 27.95704514
88.48945385 2 1.25545336
-0.36033231 2 10.04954095
-85.97371403 2 1.49011553

292
data/pseudo/tn_df_sc Normal file
View File

@ -0,0 +1,292 @@
Sc GEN 12 2
8
9.00000000 1 18.44478556
-28.08765281 2 1.72227091
6.39250114 2 38.78217945
135.57316128 3 4.25767220
30.42990876 3 30.59237471
732.69856731 4 3.04901650
-839.18407578 4 3.26586693
306.02608763 4 19.55311974
8
-0.66275990 2 28.84167604
15.34001225 2 2.35022973
-2135.70086146 3 2.36887926
-272.32226474 3 1.53860208
2408.02312621 3 2.24659807
101.49528202 4 3.20659052
2308.19070504 4 1.65816906
-2392.74854053 4 1.70062176
8
253.56902450 2 1.38158346
-244.79525414 2 7.79906720
613.28437434 3 3.46268859
-167.40250936 3 1.44953060
-445.88186498 3 4.19986338
-558.92885001 4 2.84253773
-139.52186395 4 8.10103826
-860.39715397 4 5.29686620
Ti GEN 12 2
8
10.00000000 1 22.29649672
-72305.15340277 2 6.07562013
72279.39956641 2 7.08549167
-5.38004642 3 1.85317121
228.34501358 3 11.48488557
72347.84359974 4 6.58565089
-36.31015055 4 10.79509368
524.90430538 4 4.36759114
8
-1486.27686725 2 1.90199524
1504.05739312 2 3.17280244
-346.63236251 3 7.28185273
297.60206194 3 1.60782556
49.03030057 3 31.70876802
1363.17044217 4 2.57136209
173.13661454 4 15.10326471
408.87838151 4 10.51280239
8
770.58828172 2 4.79017059
-760.06500844 2 16.39428027
4131.47101858 3 2.73641831
-2.86068712 3 1.26533109
-4128.61033146 3 2.75566672
-4681.55429918 4 13.54811035
-216.64417046 4 3.18165696
-3871.27097394 4 7.38011991
V GEN 12 2
8
11.00000000 1 7.61152016
-2254.24090893 2 3.39807975
2224.02899636 2 6.97361870
-110446453.80565737 3 4.55862146
110446537.53237911 3 4.55862102
3279.23908558 4 3.96488312
110445429.80748074 4 5.79893896
-110440859.60674113 4 5.79892709
8
793493.20383269 2 1.90936932
-793472.27490442 2 1.96341714
-208.86387558 3 5.49944355
258.48298732 3 4.42141770
-49.61911175 3 2.27427679
-42873.55595686 4 1.93670396
-750668.26686351 4 13.81929388
750696.33209725 4 13.81951796
8
563.75098077 2 2.73920868
-551.25384718 2 8.34159772
565.60881231 3 6.86565518
-552.54712531 3 7.02672916
-13.06168700 3 1.72160118
766.15325384 4 5.21722741
-1341.96583800 4 3.64504781
-2478.29367021 4 6.45896159
Cr GEN 12 2
8
12.00000000 1 37.30558989
-31.65683900 2 2.72495980
-3.82112970 2 82.35078893
-1340.05228092 3 5.03605834
1787.71935961 3 8.49223479
1670.38275859 4 5.05934149
-297.67363866 4 11.22316422
-1773.64577915 4 12.78798168
8
1321.32584937 2 2.01494487
-1297.16280545 2 9.11769637
172456.79432585 3 2.74640213
-172130.54143941 3 2.73601029
-326.25288644 3 8.22966405
3318.19479259 4 8.93660753
-4964.77333719 4 4.18996691
-7518.15931266 4 8.08712175
8
426.08303476 2 2.13852920
-410.95463497 2 6.95873057
-26339.61341213 3 10.51865586
27348.01671881 3 10.59655900
-1008.40330668 3 12.57249470
-1190.97633771 4 3.81958382
-242.50982893 4 2.30397730
-515.04540222 4 8.50147041
Mn GEN 12 2
8
13.00000000 1 5.18371402
-578541.89058487 2 5.06065032
578503.38848415 2 6.70792867
-51913.84692424 3 6.17952209
51981.23520653 3 6.17539491
363344.02202434 4 6.42176078
267112.71548476 4 5.85884127
322304.52239107 4 5.30004030
8
1419.16815158 2 2.36735511
-1393.80593768 2 10.44777616
90835.30824196 3 3.38832573
-87236.54130341 3 3.33976449
-3598.76693855 3 4.59371397
-6244.54083570 4 4.53305698
1227.60592152 4 6.80451212
-6185.56255228 4 8.40561309
8
4024.75281098 2 2.94114594
-4009.68099577 2 7.86104996
6036.24229971 3 5.47734943
597.55987937 3 7.26632213
-6633.80217908 3 5.64966653
-8536.73955532 4 4.35053539
-2120.81538582 4 3.10976563
-9025.36229250 4 6.88076377
Fe GEN 12 2
8
14.00000000 1 5.12237041
-40.17016318 2 2.51511645
-1.31093574 2 68.88205922
233.53970769 3 8.04518971
-161.82652195 3 11.87602774
-1791.82033120 4 5.09693593
1599.45078669 4 4.72210640
1.03695301 4 1.70594204
8
26.70612465 2 1.98046097
0.57578912 2 129.99498266
3039.39666376 3 2.39996246
-3165.32503397 3 2.43500497
125.92837021 3 5.42607639
-291.65810402 4 8.00515516
391.88052787 4 5.38996549
27.51771082 4 21.57361672
8
624.99065580 2 2.73200743
-610.14663705 2 8.14205971
1017.89543597 3 6.81776145
-40.92293045 3 25.88593190
-976.97250552 3 5.88766735
-1433.26030940 4 3.94271278
-167.70300401 4 2.68547503
-1659.40792313 4 8.24853344
Co GEN 12 2
8
15.00000000 1 7.54679164
144513.79744165 2 3.67362404
-144558.25171900 2 4.84501436
107.53071842 3 2.40342575
5.67115611 3 26.17864786
-58433.23776581 4 3.80837544
-86187.09039425 4 4.51680318
-24877.11683436 4 4.40937071
8
95.23258759 2 2.24610518
-66.50913381 2 5.03497074
5039.10184384 3 3.22714612
106438.82887427 3 4.39051698
-111477.93071810 3 4.34028955
-3416.23892647 4 3.35420522
-108155.92422115 4 5.08283495
111451.19401338 4 5.04411598
8
595.60664332 2 4.48956443
-581.05689813 2 7.69628175
-1377.49199281 3 3.90883087
825.53641688 3 4.85597858
551.95557593 3 2.42496884
-403.44284159 4 2.48937518
360.79216631 4 7.08237042
-1755.31252545 4 7.01264199
Ni GEN 12 2
8
16.00000000 1 7.69817381
1050.11428773 2 7.53303210
-1144.28791364 2 25.60798551
13641.04856576 3 13.90272560
-13517.87778478 3 14.02243059
-99.93959073 4 5.40919366
-14590.22326277 4 19.39187326
-6702.20081903 4 10.04177364
8
-137324.04248861 2 3.00959957
137399.59146577 2 2.97820277
137895.50489379 3 3.20429852
-1036.38091066 3 8.22563766
-136859.12398313 3 3.17346613
1370.72380067 4 18.22958633
-904.80564965 4 6.63637638
-4552.45338879 4 4.01705177
8
-315.28909178 2 15.14825706
371.76324185 2 5.57172908
471.27416207 3 2.88437623
165.43855728 3 3.75784965
-636.71271936 3 3.41699124
-172.18113847 4 5.67830819
-148.24251004 4 2.70288433
-2384.29249546 4 8.91177457
Cu GEN 12 2
8
17.00000000 1 14.72121260
0.43564135 2 173.23217215
-51.26559465 2 2.58024469
3.82433122 3 80.09883693
246.43628291 3 9.08368916
6456.72306266 4 4.49885474
-6459.98303523 4 4.56436500
-53.55070822 4 20.14135032
8
-7.61322720 2 104.42478595
38.51618543 2 3.64199543
-12.00344193 3 52.46064977
288.99573247 3 4.33410703
-276.99229053 3 8.38373584
876.14551285 4 3.01347300
-1144.52462196 4 3.25680498
-386.35474053 4 59.52152812
8
142.97388030 2 48.08520852
-128.80933064 2 49.90034500
-186.15554307 3 11.18440029
180.45159943 3 5.04653753
5.70394364 3 85.01391269
101.90155258 4 3.06268644
-238.17133323 4 3.55821337
583.56858981 4 22.24622222
Zn GEN 12 2
8
18.00000000 1 16.25309578
-62.06001046 2 3.04359000
8.22443626 2 52.31604625
284.31836352 3 4.12635237
8.23736049 3 129.68855961
11442.99692797 4 7.94323624
-11664.25528103 4 7.74821809
462.64311342 4 34.44853266
8
140.30017448 2 3.16683649
-108.24959569 2 14.80839343
88.79372352 3 43.94225321
949.52154936 3 3.34122685
-1038.31527288 3 8.34153430
780.81282740 4 18.34782011
-1958.42831296 4 4.00418064
18.92059615 4 597.07325481
8
664.93623774 2 5.16678579
-651.12455824 2 11.88724380
930.96426186 3 7.96788974
-913.07841414 3 5.27302550
-17.88584772 3 127.63757255
3275.61040524 4 37.54266998
-3957.43240479 4 9.90068894
-3622.67126499 4 37.33250038

785
data/pseudo/tn_hf Normal file
View File

@ -0,0 +1,785 @@
H GEN 0 2
6
1.00000000 1 33.97261756
-5.73227574 2 41.31028903
-0.09126064 2 25.25940941
-20.89980944 2 22.55290552
21.89980945 2 32.44131356
33.97261756 3 21.12884239
6
-792.10375913 2 18.05333002
788.69064150 2 28.72271273
243.76232429 2 17.34000000
1971.45741618 2 20.31094085
-1795.56663560 2 22.08154655
-418.65661775 2 30.98799599
6
20.17177614 2 43.35000000
-21.74798121 2 30.58059209
81.48044293 2 43.35000000
-250.69197995 2 42.07548166
88.72115024 2 36.90496619
81.48044293 2 43.35000000
He GEN 0 2
6
2.00000000 1 20.98762121
-33.61186426 2 22.14709418
24.51669349 2 23.61790706
130.14113834 2 15.38761786
-129.14113834 2 14.22621787
41.97524242 3 12.59257273
6
1056.41263785 2 13.17618363
-1062.28560366 2 23.62254131
-463.87351954 2 12.04168890
-676.20404915 2 15.14280380
-595.21618656 2 19.81607243
1736.29130578 2 22.34342328
6
428.21432838 2 21.71652417
-430.31401911 2 12.32378638
7327.65357096 2 14.04426129
-7501.20178041 2 14.34477832
827.37705616 2 17.58948890
-652.83515208 2 21.22706329
Li GEN 2 2
6
1.00000000 1 0.78732101
-2.23995793 2 0.79224763
0.10336496 2 1.79622268
4.26591073 2 1.83637465
-3.26591073 2 1.91213904
0.78732101 3 0.79291624
6
256.06005883 2 1.78312879
-255.07112703 2 0.95553059
89.99417499 2 0.87617279
271.48958394 2 1.09621549
-180.35430387 2 1.43900642
-180.12948429 2 1.83085147
6
-6.15265886 2 1.51120608
4.70876577 2 0.76936375
-145.31681550 2 0.76874061
-238.21930857 2 0.99080928
219.67347903 2 0.80457655
164.85986038 2 1.07164892
Be GEN 2 2
6
2.00000000 1 1.20639978
-5.40210132 2 1.18425537
1.72285109 2 2.81826911
2.83477794 2 2.37513515
-1.83477794 2 2.82920954
2.41279956 3 1.18219335
6
-1045.56923435 2 2.59240549
1047.78889524 2 1.41686040
-1899.02207714 2 1.48536195
1398.02036098 2 1.70076266
-696.17508584 2 2.03898393
1198.17691383 2 2.57766021
6
630.77503458 2 1.84421403
-632.64959849 2 1.13419132
441.30858401 2 1.13393716
435.76647651 2 1.22419150
-353.48689426 2 1.39760436
-522.59133089 2 1.88595068
B GEN 2 2
6
3.00000000 1 2.72292969
-11.77602579 2 2.41356794
5.22133296 2 4.60628004
0.40709712 2 3.81569642
0.59290288 2 4.75281449
8.16878906 3 2.42655010
6
-259.65579181 2 2.54943794
264.77623108 2 4.54559309
79.19161122 2 2.15270531
-59.67150303 2 2.71820746
4276.39654293 2 3.54458188
-4294.91608677 2 3.65732479
6
236.40878048 2 3.85965228
-239.02058908 2 2.15130911
4065.68265375 2 2.50786619
-4354.92616892 2 2.58144728
782.08428825 2 3.14947869
-491.84514677 2 3.69136935
C GEN 2 2
6
4.00000000 1 6.85924392
-68.83281650 2 7.67473342
58.31001518 2 8.89832626
-5.23010100 2 4.63334409
6.23010100 2 5.40036758
27.43697568 3 6.78357071
6
15927.37261280 2 7.83879438
-15918.16480090 2 5.19308059
2266.75441213 2 7.53204263
199.75030501 2 9.76960112
15915.92435302 2 5.19521204
-18381.42723477 2 7.82847044
6
-153360.42295057 2 4.77965478
153356.81223147 2 7.75552602
-369415.66050006 2 7.39994991
152547.92039307 2 4.77641318
-50035.07991665 2 8.01352516
266903.80850142 2 7.30461659
N GEN 2 2
6
5.00000000 1 11.01983025
-745.67280403 2 7.70260962
729.30210222 2 7.83791198
-3.61639106 2 8.41784728
4.61639106 2 12.53426384
55.09915126 3 6.76845507
6
190.73305357 2 10.95092720
-176.25003778 2 7.48977970
138618.50426238 2 6.17989888
-156031.83911197 2 6.21713643
33624.66842989 2 6.84042808
-16210.33273520 2 7.23938652
6
-6963.78021671 2 6.00000000
6959.42174113 2 6.82157159
-1881.92821431 2 8.95497565
13576.39988827 2 6.21477468
-14307.35309373 2 6.69426410
2613.87687182 2 8.63240466
O GEN 2 2
6
6.00000000 1 8.86965578
-28.03502457 2 6.05347085
11.15565054 2 5.51487970
180.73182495 2 10.77996678
-179.73182495 2 10.23800841
53.21793471 3 7.90307811
6
-9301.89903913 2 7.28355994
9316.57793048 2 6.06026884
59864.04331135 2 10.82203807
-5153.55178109 2 5.75221581
-94673.29831259 2 10.51025188
39963.80850689 2 9.71187643
6
1682.75815189 2 6.93414347
-1694.05800561 2 5.70161443
848.47217112 2 5.90927487
-8787.11179775 2 8.69956320
7632.94108771 2 8.89513889
306.69604455 2 4.97067782
F GEN 2 2
6
7.00000000 1 16.52363418
-6.34751135 2 13.25777643
-15.15415075 2 18.76649923
-34.29784879 2 10.97564997
35.29784879 2 21.10568925
115.66543928 3 13.45706123
6
3851.10542697 2 18.85020393
-3832.40250429 2 12.48878559
-237433.87385812 2 13.23599298
4380.91891820 2 11.79852686
240164.95590264 2 13.28196243
-7110.99868861 2 17.38283172
6
-154.12048513 2 8.59949907
138.11297468 2 9.44224375
90.42851925 2 8.92886754
24.83173716 2 10.18592724
-424.59591732 2 14.47166344
310.33244840 2 16.45175456
Ne GEN 2 2
6
8.00000000 1 21.65168713
1792.30188007 2 14.45374325
-1826.14661180 2 14.11313946
24.26469360 2 14.10779016
-23.26469360 2 20.42281751
173.21349705 3 11.94458523
6
-3233.03788910 2 12.39056574
3263.09949012 2 20.60119535
1065.47298248 2 11.30677784
846.05067282 2 12.27737462
-34052.05079344 2 17.82669542
32141.52790433 2 17.34318949
6
64989.42116117 2 20.31242587
-65003.08394100 2 20.05277414
-486.55828399 2 12.87396775
2895.04182579 2 15.84533388
-261.91821074 2 19.42277681
-2145.56672184 2 23.82700477
K GEN 18 2
6
1.00000000 1 0.68724959
7665.13435390 2 0.62381187
-7668.26785841 2 0.59278246
-3877.60874288 2 0.63961163
3878.60874288 2 0.57860350
0.68724959 3 0.50008691
6
477943.00813868 2 0.60446875
-477941.36080643 2 0.55281419
-533027.54468668 2 0.57763214
644866.44840953 2 0.56624742
-347063.87255621 2 0.60823749
235225.96911606 2 0.54903924
6
5177368.01138896 2 0.56835236
-5177366.94506877 2 0.57395949
479730.23987439 2 0.65183506
1027151.48932830 2 0.60393420
-737636.25038898 2 0.55451546
-769244.47868615 2 0.64345811
Ca GEN 18 2
6
2.00000000 1 1.02097432
-10036.20006734 2 0.76570985
10030.67757963 2 0.83608195
-8136.00883920 2 0.84362927
8137.00883920 2 0.75729596
2.04194863 3 0.94514267
6
-34706.02643508 2 0.85912364
34710.12533681 2 0.50000000
860.68953329 2 0.79227941
33806.87817612 2 0.85997136
-34747.30927870 2 0.50004940
80.74228959 2 1.01833438
6
514.89542915 2 0.50045897
-511.93073005 2 0.57886998
-1374495660.24999190 2 0.50000000
687246875.87136328 2 0.50000000
595.96081232 2 0.56402502
687248189.41960287 2 0.50000000
Sc GEN 18 2
6
3.00000000 1 8.57059896
39.59298139 2 7.59719947
-67.37349200 2 5.06179469
3.54689568 2 11.85222547
-2.54689568 2 0.70815643
25.71179688 3 5.04858060
6
414.99811890 2 5.58945823
-389.30527335 2 5.93611719
8.74915776 2 0.56803113
-23.92388226 2 0.60868170
42.12589000 2 0.76957270
-25.95178014 2 1.21300456
6
87.05758924 2 1.12946939
-62.19670511 2 8.56362761
66.37833241 2 7.27494713
16.41391965 2 0.74327556
43.70031508 2 2.03252459
-125.49197853 2 1.19227023
Ti GEN 18 2
6
4.00000000 1 4.77516915
28.34758957 2 10.86929502
-63.21363466 2 5.37319310
5.17935660 2 6.86168513
-4.17935660 2 0.95669336
19.10067660 3 3.52162434
6
211.66189616 2 7.01854391
-179.82099411 2 1.03880358
-185.28466640 2 8.02474194
43.44334388 2 1.22490803
-44.06205312 2 0.73917909
186.90335758 2 0.89595855
6
49.26886952 2 4.65596397
-18.32131307 2 12.03001514
-5.50633295 2 2.16547114
-342.25486254 2 0.92182600
304.90681508 2 0.90099079
43.85505055 2 0.99684289
V GEN 18 2
6
5.00000000 1 7.54069430
35.58763613 2 13.63949328
-78.03044429 2 6.35551182
6.53716910 2 2.59423528
-5.53716910 2 1.16176108
37.70347150 3 6.00940761
6
194.57815114 2 8.18606241
-156.25972501 2 0.95585889
-162.29334861 2 9.81441300
-7.74379387 2 0.70017858
244.84040986 2 0.97854682
-73.80312462 2 1.14925292
6
58.91069981 2 5.48333809
-21.55840127 2 14.40777862
-10.12891199 2 2.12080402
2.52953175 2 0.69388688
109.28174657 2 1.01378564
-100.68144081 2 1.02780261
Cr GEN 18 2
6
6.00000000 1 5.86829616
-3.09900314 2 0.98487638
-44.94655388 2 6.96616660
135.46731129 2 13.59887742
-134.46731129 2 11.34882544
35.20977696 3 8.91110617
6
-526.12421414 2 1.73784849
568.24328209 2 32.55674074
-4019.88240027 2 29.55364033
495.64908693 2 1.64707294
3445.48735974 2 29.05037955
79.74580069 2 3.85284016
6
31.31844062 2 19.50625909
10.30743573 2 0.86978393
-81.88780266 2 15.20370471
461.22634080 2 10.28610919
1.00599253 2 29.84121604
-379.34381792 2 10.93761710
Mn GEN 18 2
6
7.00000000 1 15.05016398
76.91199595 2 15.84783194
-135.08366030 2 9.80426007
5.12036990 2 21.62193241
-4.12036990 2 1.26331891
105.35114786 3 9.24698903
6
4.45077705 2 37.07900996
46.93892122 2 10.09409180
-59.63952162 2 18.98557107
47.25376130 2 10.16267391
2270.38024432 2 0.79460121
-2256.99438460 2 0.79345224
6
43.65884288 2 39.18960573
6.58957965 2 5.88646925
273.41973132 2 12.35978155
-27.85882166 2 45.92825074
-255.64090683 2 15.10051906
11.08093098 2 0.96083847
Fe GEN 18 2
6
8.00000000 1 20.13246747
61.79343671 2 20.09868712
-128.55600523 2 10.70685691
4.84472314 2 28.79726611
-3.84472314 2 1.31374323
161.05973977 3 11.74858936
6
-20.21006220 2 30.42214774
78.68908034 2 10.18491881
-104.38370168 2 6.69228251
11879.61125830 2 2.98725076
4067.63536025 2 2.63900793
-15841.86182474 2 2.88538957
6
52.35701571 2 38.26448010
4.85142656 2 5.90250183
2169.08154283 2 14.09502191
-40.04038813 2 42.65213493
-2140.34005623 2 14.44188153
12.29991314 2 1.06050818
Co GEN 18 2
6
9.00000000 1 18.31609159
47.84627034 2 26.91264651
-123.98809879 2 11.91957078
5.09540361 2 38.50128360
-4.09540361 2 1.45636943
164.84482431 3 13.41744556
6
-22.55314559 2 34.07535172
88.75521276 2 10.45260699
-158.32924566 2 5.91087540
-53402.80058080 2 3.13684604
49767.17959800 2 3.16692544
3794.95155282 2 2.81533596
6
61.92019742 2 38.11279103
2.85881103 2 5.82898971
-387.27158530 2 15.59733227
-64.65478412 2 38.57519906
439.30094674 2 13.98109833
13.62664636 2 1.17046441
Ni GEN 18 2
6
10.00000000 1 19.84291404
-195.32353012 2 16.02128656
108.98533897 2 26.59513762
6.08469364 2 39.39261550
-5.08469364 2 1.73812596
198.42914037 3 16.63287860
6
636.14358475 2 21.00974643
-561.54325704 2 22.88188409
-146.65571659 2 11.08963477
1590.91833845 2 2.66405882
203.15470938 2 6.84512029
-1646.41568069 2 2.74451213
6
67.70992628 2 28.31556957
5.37743585 2 4.16521410
374.49405320 2 17.37825451
-389.83846114 2 21.96153313
1.91671522 2 49.74424984
14.42906054 2 1.27579002
Cu GEN 18 2
6
11.00000000 1 35.47715926
-18105.91023962 2 21.73013363
18011.23386368 2 21.83870561
6.01228206 2 18.42008793
-5.01228206 2 1.78198604
390.24875182 3 20.58922180
6
-51.41016015 2 31.92243640
131.47547623 2 14.07215286
-100490.54220540 2 4.21909683
20675.75763691 2 3.56801887
263590.56712535 2 4.06536588
-183774.78117039 2 3.92650866
6
68.62159615 2 31.47726702
10.70810140 2 4.95987737
233.01753836 2 17.95562228
-258.78181256 2 26.97191776
12.01106739 2 46.85069031
14.75422657 2 1.35614623
Zn GEN 18 2
6
12.00000000 1 26.60492300
-196.98442222 2 17.93401272
89.18558790 2 36.25784521
6.19159911 2 49.96784160
-5.19159911 2 1.99109193
319.25907600 3 19.77027094
6
-177.37971474 2 32.01501166
269.42130045 2 23.08836163
60361.29701582 2 4.67975974
1343973.13568915 2 5.29114502
-619902.07009680 2 5.11539109
-784431.36064381 2 5.38368747
6
46.22045015 2 19.08371294
43.98275320 2 50.00000000
103.59052598 2 16.88459979
-129.86700605 2 37.83300205
11.83058445 2 5.11918008
15.44716451 2 1.45112568
Ga GEN 28 2
6
3.00000000 1 1.29464779
1852.96920182 2 1.20541500
-1856.15440251 2 1.17879070
-513.51787928 2 1.21964580
514.51787928 2 1.12868888
3.88394338 3 1.06946118
6
-10.41248284 2 0.75266853
13.44253658 2 0.82344143
-163070.82529640 2 1.96346903
118782.06261627 2 1.90761481
72439.51450979 2 2.00432013
-28149.75180125 2 1.83309310
6
-55.43707314 2 0.98715132
55.68679311 2 1.18143237
95.35935510 2 1.24163917
-111.55606197 2 1.48647971
6.22134153 2 1.87957113
10.97737885 2 2.24689865
Ge GEN 28 2
6
4.00000000 1 0.64699203
1042.65966555 2 1.17600365
-1045.50742663 2 1.40672708
-522.21837337 2 1.06148136
523.21837337 2 1.52689039
2.58796812 3 0.70634661
6
298.52031462 2 1.37488700
-295.91758286 2 3.05395101
-65778.83466330 2 1.99750874
253302.61962618 2 2.10159773
25864.29161720 2 2.35028323
-213387.07659768 2 2.16152517
6
-1416.87913796 2 1.43279054
1416.49405157 2 1.27947333
-4677.12774504 2 1.39756889
6758.57740664 2 1.50728327
-2630.12555402 2 1.70834188
549.67778384 2 1.92912262
As GEN 28 2
6
5.00000000 1 1.90897798
-8.55267316 2 1.59326524
3.44617934 2 1.10844459
-8.94709126 2 1.02625257
9.94709126 2 1.90897549
9.54488990 3 1.18318262
6
-299.57003383 2 1.31601774
303.89084920 2 0.88992491
34018.91875930 2 0.82417957
-44808.38727678 2 0.87058735
19528.43031171 2 0.91644709
-8737.95845690 2 0.77833472
6
46094.50987530 2 1.90902784
-46093.10097169 2 1.56895782
-1934.82978262 2 1.41134047
-240427.05172601 2 1.84187044
36043.17172862 2 1.53235052
206319.71069040 2 1.81590910
Se GEN 28 2
6
6.00000000 1 1.73885845
-4868.76631948 2 3.10952817
4860.07291481 2 2.76656612
247376.94576273 2 2.93723435
-247375.94576273 2 2.93039894
10.43315069 3 1.80783830
6
43.48906338 2 1.54256367
-36.07303722 2 1.99876644
-1338.16209913 2 2.22244851
88855.15492433 2 3.01653570
-93322.17292948 2 3.00370283
5806.18068397 2 2.62760372
6
101.24952978 2 1.51703915
-96.89194467 2 1.50669503
-561.81915381 2 2.17759706
1474.30831735 2 2.47900419
-87533.83638244 2 3.02701983
86622.34849171 2 3.03071493
Br GEN 28 2
6
7.00000000 1 1.29861066
-8.22129971 2 1.15959643
0.21335410 2 2.29768788
-14617.16154553 2 2.88622041
14618.16154553 2 2.88664159
9.09027461 3 1.38987227
6
1993.56030565 2 1.99554365
-1988.14839885 2 2.18330258
62338.94920254 2 2.78298975
91516.94063906 2 2.50252605
-109846.25447802 2 2.70576408
-44008.63516555 2 2.38434210
6
17.36412726 2 1.29580803
-14.67327121 2 1.60078690
-6128.76923065 2 2.16344915
12563.02678529 2 2.26961184
757.63553722 2 2.83383736
-7190.89195704 2 2.41971949
Kr GEN 28 2
6
8.00000000 1 6.82429532
2245.94610147 2 4.82301962
-2257.24927570 2 3.38163452
1889.52842356 2 3.29088128
-1888.52842356 2 4.98656184
54.59436254 3 3.01373570
6
-2003.10975854 2 6.01573226
2010.79212346 2 4.07497664
13467772.94730707 2 4.47273823
-18464141.82809087 2 4.45030979
-2607955.84552628 2 4.28291762
7604325.72641131 2 4.35368575
6
-6512.57971257 2 5.33963561
6517.54562224 2 4.41831473
55170.14413687 2 3.66247372
-35314.20447418 2 3.56293692
-27094.88743738 2 3.99199621
7239.94695795 2 5.23539786
Al GEN 10 2
6
3.00000000 1 0.90167530
-12.07740634 2 1.08338853
6.60507677 2 2.07851308
-13877404.00590185 2 2.08053590
13877405.00590186 2 2.08053570
2.70502591 3 0.92748596
6
-41.26842670 2 2.04866185
45.70193781 2 1.11866688
2946.69575922 2 1.71721106
-376.01922297 2 1.36753958
4331.41613799 2 1.93292012
-6901.09265568 2 1.86705782
6
504.79904464 2 1.88548919
-502.69536383 2 1.42616967
-769.46860271 2 1.80548694
-17.66088618 2 0.95520911
101.43853505 2 1.20112583
686.69150206 2 1.52824179
Si GEN 10 2
6
4.00000000 1 2.54461774
-2902.58084906 2 2.24978528
2895.18838752 2 2.53789008
7161.72254279 2 2.34887222
-7160.72254279 2 2.46336277
10.17847098 3 1.52421025
6
4.24352962 2 1.08064949
2.05989979 2 1.33341749
88608.14855737 2 2.39993059
-849.93508619 2 1.92845396
-1434647.87047626 2 2.35634772
1346890.65714548 2 2.35320332
6
-15264.86061936 2 1.82998100
15267.99758945 2 1.91566514
-0.49522434 2 1.35066217
2807.17037795 2 2.16756956
6912.45723497 2 1.79762600
-9718.13169060 2 2.03990309
P GEN 10 2
6
5.00000000 1 2.20104239
-14571.76154266 2 3.30954781
14561.08785293 2 3.65491917
-21023.88213100 2 3.60582863
21024.88213100 2 3.36814532
11.00521195 3 2.06883762
6
-214.99423753 2 3.00175595
224.31212541 2 1.90508764
-1320.42895216 2 2.23252373
2262.27394007 2 2.56842585
-5217.11058123 2 3.22957222
4276.26614237 2 3.32169865
6
-4655.41288683 2 1.51251059
4660.80718311 2 1.51289861
-994.25816078 2 3.31761981
-19.30793578 2 2.04639527
311.57919748 2 3.70626860
702.98798215 2 3.09154453
S GEN 10 2
6
6.00000000 1 3.76431332
518.21506704 2 2.91975646
-532.35656437 2 2.26777538
14394.84387811 2 2.49556645
-14393.84387811 2 2.51698479
22.58587994 3 2.71241239
6
-104.19902150 2 4.55895180
116.57081427 2 2.10503756
-994.81335242 2 2.63814508
2203.13414043 2 3.11140569
-1617.61176296 2 3.62963239
410.29160018 2 4.55921172
6
723.09548214 2 4.48128068
-715.46568241 2 3.35956681
9063.41201304 2 3.83857196
-16.38228027 2 1.92699416
44.06704522 2 2.30670170
-9090.09577098 2 3.92706305
Cl GEN 10 2
6
7.00000000 1 4.77392870
719885.76609499 2 4.74019033
-719903.82223984 2 4.74189768
-37102.89380181 2 4.67979490
37103.89380181 2 4.71510215
33.41750090 3 3.29732864
6
959.05010082 2 5.01134618
-943.54843009 2 3.64529189
-6456.16063099 2 4.20510279
637.70704529 2 2.74283267
-1479.66774202 2 3.00605599
7299.12201388 2 3.90198120
6
-121.63220275 2 3.86324469
131.70125226 2 3.08695111
5447.27282828 2 5.92092153
-52.94814165 2 2.63467524
559.83762330 2 5.08437179
-5953.16139883 2 5.86183616
Ar GEN 10 2
6
8.00000000 1 5.17746158
-76.72264736 2 5.90884243
56.16280755 2 3.53735685
-660.63282107 2 4.53072721
661.63282107 2 4.90879705
41.41969264 3 3.95156133
6
496.48392385 2 3.21092458
-479.29969508 2 3.39224537
-12086.26924659 2 4.28061928
37151.97923364 2 4.62803105
496310.90908097 2 5.10487541
-521375.61810527 2 5.08995306
6
-1901.02320099 2 5.53714820
1911.87432982 2 4.52372637
-127.53875733 2 2.45115265
198.78501467 2 2.62001527
-976.26297293 2 3.97593759
906.01814260 2 6.12659776

BIN
data/qp.png Normal file
View File

Binary file not shown.
Side by Side

After

Width:  |  Height:  |  Size: 42 KiB

1
install/scripts/install_ocaml.sh
View File

@ -6,6 +6,7 @@ cd -
# Normal installation # Normal installation
PACKAGES="core cryptokit ocamlfind sexplib ZMQ" PACKAGES="core cryptokit ocamlfind sexplib ZMQ"
#ppx_sexp_conv
# Needed for ZeroMQ # Needed for ZeroMQ
export C_INCLUDE_PATH="${QP_ROOT}"/lib:"${C_INCLUDE_PATH}" export C_INCLUDE_PATH="${QP_ROOT}"/lib:"${C_INCLUDE_PATH}"

12
ocaml/Atom.ml
View File

@ -1,4 +1,4 @@
open Core.Std;; open Core.Std
exception AtomError of string exception AtomError of string
@ -27,12 +27,18 @@ let of_string ~units s =
coord = Point3d.of_string ~units (String.concat [x; y; z] ~sep:" ") coord = Point3d.of_string ~units (String.concat [x; y; z] ~sep:" ")
} }
| _ -> raise (AtomError s) | _ -> raise (AtomError s)
;;
let to_string ~units a = let to_string ~units a =
[ Element.to_string a.element ; [ Element.to_string a.element ;
Charge.to_string a.charge ; Charge.to_string a.charge ;
Point3d.to_string ~units a.coord ] Point3d.to_string ~units a.coord ]
|> String.concat ~sep:" " |> String.concat ~sep:" "
;;
let to_xyz a =
Printf.sprintf "%-3s %s"
(Element.to_string a.element)
(Point3d.to_string ~units:Units.Angstrom a.coord)

1
ocaml/Atom.mli
View File

@ -7,3 +7,4 @@ val sexp_of_t : t -> Sexplib.Sexp.t
val of_string : units:Units.units -> string -> t val of_string : units:Units.units -> string -> t
val to_string : units:Units.units -> t -> string val to_string : units:Units.units -> t -> string
val to_xyz : t -> string

20
ocaml/Basis.ml
View File

@ -35,11 +35,11 @@ let read_element in_channel at_number element =
read in_channel at_number read in_channel at_number
let to_string b =
let to_string_general ~fmt ~atom_sep b =
let new_nucleus n = let new_nucleus n =
Printf.sprintf "Atom %d" n Printf.sprintf "Atom %d" n
in in
let rec do_work accu current_nucleus = function let rec do_work accu current_nucleus = function
| [] -> List.rev accu | [] -> List.rev accu
| (g,n)::tail -> | (g,n)::tail ->
@ -47,15 +47,27 @@ let to_string b =
in in
let accu = let accu =
if (n <> current_nucleus) then if (n <> current_nucleus) then
(new_nucleus n)::""::accu (new_nucleus n)::atom_sep::accu
else else
accu accu
in in
do_work ((Gto.to_string g)::accu) n tail do_work ((Gto.to_string ~fmt g)::accu) n tail
in in
do_work [new_nucleus 1] 1 b do_work [new_nucleus 1] 1 b
|> String.concat ~sep:"\n" |> String.concat ~sep:"\n"
let to_string_gamess =
to_string_general ~fmt:Gto.Gamess ~atom_sep:""
let to_string_gaussian b =
String.concat ~sep:"\n"
[ to_string_general ~fmt:Gto.Gaussian ~atom_sep:"****" b ; "****" ]
let to_string ?(fmt=Gto.Gamess) =
match fmt with
| Gto.Gamess -> to_string_gamess
| Gto.Gaussian -> to_string_gaussian
include To_md5 include To_md5
let to_md5 = to_md5 sexp_of_t let to_md5 = to_md5 sexp_of_t

2
ocaml/Basis.mli
View File

@ -14,7 +14,7 @@ val read_element :
in_channel -> Nucl_number.t -> Element.t -> (Gto.t * Nucl_number.t) list in_channel -> Nucl_number.t -> Element.t -> (Gto.t * Nucl_number.t) list
(** Convert the basis to a string *) (** Convert the basis to a string *)
val to_string : (Gto.t * Nucl_number.t) list -> string val to_string : ?fmt:Gto.fmt -> (Gto.t * Nucl_number.t) list -> string
(** Convert the basis to an MD5 hash *) (** Convert the basis to an MD5 hash *)
val to_md5 : (Gto.t * Nucl_number.t) list -> MD5.t val to_md5 : (Gto.t * Nucl_number.t) list -> MD5.t

219
ocaml/Element.ml
View File

@ -9,6 +9,7 @@ type t =
|Li|Be |B |C |N |O |F |Ne |Li|Be |B |C |N |O |F |Ne
|Na|Mg |Al|Si|P |S |Cl|Ar |Na|Mg |Al|Si|P |S |Cl|Ar
|K |Ca|Sc|Ti|V |Cr|Mn|Fe|Co|Ni|Cu|Zn|Ga|Ge|As|Se|Br|Kr |K |Ca|Sc|Ti|V |Cr|Mn|Fe|Co|Ni|Cu|Zn|Ga|Ge|As|Se|Br|Kr
|Rb|Sr|Y |Zr|Nb|Mo|Tc|Ru|Rh|Pd|Ag|Cd|In|Sn|Sb|Te|I |Xe
with sexp with sexp
let of_string x = let of_string x =
@ -50,6 +51,24 @@ let of_string x =
| "Se" | "Selenium" -> Se | "Se" | "Selenium" -> Se
| "Br" | "Bromine" -> Br | "Br" | "Bromine" -> Br
| "Kr" | "Krypton" -> Kr | "Kr" | "Krypton" -> Kr
| "Rb" | "Rubidium" -> Rb
| "Sr" | "Strontium" -> Sr
| "Y" | "Yttrium" -> Y
| "Zr" | "Zirconium" -> Zr
| "Nb" | "Niobium" -> Nb
| "Mo" | "Molybdenum" -> Mo
| "Tc" | "Technetium" -> Tc
| "Ru" | "Ruthenium" -> Ru
| "Rh" | "Rhodium" -> Rh
| "Pd" | "Palladium" -> Pd
| "Ag" | "Silver" -> Ag
| "Cd" | "Cadmium" -> Cd
| "In" | "Indium" -> In
| "Sn" | "Tin" -> Sn
| "Sb" | "Antimony" -> Sb
| "Te" | "Tellurium" -> Te
| "I" | "Iodine" -> I
| "Xe" | "Xenon" -> Xe
| x -> raise (ElementError ("Element "^x^" unknown")) | x -> raise (ElementError ("Element "^x^" unknown"))
@ -91,6 +110,24 @@ let to_string = function
| Se -> "Se" | Se -> "Se"
| Br -> "Br" | Br -> "Br"
| Kr -> "Kr" | Kr -> "Kr"
| Rb -> "Rb"
| Sr -> "Sr"
| Y -> "Y"
| Zr -> "Zr"
| Nb -> "Nb"
| Mo -> "Mo"
| Tc -> "Tc"
| Ru -> "Ru"
| Rh -> "Rh"
| Pd -> "Pd"
| Ag -> "Ag"
| Cd -> "Cd"
| In -> "In"
| Sn -> "Sn"
| Sb -> "Sb"
| Te -> "Te"
| I -> "I"
| Xe -> "Xe"
let to_long_string = function let to_long_string = function
@ -131,6 +168,24 @@ let to_long_string = function
| Se -> "Selenium" | Se -> "Selenium"
| Br -> "Bromine" | Br -> "Bromine"
| Kr -> "Krypton" | Kr -> "Krypton"
| Rb -> "Rubidium"
| Sr -> "Strontium"
| Y -> "Yttrium"
| Zr -> "Zirconium"
| Nb -> "Niobium"
| Mo -> "Molybdenum"
| Tc -> "Technetium"
| Ru -> "Ruthenium"
| Rh -> "Rhodium"
| Pd -> "Palladium"
| Ag -> "Silver"
| Cd -> "Cadmium"
| In -> "Indium"
| Sn -> "Tin"
| Sb -> "Antimony"
| Te -> "Tellurium"
| I -> "Iodine"
| Xe -> "Xenon"
let to_charge c = let to_charge c =
@ -172,47 +227,83 @@ let to_charge c =
| Se -> 34 | Se -> 34
| Br -> 35 | Br -> 35
| Kr -> 36 | Kr -> 36
| Rb -> 37
| Sr -> 38
| Y -> 39
| Zr -> 40
| Nb -> 41
| Mo -> 42
| Tc -> 43
| Ru -> 44
| Rh -> 45
| Pd -> 46
| Ag -> 47
| Cd -> 48
| In -> 49
| Sn -> 50
| Sb -> 51
| Te -> 52
| I -> 53
| Xe -> 54
in Charge.of_int result in Charge.of_int result
let of_charge c = match (Charge.to_int c) with let of_charge c = match (Charge.to_int c) with
| 0 -> X | 0 -> X
| 1 -> H | 1 -> H
| 2 -> He | 2 -> He
| 3 -> Li | 3 -> Li
| 4 -> Be | 4 -> Be
| 5 -> B | 5 -> B
| 6 -> C | 6 -> C
| 7 -> N | 7 -> N
| 8 -> O | 8 -> O
| 9 -> F | 9 -> F
| 10 -> Ne | 10 -> Ne
| 11 -> Na | 11 -> Na
| 12 -> Mg | 12 -> Mg
| 13 -> Al | 13 -> Al
| 14 -> Si | 14 -> Si
| 15 -> P | 15 -> P
| 16 -> S | 16 -> S
| 17 -> Cl | 17 -> Cl
| 18 -> Ar | 18 -> Ar
| 19 -> K | 19 -> K
| 20 -> Ca | 20 -> Ca
| 21 -> Sc | 21 -> Sc
| 22 -> Ti | 22 -> Ti
| 23 -> V | 23 -> V
| 24 -> Cr | 24 -> Cr
| 25 -> Mn | 25 -> Mn
| 26 -> Fe | 26 -> Fe
| 27 -> Co | 27 -> Co
| 28 -> Ni | 28 -> Ni
| 29 -> Cu | 29 -> Cu
| 30 -> Zn | 30 -> Zn
| 31 -> Ga | 31 -> Ga
| 32 -> Ge | 32 -> Ge
| 33 -> As | 33 -> As
| 34 -> Se | 34 -> Se
| 35 -> Br | 35 -> Br
| 36 -> Kr | 36 -> Kr
| 37 -> Rb
| 38 -> Sr
| 39 -> Y
| 40 -> Zr
| 41 -> Nb
| 42 -> Mo
| 43 -> Tc
| 44 -> Ru
| 45 -> Rh
| 46 -> Pd
| 47 -> Ag
| 48 -> Cd
| 49 -> In
| 50 -> Sn
| 51 -> Sb
| 52 -> Te
| 53 -> I
| 54 -> Xe
| x -> raise (ElementError ("Element of charge "^(string_of_int x)^" unknown")) | x -> raise (ElementError ("Element of charge "^(string_of_int x)^" unknown"))
@ -255,6 +346,24 @@ let covalent_radius x =
| Se -> 0.70 | Se -> 0.70
| Br -> 1.24 | Br -> 1.24
| Kr -> 1.91 | Kr -> 1.91
| Rb -> 2.20
| Sr -> 1.95
| Y -> 1.90
| Zr -> 1.75
| Nb -> 1.64
| Mo -> 1.54
| Tc -> 1.47
| Ru -> 1.46
| Rh -> 1.42
| Pd -> 1.39
| Ag -> 1.45
| Cd -> 1.44
| In -> 1.42
| Sn -> 1.39
| Sb -> 1.39
| Te -> 1.38
| I -> 1.39
| Xe -> 1.40
in in
Units.angstrom_to_bohr *. (result x) Units.angstrom_to_bohr *. (result x)
|> Positive_float.of_float |> Positive_float.of_float
@ -298,6 +407,24 @@ let vdw_radius x =
| Se -> 1.70 | Se -> 1.70
| Br -> 2.10 | Br -> 2.10
| Kr -> 1.70 | Kr -> 1.70
| Rb -> 3.03
| Sr -> 2.49
| Y -> 0.
| Zr -> 0.
| Nb -> 0.
| Mo -> 0.
| Tc -> 0.
| Ru -> 0.
| Rh -> 0.
| Pd -> 1.63
| Ag -> 1.72
| Cd -> 1.58
| In -> 1.93
| Sn -> 2.17
| Sb -> 2.06
| Te -> 2.06
| I -> 1.98
| Xe -> 2.16
in in
Units.angstrom_to_bohr *. (result x) Units.angstrom_to_bohr *. (result x)
|> Positive_float.of_float |> Positive_float.of_float
@ -341,6 +468,24 @@ let mass x =
| Se -> 78.96 | Se -> 78.96
| Br -> 79.904 | Br -> 79.904
| Kr -> 83.80 | Kr -> 83.80
| Rb -> 85.4678
| Sr -> 87.62
| Y -> 88.90584
| Zr -> 91.224
| Nb -> 92.90637
| Mo -> 95.95
| Tc -> 98.
| Ru -> 101.07
| Rh -> 102.90550
| Pd -> 106.42
| Ag -> 107.8682
| Cd -> 112.414
| In -> 114.818
| Sn -> 118.710
| Sb -> 121.760
| Te -> 127.60
| I -> 126.90447
| Xe -> 131.293
in in
result x result x
|> Positive_float.of_float |> Positive_float.of_float

1
ocaml/Element.mli
View File

@ -6,6 +6,7 @@ type t =
|Li|Be |B |C |N |O |F |Ne |Li|Be |B |C |N |O |F |Ne
|Na|Mg |Al|Si|P |S |Cl|Ar |Na|Mg |Al|Si|P |S |Cl|Ar
|K |Ca|Sc|Ti|V |Cr|Mn|Fe|Co|Ni|Cu|Zn|Ga|Ge|As|Se|Br|Kr |K |Ca|Sc|Ti|V |Cr|Mn|Fe|Co|Ni|Cu|Zn|Ga|Ge|As|Se|Br|Kr
|Rb|Sr|Y |Zr|Nb|Mo|Tc|Ru|Rh|Pd|Ag|Cd|In|Sn|Sb|Te|I |Xe
with sexp with sexp
(** String conversion functions *) (** String conversion functions *)

35
ocaml/Gto.ml
View File

@ -4,6 +4,10 @@ open Qptypes
exception GTO_Read_Failure of string exception GTO_Read_Failure of string
exception End_Of_Basis exception End_Of_Basis
type fmt =
| Gamess
| Gaussian
type t = type t =
{ sym : Symmetry.t ; { sym : Symmetry.t ;
lc : ((Primitive.t * AO_coef.t) list) lc : ((Primitive.t * AO_coef.t) list)
@ -68,8 +72,8 @@ let read_one in_channel =
(** Transform the gto to a string *) (** Write the GTO in Gamess format *)
let to_string { sym = sym ; lc = lc } = let to_string_gamess { sym = sym ; lc = lc } =
let result = let result =
Printf.sprintf "%s %3d" (Symmetry.to_string sym) (List.length lc) Printf.sprintf "%s %3d" (Symmetry.to_string sym) (List.length lc)
in in
@ -88,3 +92,30 @@ let to_string { sym = sym ; lc = lc } =
|> String.concat ~sep:"\n" |> String.concat ~sep:"\n"
(** Write the GTO in Gaussian format *)
let to_string_gaussian { sym = sym ; lc = lc } =
let result =
Printf.sprintf "%s %3d 1.00" (Symmetry.to_string sym) (List.length lc)
in
let rec do_work accu i = function
| [] -> List.rev accu
| (p,c)::tail ->
let p = AO_expo.to_float p.Primitive.expo
and c = AO_coef.to_float c
in
let result =
Printf.sprintf "%15.7f %15.7f" p c
in
do_work (result::accu) (i+1) tail
in
(do_work [result] 1 lc)
|> String.concat ~sep:"\n"
(** Transform the gto to a string *)
let to_string ?(fmt=Gamess) =
match fmt with
| Gamess -> to_string_gamess
| Gaussian -> to_string_gaussian

6
ocaml/Gto.mli
View File

@ -1,5 +1,9 @@
exception GTO_Read_Failure of string exception GTO_Read_Failure of string
exception End_Of_Basis exception End_Of_Basis
type fmt =
| Gamess
| Gaussian
type t = type t =
{ sym : Symmetry.t ; { sym : Symmetry.t ;
lc : (Primitive.t * Qptypes.AO_coef.t) list; lc : (Primitive.t * Qptypes.AO_coef.t) list;
@ -13,4 +17,4 @@ val of_prim_coef_list :
val read_one : in_channel -> t val read_one : in_channel -> t
(** Convert to string for printing *) (** Convert to string for printing *)
val to_string : t -> string val to_string : ?fmt:fmt -> t -> string

1
ocaml/Input_ao_basis.ml
View File

@ -17,6 +17,7 @@ module Ao_basis : sig
;; ;;
val read : unit -> t option val read : unit -> t option
val to_string : t -> string val to_string : t -> string
val to_basis : t -> Basis.t
val write : t -> unit val write : t -> unit
val to_md5 : t -> MD5.t val to_md5 : t -> MD5.t
val to_rst : t -> Rst_string.t val to_rst : t -> Rst_string.t

17
ocaml/Input_nuclei.ml
View File

@ -13,6 +13,7 @@ module Nuclei : sig
val read : unit -> t option val read : unit -> t option
val write : t -> unit val write : t -> unit
val to_string : t -> string val to_string : t -> string
val to_atom_list : t -> Atom.t list
val to_rst : t -> Rst_string.t val to_rst : t -> Rst_string.t
val of_rst : Rst_string.t -> t option val of_rst : Rst_string.t -> t option
end = struct end = struct
@ -134,6 +135,22 @@ end = struct
;; ;;
let to_atom_list b =
let rec loop accu (coord, charge, label) = function
| -1 -> accu
| i ->
let atom =
{ Atom.element = label.(i) ;
Atom.charge = charge.(i) ;
Atom.coord = coord.(i) ;
}
in
loop (atom::accu) (coord, charge, label) (i-1)
in
loop [] (b.nucl_coord, b.nucl_charge, b.nucl_label)
( (Nucl_number.to_int b.nucl_num) - 1)
;;
let to_string b = let to_string b =
Printf.sprintf " Printf.sprintf "
nucl_num = %s nucl_num = %s

11
ocaml/Molecule.ml
View File

@ -85,7 +85,7 @@ let name m =
String.concat (result) String.concat (result)
let to_string m = let to_string_general ~f m =
let { nuclei ; elec_alpha ; elec_beta } = m let { nuclei ; elec_alpha ; elec_beta } = m
in in
let n = let n =
@ -94,10 +94,15 @@ let to_string m =
let title = let title =
name m name m
in in
[ Int.to_string n ; title ] @ [ Int.to_string n ; title ] @ (List.map ~f nuclei)
(List.map ~f:(fun x -> Atom.to_string Units.Angstrom x) nuclei)
|> String.concat ~sep:"\n" |> String.concat ~sep:"\n"
let to_string =
to_string_general ~f:(fun x -> Atom.to_string Units.Angstrom x)
let to_xyz =
to_string_general ~f:Atom.to_xyz
let of_xyz_string let of_xyz_string
?(charge=(Charge.of_int 0)) ?(multiplicity=(Multiplicity.of_int 1)) ?(charge=(Charge.of_int 0)) ?(multiplicity=(Multiplicity.of_int 1))

1
ocaml/Molecule.mli
View File

@ -20,6 +20,7 @@ val name : t -> string
(** Conversion for printing *) (** Conversion for printing *)
val to_string : t -> string val to_string : t -> string
val to_xyz : t -> string
(** Creates a molecule from an xyz file *) (** Creates a molecule from an xyz file *)

112
ocaml/TaskServer.ml
View File

@ -2,6 +2,23 @@ open Core.Std
open Qptypes open Qptypes
type pub_state =
| Waiting
| Running of string
| Stopped
let pub_state_of_string = function
| "Waiting" -> Waiting
| "Stopped" -> Stopped
| s -> Running s
let string_of_pub_state = function
| Waiting -> "Waiting"
| Stopped -> "Stopped"
| Running s -> s
type t = type t =
{ {
queue : Queuing_system.t ; queue : Queuing_system.t ;
@ -120,7 +137,7 @@ let stop ~port =
ZMQ.Socket.close req_socket ZMQ.Socket.close req_socket
let new_job msg program_state rep_socket = let new_job msg program_state rep_socket pair_socket =
let state = let state =
msg.Message.Newjob_msg.state msg.Message.Newjob_msg.state
@ -143,10 +160,12 @@ let new_job msg program_state rep_socket =
} }
in in
reply_ok rep_socket; reply_ok rep_socket;
string_of_pub_state (Running (Message.State.to_string state))
|> ZMQ.Socket.send pair_socket ;
result result
let end_job msg program_state rep_socket = let end_job msg program_state rep_socket pair_socket =
let failure () = let failure () =
reply_wrong_state rep_socket; reply_wrong_state rep_socket;
@ -165,7 +184,11 @@ let end_job msg program_state rep_socket =
| Some state -> | Some state ->
begin begin
if (msg.Message.Endjob_msg.state = state) then if (msg.Message.Endjob_msg.state = state) then
success state begin
string_of_pub_state Waiting
|> ZMQ.Socket.send pair_socket ;
success state
end
else else
failure () failure ()
end end
@ -355,7 +378,7 @@ let add_task msg program_state rep_socket =
let get_task msg program_state rep_socket = let get_task msg program_state rep_socket pair_socket =
let state, client_id = let state, client_id =
msg.Message.GetTask_msg.state, msg.Message.GetTask_msg.state,
@ -371,6 +394,12 @@ let get_task msg program_state rep_socket =
let new_queue, task_id, task = let new_queue, task_id, task =
Queuing_system.pop_task ~client_id program_state.queue Queuing_system.pop_task ~client_id program_state.queue
in in
if (Queuing_system.number_of_queued new_queue = 0) then
string_of_pub_state Waiting
|> ZMQ.Socket.send pair_socket
else
string_of_pub_state (Running (Message.State.to_string state))
|> ZMQ.Socket.send pair_socket;
let new_program_state = let new_program_state =
{ program_state with { program_state with
@ -512,18 +541,76 @@ let error msg program_state rep_socket =
|> ZMQ.Socket.send rep_socket ; |> ZMQ.Socket.send rep_socket ;
program_state program_state
let start_pub_thread ~port =
Thread.create (fun () ->
let timeout =
1000
in
let pair_socket =
ZMQ.Socket.create zmq_context ZMQ.Socket.pair
and address =
"inproc://pair"
in
ZMQ.Socket.connect pair_socket address;
let pub_socket =
ZMQ.Socket.create zmq_context ZMQ.Socket.pub
and address =
Printf.sprintf "tcp://*:%d" port
in
bind_socket ~socket_type:"PUB" ~socket:pub_socket ~address;
let pollitem =
ZMQ.Poll.mask_of
[| (pair_socket, ZMQ.Poll.In) |]
in
let rec run state =
let new_state =
let polling =
ZMQ.Poll.poll ~timeout pollitem
in
if (polling.(0) = Some ZMQ.Poll.In) then
ZMQ.Socket.recv ~block:false pair_socket
|> pub_state_of_string
else
state
in
ZMQ.Socket.send pub_socket @@ string_of_pub_state new_state;
match state with
| Stopped -> ()
| _ -> run new_state
in
run Waiting;
ZMQ.Socket.set_linger_period pair_socket 1000 ;
ZMQ.Socket.close pair_socket;
ZMQ.Socket.set_linger_period pub_socket 1000 ;
ZMQ.Socket.close pub_socket;
)
let run ~port = let run ~port =
(** Bind inproc socket for changing state of pub *)
let pair_socket =
ZMQ.Socket.create zmq_context ZMQ.Socket.pair
and address =
"inproc://pair"
in
bind_socket "PAIR" pair_socket address;
let pub_thread =
start_pub_thread ~port:(port+1) ()
in
(** Bind REP socket *) (** Bind REP socket *)
let rep_socket = let rep_socket =
ZMQ.Socket.create zmq_context ZMQ.Socket.rep ZMQ.Socket.create zmq_context ZMQ.Socket.rep
and address = and address =
Printf.sprintf "tcp://%s:%d" (Lazy.force ip_address) port Printf.sprintf "tcp://*:%d" port
in in
bind_socket "REP" rep_socket address;
ZMQ.Socket.set_linger_period rep_socket 1_000_000; ZMQ.Socket.set_linger_period rep_socket 1_000_000;
bind_socket "REP" rep_socket address;
let initial_program_state = let initial_program_state =
{ queue = Queuing_system.create () ; { queue = Queuing_system.create () ;
@ -542,6 +629,9 @@ let run ~port =
[| (rep_socket, ZMQ.Poll.In) |] [| (rep_socket, ZMQ.Poll.In) |]
in in
let address =
Printf.sprintf "tcp://%s:%d" (Lazy.force ip_address) port
in
Printf.printf "Task server running : %s\n%!" address; Printf.printf "Task server running : %s\n%!" address;
@ -591,15 +681,15 @@ let run ~port =
| _ , Message.Terminate _ -> terminate program_state rep_socket | _ , Message.Terminate _ -> terminate program_state rep_socket
| _ , Message.PutPsi x -> put_psi x rest program_state rep_socket | _ , Message.PutPsi x -> put_psi x rest program_state rep_socket
| _ , Message.GetPsi x -> get_psi x program_state rep_socket | _ , Message.GetPsi x -> get_psi x program_state rep_socket
| None , Message.Newjob x -> new_job x program_state rep_socket | None , Message.Newjob x -> new_job x program_state rep_socket pair_socket
| _ , Message.Newjob _ -> error "A job is already running" program_state rep_socket | _ , Message.Newjob _ -> error "A job is already running" program_state rep_socket
| Some _, Message.Endjob x -> end_job x program_state rep_socket | Some _, Message.Endjob x -> end_job x program_state rep_socket pair_socket
| None , _ -> error "No job is running" program_state rep_socket | None , _ -> error "No job is running" program_state rep_socket
| Some _, Message.Connect x -> connect x program_state rep_socket | Some _, Message.Connect x -> connect x program_state rep_socket
| Some _, Message.Disconnect x -> disconnect x program_state rep_socket | Some _, Message.Disconnect x -> disconnect x program_state rep_socket
| Some _, Message.AddTask x -> add_task x program_state rep_socket | Some _, Message.AddTask x -> add_task x program_state rep_socket
| Some _, Message.DelTask x -> del_task x program_state rep_socket | Some _, Message.DelTask x -> del_task x program_state rep_socket
| Some _, Message.GetTask x -> get_task x program_state rep_socket | Some _, Message.GetTask x -> get_task x program_state rep_socket pair_socket
| Some _, Message.TaskDone x -> task_done x program_state rep_socket | Some _, Message.TaskDone x -> task_done x program_state rep_socket
| _ , _ -> | _ , _ ->
error ("Invalid message : "^(Message.to_string message)) program_state rep_socket error ("Invalid message : "^(Message.to_string message)) program_state rep_socket
@ -614,6 +704,10 @@ let run ~port =
end end
in main_loop initial_program_state true; in main_loop initial_program_state true;
ZMQ.Socket.send pair_socket @@ string_of_pub_state Stopped;
Thread.join pub_thread;

84
ocaml/TaskServer.mli Normal file
View File

@ -0,0 +1,84 @@
type t =
{
queue : Queuing_system.t ;
state : Message.State.t option ;
address_tcp : Address.Tcp.t option ;
address_inproc : Address.Inproc.t option ;
psi : Message.Psi.t option;
progress_bar : Progress_bar.t option ;
running : bool;
}
(** {1} Debugging *)
(** Fetch the QP_TASK_DEBUG environment variable *)
val debug_env : bool
(** Print a debug message *)
val debug : string -> unit
(** {1} ZMQ *)
(** ZeroMQ context *)
val zmq_context : ZMQ.Context.t
(** Bind a ZMQ socket *)
val bind_socket :
socket_type:string -> socket:'a ZMQ.Socket.t -> address:string -> unit
(** Name of the host on which the server runs *)
val hostname : string lazy_t
(** IP address of the current host *)
val ip_address : string lazy_t
(** Standard messages *)
val reply_ok : [> `Req ] ZMQ.Socket.t -> unit
val reply_wrong_state : [> `Req ] ZMQ.Socket.t -> unit
(** Stop server *)
val stop : port:int -> unit
(** {1} Server functions *)
(** Create a new job *)
val new_job : Message.Newjob_msg.t -> t -> [> `Req ] ZMQ.Socket.t -> [> `Pair] ZMQ.Socket.t -> t
(** Finish a running job *)
val end_job : Message.Endjob_msg.t -> t -> [> `Req ] ZMQ.Socket.t -> [> `Pair] ZMQ.Socket.t -> t
(** Connect a client *)
val connect: Message.Connect_msg.t -> t -> [> `Req ] ZMQ.Socket.t -> t
(** Disconnect a client *)
val disconnect: Message.Disconnect_msg.t -> t -> [> `Req ] ZMQ.Socket.t -> t
(** Add a task to the pool *)
val add_task: Message.AddTask_msg.t -> t -> [> `Req ] ZMQ.Socket.t -> t
(** Mark the task as done by the client *)
val task_done: Message.TaskDone_msg.t -> t -> [> `Req ] ZMQ.Socket.t -> t
(** Delete a task when it has been pulled by the collector *)
val del_task: Message.DelTask_msg.t -> t -> [> `Req ] ZMQ.Socket.t -> t
(** The client get a new task to execute *)
val get_task: Message.GetTask_msg.t -> t -> [> `Req ] ZMQ.Socket.t -> [> `Pair] ZMQ.Socket.t -> t
(** Terminate server *)
val terminate : t -> [> `Req ] ZMQ.Socket.t -> t
(** Put a wave function in the task server *)
val put_psi :
Message.PutPsi_msg.t -> string list -> t -> [> `Req ] ZMQ.Socket.t -> t
(** Get the wave function stored in the task server *)
val get_psi : Message.GetPsi_msg.t -> t -> [> `Req ] ZMQ.Socket.t -> t
(** Reply an Error message *)
val error : string -> t -> [> `Req ] ZMQ.Socket.t -> t
(** Run server *)
val run : port:int -> unit

2
ocaml/_tags
View File

@ -1,3 +1,3 @@
true: package(core,sexplib.syntax,cryptokit,ZMQ) true: package(core,cryptokit,ZMQ,sexplib.syntax)
true: thread true: thread
false: profile false: profile

3
plugins/All_singles/H_apply.irp.f
View File

@ -8,10 +8,9 @@ s.unset_skip()
s.filter_only_1h1p() s.filter_only_1h1p()
print s print s
s = H_apply("just_mono") s = H_apply("just_mono",do_double_exc=False)
s.set_selection_pt2("epstein_nesbet_2x2") s.set_selection_pt2("epstein_nesbet_2x2")
s.unset_skip() s.unset_skip()
s.unset_double_excitations()
print s print s
END_SHELL END_SHELL

2
plugins/All_singles/all_singles.irp.f
View File

@ -15,7 +15,7 @@ subroutine routine
integer :: N_st, degree integer :: N_st, degree
double precision,allocatable :: E_before(:) double precision,allocatable :: E_before(:)
integer :: n_det_before integer :: n_det_before
N_st = N_states N_st = N_states_diag
allocate (pt2(N_st), norm_pert(N_st),H_pert_diag(N_st),E_before(N_st)) allocate (pt2(N_st), norm_pert(N_st),H_pert_diag(N_st),E_before(N_st))
i = 0 i = 0
print*,'N_det = ',N_det print*,'N_det = ',N_det

4
plugins/CAS_SD/H_apply.irp.f
View File

@ -20,22 +20,18 @@ print s
s = H_apply("CAS_S",do_double_exc=False) s = H_apply("CAS_S",do_double_exc=False)
s.unset_double_excitations()
print s print s
s = H_apply("CAS_S_selected_no_skip",do_double_exc=False) s = H_apply("CAS_S_selected_no_skip",do_double_exc=False)
s.unset_double_excitations()
s.set_selection_pt2("epstein_nesbet_2x2") s.set_selection_pt2("epstein_nesbet_2x2")
s.unset_skip() s.unset_skip()
print s print s
s = H_apply("CAS_S_selected",do_double_exc=False) s = H_apply("CAS_S_selected",do_double_exc=False)
s.unset_double_excitations()
s.set_selection_pt2("epstein_nesbet_2x2") s.set_selection_pt2("epstein_nesbet_2x2")
print s print s
s = H_apply("CAS_S_PT2",do_double_exc=False) s = H_apply("CAS_S_PT2",do_double_exc=False)
s.unset_double_excitations()
s.set_perturbation("epstein_nesbet_2x2") s.set_perturbation("epstein_nesbet_2x2")
print s print s

23
plugins/DDCI_selected/ddci.irp.f
View File

@ -3,10 +3,10 @@ program ddci
integer :: i,k integer :: i,k
double precision, allocatable :: pt2(:), norm_pert(:), H_pert_diag(:) double precision, allocatable :: pt2(:), norm_pert(:), H_pert_diag(:),E_before(:)
integer :: N_st, degree integer :: N_st, degree
N_st = N_states N_st = N_states_diag
allocate (pt2(N_st), norm_pert(N_st),H_pert_diag(N_st)) allocate (pt2(N_st), norm_pert(N_st),H_pert_diag(N_st),E_before(N_st))
character*(64) :: perturbation character*(64) :: perturbation
pt2 = 1.d0 pt2 = 1.d0
@ -27,6 +27,8 @@ program ddci
print *, 'E+PT2 = ', CI_energy+pt2 print *, 'E+PT2 = ', CI_energy+pt2
print *, '-----' print *, '-----'
endif endif
call set_bitmask_particl_as_input(reunion_of_bitmask)
call set_bitmask_hole_as_input(reunion_of_bitmask)
do while (N_det < N_det_max.and.maxval(abs(pt2(1:N_st))) > pt2_max) do while (N_det < N_det_max.and.maxval(abs(pt2(1:N_st))) > pt2_max)
call H_apply_DDCI_selection(pt2, norm_pert, H_pert_diag, N_st) call H_apply_DDCI_selection(pt2, norm_pert, H_pert_diag, N_st)
@ -47,8 +49,21 @@ program ddci
print *, 'N_states = ', N_states print *, 'N_states = ', N_states
print *, 'PT2 = ', pt2 print *, 'PT2 = ', pt2
print *, 'E = ', CI_energy print *, 'E = ', CI_energy
print *, 'E+PT2 = ', CI_energy+pt2 print *, 'E+PT2 = ', E_before+pt2
print *, '-----' print *, '-----'
if(N_states_diag.gt.1)then
print*,'Variational Energy difference'
do i = 2, N_st
print*,'Delta E = ',CI_energy(i) - CI_energy(1)
enddo
endif
if(N_states.gt.1)then
print*,'Variational + perturbative Energy difference'
do i = 2, N_st
print*,'Delta E = ',E_before(i)+ pt2(i) - (E_before(1) + pt2(1))
enddo
endif
E_before = CI_energy
call ezfio_set_ddci_selected_energy(CI_energy) call ezfio_set_ddci_selected_energy(CI_energy)
enddo enddo
if(do_pt2_end)then if(do_pt2_end)then

25
plugins/FOBOCI/EZFIO.cfg
View File

@ -1,6 +1,13 @@
[threshold_singles] [threshold_lmct]
type: double precision type: double precision
doc: threshold to select the pertinent single excitations at second order doc: threshold to select the pertinent LMCT excitations at second order
interface: ezfio,provider,ocaml
default: 0.01
[threshold_mlct]
type: double precision
doc: threshold to select the pertinent MLCT excitations at second order
interface: ezfio,provider,ocaml interface: ezfio,provider,ocaml
default: 0.01 default: 0.01
@ -16,6 +23,20 @@ doc: if true, you do the FOBOCI calculation perturbatively
interface: ezfio,provider,ocaml interface: ezfio,provider,ocaml
default: .False. default: .False.
[speed_up_convergence_foboscf]
type: logical
doc: if true, the threshold of the FOBO-SCF algorithms are increased with the iterations
interface: ezfio,provider,ocaml
default: .True.
[dressing_2h2p]
type: logical
doc: if true, you do dress with 2h2p excitations each FOBOCI matrix
interface: ezfio,provider,ocaml
default: .False.
[second_order_h] [second_order_h]
type: logical type: logical
doc: if true, you do the FOBOCI calculation using second order intermediate Hamiltonian doc: if true, you do the FOBOCI calculation using second order intermediate Hamiltonian

16
plugins/FOBOCI/H_apply.irp.f
View File

@ -18,8 +18,22 @@ print s
s = H_apply("standard") s = H_apply("only_1h2p")
s.set_selection_pt2("epstein_nesbet") s.set_selection_pt2("epstein_nesbet")
s.filter_only_1h2p()
s.unset_skip()
print s
s = H_apply("only_2h2p")
s.set_selection_pt2("epstein_nesbet")
s.filter_only_2h2p()
s.unset_skip()
print s
s = H_apply("only_2p")
s.set_selection_pt2("epstein_nesbet")
s.filter_only_2p()
s.unset_skip() s.unset_skip()
print s print s

2
plugins/FOBOCI/NEEDED_CHILDREN_MODULES
View File

@ -1 +1 @@
Perturbation Generators_restart Selectors_no_sorted Perturbation Selectors_no_sorted Hartree_Fock

335
plugins/FOBOCI/all_singles.irp.f
View File

@ -6,9 +6,9 @@ subroutine all_single
double precision,allocatable :: E_before(:) double precision,allocatable :: E_before(:)
N_st = N_states N_st = N_states
allocate (pt2(N_st), norm_pert(N_st),H_pert_diag(N_st),E_before(N_st)) allocate (pt2(N_st), norm_pert(N_st),H_pert_diag(N_st),E_before(N_st))
selection_criterion = 1.d-8 selection_criterion = 0.d0
soft_touch selection_criterion soft_touch selection_criterion
threshold_davidson = 1.d-5 threshold_davidson = 1.d-9
soft_touch threshold_davidson davidson_criterion soft_touch threshold_davidson davidson_criterion
i = 0 i = 0
print*,'Doing all the mono excitations !' print*,'Doing all the mono excitations !'
@ -52,10 +52,173 @@ subroutine all_single
enddo enddo
endif endif
E_before = CI_energy E_before = CI_energy
!!!!!!!!!!!!!!!!!!!!!!!!!!! DOING ONLY ONE ITERATION OF SELECTION AS THE SELECTION CRITERION IS SET TO ZERO
exit
enddo enddo
threshold_davidson = 1.d-10 ! threshold_davidson = 1.d-8
! soft_touch threshold_davidson davidson_criterion
! call diagonalize_CI
print*,'Final Step '
print*,'N_det = ',N_det
do i = 1, N_states_diag
print*,''
print*,'i = ',i
print*,'E = ',CI_energy(i)
print*,'S^2 = ',CI_eigenvectors_s2(i)
enddo
do i = 1, max(2,N_det_generators)
print*,'psi_coef = ',psi_coef(i,1)
enddo
deallocate(pt2,norm_pert,E_before)
end
subroutine all_1h2p
implicit none
integer :: i,k
double precision, allocatable :: pt2(:), norm_pert(:), H_pert_diag(:)
integer :: N_st, degree
double precision,allocatable :: E_before(:)
N_st = N_states
allocate (pt2(N_st), norm_pert(N_st),H_pert_diag(N_st),E_before(N_st))
selection_criterion = 0.d0
soft_touch selection_criterion
threshold_davidson = 1.d-5
soft_touch threshold_davidson davidson_criterion soft_touch threshold_davidson davidson_criterion
call diagonalize_CI i = 0
print*,''
print*,''
print*,''
print*,''
print*,''
print*,'*****************************'
print*,'Doing all the 1h2P excitations'
print*,'*****************************'
print*,''
print*,''
print*,'N_det = ',N_det
print*,'n_det_max = ',n_det_max
print*,'pt2_max = ',pt2_max
print*,'N_det_generators = ',N_det_generators
pt2=-1.d0
E_before = ref_bitmask_energy
print*,'Initial Step '
print*,'Inital determinants '
print*,'N_det = ',N_det
do i = 1, N_states_diag
print*,''
print*,'i = ',i
print*,'E = ',CI_energy(i)
print*,'S^2 = ',CI_eigenvectors_s2(i)
enddo
n_det_max = 100000
i = 0
do while (N_det < n_det_max.and.maxval(abs(pt2(1:N_st))) > pt2_max)
i += 1
print*,'-----------------------'
print*,'i = ',i
call H_apply_only_1h2p(pt2, norm_pert, H_pert_diag, N_st)
call diagonalize_CI
print*,'N_det = ',N_det
print*,'E = ',CI_energy(1)
print*,'pt2 = ',pt2(1)
print*,'E+PT2 = ',E_before + pt2(1)
if(N_states_diag.gt.1)then
print*,'Variational Energy difference'
do i = 2, N_st
print*,'Delta E = ',CI_energy(i) - CI_energy(1)
enddo
endif
if(N_states.gt.1)then
print*,'Variational + perturbative Energy difference'
do i = 2, N_st
print*,'Delta E = ',E_before(i)+ pt2(i) - (E_before(1) + pt2(1))
enddo
endif
E_before = CI_energy
enddo
print*,'Final Step '
print*,'N_det = ',N_det
do i = 1, N_states_diag
print*,''
print*,'i = ',i
print*,'E = ',CI_energy(i)
print*,'S^2 = ',CI_eigenvectors_s2(i)
enddo
do i = 1, 2
print*,'psi_coef = ',psi_coef(i,1)
enddo
deallocate(pt2,norm_pert,E_before)
end
subroutine all_2h2p
implicit none
integer :: i,k
double precision, allocatable :: pt2(:), norm_pert(:), H_pert_diag(:)
integer :: N_st, degree
double precision,allocatable :: E_before(:)
N_st = N_states
allocate (pt2(N_st), norm_pert(N_st),H_pert_diag(N_st),E_before(N_st))
selection_criterion = 0.d0
soft_touch selection_criterion
threshold_davidson = 1.d-5
soft_touch threshold_davidson davidson_criterion
i = 0
print*,''
print*,''
print*,''
print*,''
print*,''
print*,'*****************************'
print*,'Doing all the 2h2P excitations'
print*,'*****************************'
print*,''
print*,''
print*,'N_det = ',N_det
print*,'n_det_max = ',n_det_max
print*,'pt2_max = ',pt2_max
print*,'N_det_generators = ',N_det_generators
pt2=-1.d0
E_before = ref_bitmask_energy
print*,'Initial Step '
print*,'Inital determinants '
print*,'N_det = ',N_det
do i = 1, N_states_diag
print*,''
print*,'i = ',i
print*,'E = ',CI_energy(i)
print*,'S^2 = ',CI_eigenvectors_s2(i)
enddo
n_det_max = 100000
i = 0
do while (N_det < n_det_max.and.maxval(abs(pt2(1:N_st))) > pt2_max)
i += 1
print*,'-----------------------'
print*,'i = ',i
call H_apply_only_2h2p(pt2, norm_pert, H_pert_diag, N_st)
call diagonalize_CI
print*,'N_det = ',N_det
print*,'E = ',CI_energy(1)
print*,'pt2 = ',pt2(1)
print*,'E+PT2 = ',E_before + pt2(1)
if(N_states_diag.gt.1)then
print*,'Variational Energy difference'
do i = 2, N_st
print*,'Delta E = ',CI_energy(i) - CI_energy(1)
enddo
endif
if(N_states.gt.1)then
print*,'Variational + perturbative Energy difference'
do i = 2, N_st
print*,'Delta E = ',E_before(i)+ pt2(i) - (E_before(1) + pt2(1))
enddo
endif
E_before = CI_energy
enddo
print*,'Final Step ' print*,'Final Step '
print*,'N_det = ',N_det print*,'N_det = ',N_det
do i = 1, N_states_diag do i = 1, N_states_diag
@ -67,10 +230,89 @@ subroutine all_single
do i = 1, 2 do i = 1, 2
print*,'psi_coef = ',psi_coef(i,1) print*,'psi_coef = ',psi_coef(i,1)
enddo enddo
! call save_wavefunction
deallocate(pt2,norm_pert,E_before) deallocate(pt2,norm_pert,E_before)
end end
subroutine all_2p
implicit none
integer :: i,k
double precision, allocatable :: pt2(:), norm_pert(:), H_pert_diag(:)
integer :: N_st, degree
double precision,allocatable :: E_before(:)
N_st = N_states
allocate (pt2(N_st), norm_pert(N_st),H_pert_diag(N_st),E_before(N_st))
selection_criterion = 0.d0
soft_touch selection_criterion
threshold_davidson = 1.d-5
soft_touch threshold_davidson davidson_criterion
i = 0
print*,''
print*,''
print*,''
print*,''
print*,''
print*,'*****************************'
print*,'Doing all the 2P excitations'
print*,'*****************************'
print*,''
print*,''
print*,'N_det = ',N_det
print*,'n_det_max = ',n_det_max
print*,'pt2_max = ',pt2_max
print*,'N_det_generators = ',N_det_generators
pt2=-1.d0
E_before = ref_bitmask_energy
print*,'Initial Step '
print*,'Inital determinants '
print*,'N_det = ',N_det
do i = 1, N_states_diag
print*,''
print*,'i = ',i
print*,'E = ',CI_energy(i)
print*,'S^2 = ',CI_eigenvectors_s2(i)
enddo
n_det_max = 100000
i = 0
do while (N_det < n_det_max.and.maxval(abs(pt2(1:N_st))) > pt2_max)
i += 1
print*,'-----------------------'
print*,'i = ',i
call H_apply_only_2p(pt2, norm_pert, H_pert_diag, N_st)
call diagonalize_CI
print*,'N_det = ',N_det
print*,'E = ',CI_energy(1)
print*,'pt2 = ',pt2(1)
print*,'E+PT2 = ',E_before + pt2(1)
if(N_states_diag.gt.1)then
print*,'Variational Energy difference'
do i = 2, N_st
print*,'Delta E = ',CI_energy(i) - CI_energy(1)
enddo
endif
if(N_states.gt.1)then
print*,'Variational + perturbative Energy difference'
do i = 2, N_st
print*,'Delta E = ',E_before(i)+ pt2(i) - (E_before(1) + pt2(1))
enddo
endif
E_before = CI_energy
enddo
print*,'Final Step '
print*,'N_det = ',N_det
do i = 1, N_states_diag
print*,''
print*,'i = ',i
print*,'E = ',CI_energy(i)
print*,'S^2 = ',CI_eigenvectors_s2(i)
enddo
deallocate(pt2,norm_pert,E_before)
do i = 1, 2
print*,'psi_coef = ',psi_coef(i,1)
enddo
end
subroutine all_single_no_1h_or_1p subroutine all_single_no_1h_or_1p
implicit none implicit none
integer :: i,k integer :: i,k
@ -79,6 +321,8 @@ subroutine all_single_no_1h_or_1p
double precision,allocatable :: E_before(:) double precision,allocatable :: E_before(:)
N_st = N_states N_st = N_states
allocate (pt2(N_st), norm_pert(N_st),H_pert_diag(N_st),E_before(N_st)) allocate (pt2(N_st), norm_pert(N_st),H_pert_diag(N_st),E_before(N_st))
selection_criterion = 0.d0
soft_touch selection_criterion
threshold_davidson = 1.d-5 threshold_davidson = 1.d-5
soft_touch threshold_davidson davidson_criterion soft_touch threshold_davidson davidson_criterion
i = 0 i = 0
@ -124,7 +368,7 @@ subroutine all_single_no_1h_or_1p
endif endif
E_before = CI_energy E_before = CI_energy
enddo enddo
threshold_davidson = 1.d-10 threshold_davidson = 1.d-16
soft_touch threshold_davidson davidson_criterion soft_touch threshold_davidson davidson_criterion
call diagonalize_CI call diagonalize_CI
print*,'Final Step ' print*,'Final Step '
@ -215,85 +459,6 @@ subroutine all_single_no_1h_or_1p_or_2p
deallocate(pt2,norm_pert,E_before) deallocate(pt2,norm_pert,E_before)
end end
subroutine all_2p
implicit none
integer :: i,k
double precision, allocatable :: pt2(:), norm_pert(:), H_pert_diag(:)
integer :: N_st, degree
double precision,allocatable :: E_before(:)
N_st = N_states
allocate (pt2(N_st), norm_pert(N_st),H_pert_diag(N_st),E_before(N_st))
selection_criterion = 0.d0
soft_touch selection_criterion
threshold_davidson = 1.d-5
soft_touch threshold_davidson davidson_criterion
i = 0
print*,''
print*,''
print*,''
print*,''
print*,''
print*,'*****************************'
print*,'Doing all the 2P excitations'
print*,'*****************************'
print*,''
print*,''
print*,'N_det = ',N_det
print*,'n_det_max = ',n_det_max
print*,'pt2_max = ',pt2_max
print*,'N_det_generators = ',N_det_generators
pt2=-1.d0
E_before = ref_bitmask_energy
print*,'Initial Step '
print*,'Inital determinants '
print*,'N_det = ',N_det
do i = 1, N_states_diag
print*,''
print*,'i = ',i
print*,'E = ',CI_energy(i)
print*,'S^2 = ',CI_eigenvectors_s2(i)
enddo
n_det_max = 100000
i = 0
do while (N_det < n_det_max.and.maxval(abs(pt2(1:N_st))) > pt2_max)
i += 1
print*,'-----------------------'
print*,'i = ',i
call H_apply_standard(pt2, norm_pert, H_pert_diag, N_st)
call diagonalize_CI
print*,'N_det = ',N_det
print*,'E = ',CI_energy(1)
print*,'pt2 = ',pt2(1)
print*,'E+PT2 = ',E_before + pt2(1)
if(N_states_diag.gt.1)then
print*,'Variational Energy difference'
do i = 2, N_st
print*,'Delta E = ',CI_energy(i) - CI_energy(1)
enddo
endif
if(N_states.gt.1)then
print*,'Variational + perturbative Energy difference'
do i = 2, N_st
print*,'Delta E = ',E_before(i)+ pt2(i) - (E_before(1) + pt2(1))
enddo
endif
E_before = CI_energy
enddo
print*,'Final Step '
print*,'N_det = ',N_det
do i = 1, N_states_diag
print*,''
print*,'i = ',i
print*,'E = ',CI_energy(i)
print*,'S^2 = ',CI_eigenvectors_s2(i)
enddo
! call save_wavefunction
deallocate(pt2,norm_pert,E_before)
end
subroutine all_1h_1p_routine subroutine all_1h_1p_routine
implicit none implicit none
integer :: i,k integer :: i,k

442
plugins/FOBOCI/all_singles_split.irp.f
View File

@ -5,7 +5,7 @@ subroutine all_single_split(psi_det_generators_input,psi_coef_generators_input,N
integer(bit_kind), intent(in) :: psi_det_generators_input(N_int,2,Ndet_generators_input) integer(bit_kind), intent(in) :: psi_det_generators_input(N_int,2,Ndet_generators_input)
double precision, intent(inout) :: dressing_matrix(Ndet_generators_input,Ndet_generators_input) double precision, intent(inout) :: dressing_matrix(Ndet_generators_input,Ndet_generators_input)
double precision, intent(in) :: psi_coef_generators_input(ndet_generators_input,n_states) double precision, intent(in) :: psi_coef_generators_input(ndet_generators_input,n_states)
integer :: i,i_hole integer :: i,i_hole,j
n_det_max_jacobi = 50 n_det_max_jacobi = 50
soft_touch n_det_max_jacobi soft_touch n_det_max_jacobi
do i = 1, n_inact_orb do i = 1, n_inact_orb
@ -22,56 +22,339 @@ subroutine all_single_split(psi_det_generators_input,psi_coef_generators_input,N
call set_generators_as_input_psi(ndet_generators_input,psi_det_generators_input,psi_coef_generators_input) call set_generators_as_input_psi(ndet_generators_input,psi_det_generators_input,psi_coef_generators_input)
call set_psi_det_as_input_psi(ndet_generators_input,psi_det_generators_input,psi_coef_generators_input) call set_psi_det_as_input_psi(ndet_generators_input,psi_det_generators_input,psi_coef_generators_input)
call all_single call all_single
threshold_davidson = 1.d-10 ! call diagonalize_CI_SC2
soft_touch threshold_davidson davidson_criterion ! call update_matrix_dressing_sc2(dressing_matrix,ndet_generators_input,psi_det_generators_input,Diag_H_elements_SC2)
call diagonalize_CI
call provide_matrix_dressing(dressing_matrix,ndet_generators_input,psi_det_generators_input) call provide_matrix_dressing(dressing_matrix,ndet_generators_input,psi_det_generators_input)
enddo enddo
do i = 1, n_act_orb
i_hole = list_act(i)
print*,''
print*,'Doing all the single excitations from the orbital '
print*,i_hole
print*,''
print*,''
threshold_davidson = 1.d-4
soft_touch threshold_davidson davidson_criterion
call modify_bitmasks_for_hole(i_hole)
call set_bitmask_particl_as_input(reunion_of_bitmask)
call set_generators_as_input_psi(ndet_generators_input,psi_det_generators_input,psi_coef_generators_input)
call set_psi_det_as_input_psi(ndet_generators_input,psi_det_generators_input,psi_coef_generators_input)
call all_single
! call diagonalize_CI_SC2
! call update_matrix_dressing_sc2(dressing_matrix,ndet_generators_input,psi_det_generators_input,Diag_H_elements_SC2)
call provide_matrix_dressing(dressing_matrix,ndet_generators_input,psi_det_generators_input)
enddo
do i = 1, n_virt_orb
i_hole = list_virt(i)
print*,''
print*,'Doing all the single excitations from the orbital '
print*,i_hole
print*,''
print*,''
threshold_davidson = 1.d-4
soft_touch threshold_davidson davidson_criterion
call modify_bitmasks_for_hole(i_hole)
call set_bitmask_particl_as_input(reunion_of_bitmask)
call set_generators_as_input_psi(ndet_generators_input,psi_det_generators_input,psi_coef_generators_input)
call set_psi_det_as_input_psi(ndet_generators_input,psi_det_generators_input,psi_coef_generators_input)
call all_single
! call diagonalize_CI_SC2
! call update_matrix_dressing_sc2(dressing_matrix,ndet_generators_input,psi_det_generators_input,Diag_H_elements_SC2)
call provide_matrix_dressing(dressing_matrix,ndet_generators_input,psi_det_generators_input)
enddo
n_det_max_jacobi = 1000 n_det_max_jacobi = 1000
soft_touch n_det_max_jacobi soft_touch n_det_max_jacobi
end end
subroutine all_single_for_1h(dressing_matrix_1h1p,dressing_matrix_2h1p)
subroutine all_single_for_1p(i_particl,dressing_matrix_1h1p,dressing_matrix_1h2p,dressing_matrix_extra_1h_or_1p)
implicit none implicit none
use bitmasks use bitmasks
integer, intent(in) :: i_particl
double precision, intent(inout) :: dressing_matrix_1h1p(N_det_generators,N_det_generators) double precision, intent(inout) :: dressing_matrix_1h1p(N_det_generators,N_det_generators)
double precision, intent(inout) :: dressing_matrix_2h1p(N_det_generators,N_det_generators) double precision, intent(inout) :: dressing_matrix_1h2p(N_det_generators,N_det_generators)
integer :: i,i_hole double precision, intent(inout) :: dressing_matrix_extra_1h_or_1p(N_det_generators,N_det_generators)
integer :: i,j
n_det_max_jacobi = 50 n_det_max_jacobi = 50
soft_touch n_det_max_jacobi soft_touch n_det_max_jacobi
integer :: n_det_1h1p,n_det_2h1p call all_single
integer(bit_kind), allocatable :: psi_ref_out(:,:,:)
integer(bit_kind), allocatable :: psi_1h1p(:,:,:)
integer(bit_kind), allocatable :: psi_2h1p(:,:,:)
double precision, allocatable :: psi_ref_coef_out(:,:)
double precision, allocatable :: psi_coef_1h1p(:,:)
double precision, allocatable :: psi_coef_2h1p(:,:)
call all_single_no_1h_or_1p
threshold_davidson = 1.d-12 threshold_davidson = 1.d-12
soft_touch threshold_davidson davidson_criterion soft_touch threshold_davidson davidson_criterion
call diagonalize_CI call diagonalize_CI
call give_n_1h1p_and_n_2h1p_in_psi_det(n_det_1h1p,n_det_2h1p)
allocate(psi_ref_out(N_int,2,N_det_generators))
allocate(psi_1h1p(N_int,2,n_det_1h1p))
allocate(psi_2h1p(N_int,2,n_det_2h1p))
allocate(psi_ref_coef_out(N_det_generators,N_states))
allocate(psi_coef_1h1p(n_det_1h1p,N_states))
allocate(psi_coef_2h1p(n_det_2h1p,N_states))
call split_wf_generators_and_1h1p_and_2h1p(n_det_1h1p,n_det_2h1p,psi_ref_out,psi_ref_coef_out,psi_1h1p,psi_coef_1h1p,psi_2h1p,psi_coef_2h1p)
call provide_matrix_dressing_general(dressing_matrix_1h1p,psi_ref_out,psi_ref_coef_out,N_det_generators, &
psi_1h1p,psi_coef_1h1p,n_det_1h1p)
call provide_matrix_dressing_general(dressing_matrix_2h1p,psi_ref_out,psi_ref_coef_out,N_det_generators, &
psi_2h1p,psi_coef_2h1p,n_det_2h1p)
deallocate(psi_ref_out)
deallocate(psi_1h1p)
deallocate(psi_2h1p) double precision, allocatable :: matrix_ref_1h_1p(:,:)
deallocate(psi_ref_coef_out) double precision, allocatable :: matrix_ref_1h_1p_dressing_1h1p(:,:)
deallocate(psi_coef_1h1p) double precision, allocatable :: matrix_ref_1h_1p_dressing_1h2p(:,:)
deallocate(psi_coef_2h1p) double precision, allocatable :: psi_coef_ref_1h_1p(:,:)
double precision, allocatable :: psi_coef_1h1p(:,:)
double precision, allocatable :: psi_coef_1h2p(:,:)
integer(bit_kind), allocatable :: psi_det_1h2p(:,:,:)
integer(bit_kind), allocatable :: psi_det_ref_1h_1p(:,:,:)
integer(bit_kind), allocatable :: psi_det_1h1p(:,:,:)
integer :: n_det_ref_1h_1p,n_det_1h2p,n_det_1h1p
double precision :: hka
double precision,allocatable :: eigenvectors(:,:), eigenvalues(:)
call give_n_ref_1h_1p_and_n_1h2p_1h1p_in_psi_det(n_det_ref_1h_1p,n_det_1h2p,n_det_1h1p)
allocate(matrix_ref_1h_1p(n_det_ref_1h_1p,n_det_ref_1h_1p))
allocate(matrix_ref_1h_1p_dressing_1h1p(n_det_ref_1h_1p,n_det_ref_1h_1p))
allocate(matrix_ref_1h_1p_dressing_1h2p(n_det_ref_1h_1p,n_det_ref_1h_1p))
allocate(psi_det_ref_1h_1p(N_int,2,n_det_ref_1h_1p), psi_coef_ref_1h_1p(n_det_ref_1h_1p,N_states))
allocate(psi_det_1h2p(N_int,2,n_det_1h2p), psi_coef_1h2p(n_det_1h2p,N_states))
allocate(psi_det_1h1p(N_int,2,n_det_1h1p), psi_coef_1h1p(n_det_1h1p,N_states))
call give_wf_n_ref_1h_1p_and_n_1h2p_1h1p_in_psi_det(n_det_ref_1h_1p,n_det_1h2p,n_det_1h1p,psi_det_ref_1h_1p,psi_coef_ref_1h_1p,&
psi_det_1h2p,psi_coef_1h2p,psi_det_1h1p,psi_coef_1h1p)
do i = 1, n_det_ref_1h_1p
do j = 1, n_det_ref_1h_1p
call i_h_j(psi_det_ref_1h_1p(1,1,i),psi_det_ref_1h_1p(1,1,j),N_int,hka)
matrix_ref_1h_1p(i,j) = hka
enddo
enddo
matrix_ref_1h_1p_dressing_1h1p = 0.d0
matrix_ref_1h_1p_dressing_1h2p = 0.d0
call provide_matrix_dressing_general(matrix_ref_1h_1p_dressing_1h2p,psi_det_ref_1h_1p,psi_coef_ref_1h_1p,n_det_ref_1h_1p, &
psi_det_1h2p,psi_coef_1h2p,n_det_1h2p)
call provide_matrix_dressing_general(matrix_ref_1h_1p_dressing_1h1p,psi_det_ref_1h_1p,psi_coef_ref_1h_1p,n_det_ref_1h_1p, &
psi_det_1h1p,psi_coef_1h1p,n_det_1h1p)
do i = 1, n_det_ref_1h_1p
do j = 1, n_det_ref_1h_1p
matrix_ref_1h_1p(i,j) += matrix_ref_1h_1p_dressing_1h2p(i,j) + matrix_ref_1h_1p_dressing_1h1p(i,j)
enddo
enddo
allocate(eigenvectors(n_det_ref_1h_1p,n_det_ref_1h_1p), eigenvalues(n_det_ref_1h_1p))
call lapack_diag(eigenvalues,eigenvectors,matrix_ref_1h_1p,n_det_ref_1h_1p,n_det_ref_1h_1p)
!do j = 1, n_det_ref_1h_1p
! print*,'coef = ',eigenvectors(j,1)
!enddo
print*,''
print*,'-----------------------'
print*,'-----------------------'
print*,'e_dressed = ',eigenvalues(1)+nuclear_repulsion
print*,'-----------------------'
! Extract the
integer, allocatable :: index_generator(:)
integer :: n_det_generators_tmp,degree
n_det_generators_tmp = 0
allocate(index_generator(n_det_ref_1h_1p))
do i = 1, n_det_ref_1h_1p
do j = 1, N_det_generators
call get_excitation_degree(psi_det_generators(1,1,j),psi_det_ref_1h_1p(1,1,i), degree, N_int)
if(degree == 0)then
n_det_generators_tmp +=1
index_generator(n_det_generators_tmp) = i
endif
enddo
enddo
if(n_det_generators_tmp .ne. n_det_generators)then
print*,'PB !!!'
print*,'if(n_det_generators_tmp .ne. n_det_genrators)then'
stop
endif
do i = 1, N_det_generators
print*,'psi_coef_dressed = ',eigenvectors(index_generator(i),1)
do j = 1, N_det_generators
dressing_matrix_1h1p(i,j) += matrix_ref_1h_1p_dressing_1h1p(index_generator(i),index_generator(j))
dressing_matrix_1h2p(i,j) += matrix_ref_1h_1p_dressing_1h2p(index_generator(i),index_generator(j))
enddo
enddo
print*,'-----------------------'
print*,'-----------------------'
deallocate(matrix_ref_1h_1p)
deallocate(matrix_ref_1h_1p_dressing_1h1p)
deallocate(matrix_ref_1h_1p_dressing_1h2p)
deallocate(psi_det_ref_1h_1p, psi_coef_ref_1h_1p)
deallocate(psi_det_1h2p, psi_coef_1h2p)
deallocate(psi_det_1h1p, psi_coef_1h1p)
deallocate(eigenvectors,eigenvalues)
deallocate(index_generator)
end
subroutine all_single_for_1h(i_hole,dressing_matrix_1h1p,dressing_matrix_2h1p,dressing_matrix_extra_1h_or_1p)
implicit none
use bitmasks
integer, intent(in) :: i_hole
double precision, intent(inout) :: dressing_matrix_1h1p(N_det_generators,N_det_generators)
double precision, intent(inout) :: dressing_matrix_2h1p(N_det_generators,N_det_generators)
double precision, intent(inout) :: dressing_matrix_extra_1h_or_1p(N_det_generators,N_det_generators)
integer :: i,j
n_det_max_jacobi = 50
soft_touch n_det_max_jacobi
call all_single
threshold_davidson = 1.d-12
soft_touch threshold_davidson davidson_criterion
call diagonalize_CI
double precision, allocatable :: matrix_ref_1h_1p(:,:)
double precision, allocatable :: matrix_ref_1h_1p_dressing_1h1p(:,:)
double precision, allocatable :: matrix_ref_1h_1p_dressing_2h1p(:,:)
double precision, allocatable :: psi_coef_ref_1h_1p(:,:)
double precision, allocatable :: psi_coef_1h1p(:,:)
double precision, allocatable :: psi_coef_2h1p(:,:)
integer(bit_kind), allocatable :: psi_det_2h1p(:,:,:)
integer(bit_kind), allocatable :: psi_det_ref_1h_1p(:,:,:)
integer(bit_kind), allocatable :: psi_det_1h1p(:,:,:)
integer :: n_det_ref_1h_1p,n_det_2h1p,n_det_1h1p
double precision :: hka
double precision,allocatable :: eigenvectors(:,:), eigenvalues(:)
call give_n_ref_1h_1p_and_n_2h1p_1h1p_in_psi_det(n_det_ref_1h_1p,n_det_2h1p,n_det_1h1p)
allocate(matrix_ref_1h_1p(n_det_ref_1h_1p,n_det_ref_1h_1p))
allocate(matrix_ref_1h_1p_dressing_1h1p(n_det_ref_1h_1p,n_det_ref_1h_1p))
allocate(matrix_ref_1h_1p_dressing_2h1p(n_det_ref_1h_1p,n_det_ref_1h_1p))
allocate(psi_det_ref_1h_1p(N_int,2,n_det_ref_1h_1p), psi_coef_ref_1h_1p(n_det_ref_1h_1p,N_states))
allocate(psi_det_2h1p(N_int,2,n_det_2h1p), psi_coef_2h1p(n_det_2h1p,N_states))
allocate(psi_det_1h1p(N_int,2,n_det_1h1p), psi_coef_1h1p(n_det_1h1p,N_states))
call give_wf_n_ref_1h_1p_and_n_2h1p_1h1p_in_psi_det(n_det_ref_1h_1p,n_det_2h1p,n_det_1h1p,psi_det_ref_1h_1p,psi_coef_ref_1h_1p,&
psi_det_2h1p,psi_coef_2h1p,psi_det_1h1p,psi_coef_1h1p)
do i = 1, n_det_ref_1h_1p
do j = 1, n_det_ref_1h_1p
call i_h_j(psi_det_ref_1h_1p(1,1,i),psi_det_ref_1h_1p(1,1,j),N_int,hka)
matrix_ref_1h_1p(i,j) = hka
enddo
enddo
matrix_ref_1h_1p_dressing_1h1p = 0.d0
matrix_ref_1h_1p_dressing_2h1p = 0.d0
call provide_matrix_dressing_general(matrix_ref_1h_1p_dressing_2h1p,psi_det_ref_1h_1p,psi_coef_ref_1h_1p,n_det_ref_1h_1p, &
psi_det_2h1p,psi_coef_2h1p,n_det_2h1p)
call provide_matrix_dressing_general(matrix_ref_1h_1p_dressing_1h1p,psi_det_ref_1h_1p,psi_coef_ref_1h_1p,n_det_ref_1h_1p, &
psi_det_1h1p,psi_coef_1h1p,n_det_1h1p)
do i = 1, n_det_ref_1h_1p
do j = 1, n_det_ref_1h_1p
matrix_ref_1h_1p(i,j) += matrix_ref_1h_1p_dressing_2h1p(i,j) + matrix_ref_1h_1p_dressing_1h1p(i,j)
enddo
enddo
allocate(eigenvectors(n_det_ref_1h_1p,n_det_ref_1h_1p), eigenvalues(n_det_ref_1h_1p))
call lapack_diag(eigenvalues,eigenvectors,matrix_ref_1h_1p,n_det_ref_1h_1p,n_det_ref_1h_1p)
!do j = 1, n_det_ref_1h_1p
! print*,'coef = ',eigenvectors(j,1)
!enddo
print*,''
print*,'-----------------------'
print*,'-----------------------'
print*,'e_dressed = ',eigenvalues(1)+nuclear_repulsion
print*,'-----------------------'
! Extract the
integer, allocatable :: index_generator(:)
integer :: n_det_generators_tmp,degree
n_det_generators_tmp = 0
allocate(index_generator(n_det_ref_1h_1p))
do i = 1, n_det_ref_1h_1p
do j = 1, N_det_generators
call get_excitation_degree(psi_det_generators(1,1,j),psi_det_ref_1h_1p(1,1,i), degree, N_int)
if(degree == 0)then
n_det_generators_tmp +=1
index_generator(n_det_generators_tmp) = i
endif
enddo
enddo
if(n_det_generators_tmp .ne. n_det_generators)then
print*,'PB !!!'
print*,'if(n_det_generators_tmp .ne. n_det_genrators)then'
stop
endif
do i = 1, N_det_generators
print*,'psi_coef_dressed = ',eigenvectors(index_generator(i),1)
do j = 1, N_det_generators
dressing_matrix_1h1p(i,j) += matrix_ref_1h_1p_dressing_1h1p(index_generator(i),index_generator(j))
dressing_matrix_2h1p(i,j) += matrix_ref_1h_1p_dressing_2h1p(index_generator(i),index_generator(j))
enddo
enddo
print*,'-----------------------'
print*,'-----------------------'
deallocate(matrix_ref_1h_1p)
deallocate(matrix_ref_1h_1p_dressing_1h1p)
deallocate(matrix_ref_1h_1p_dressing_2h1p)
deallocate(psi_det_ref_1h_1p, psi_coef_ref_1h_1p)
deallocate(psi_det_2h1p, psi_coef_2h1p)
deallocate(psi_det_1h1p, psi_coef_1h1p)
deallocate(eigenvectors,eigenvalues)
deallocate(index_generator)
!return
!
!integer(bit_kind), allocatable :: psi_ref_out(:,:,:)
!integer(bit_kind), allocatable :: psi_1h1p(:,:,:)
!integer(bit_kind), allocatable :: psi_2h1p(:,:,:)
!integer(bit_kind), allocatable :: psi_extra_1h_or_1p(:,:,:)
!double precision, allocatable :: psi_ref_coef_out(:,:)
!double precision, allocatable :: psi_coef_extra_1h_or_1p(:,:)
!call all_single_no_1h_or_1p
!call give_n_1h1p_and_n_2h1p_in_psi_det(i_hole,n_det_extra_1h_or_1p,n_det_1h1p,n_det_2h1p)
!allocate(psi_ref_out(N_int,2,N_det_generators))
!allocate(psi_1h1p(N_int,2,n_det_1h1p))
!allocate(psi_2h1p(N_int,2,n_det_2h1p))
!allocate(psi_extra_1h_or_1p(N_int,2,n_det_extra_1h_or_1p))
!allocate(psi_ref_coef_out(N_det_generators,N_states))
!allocate(psi_coef_1h1p(n_det_1h1p,N_states))
!allocate(psi_coef_2h1p(n_det_2h1p,N_states))
!allocate(psi_coef_extra_1h_or_1p(n_det_extra_1h_or_1p,N_states))
!call split_wf_generators_and_1h1p_and_2h1p(i_hole,n_det_extra_1h_or_1p,n_det_1h1p,n_det_2h1p,psi_ref_out,psi_ref_coef_out,psi_1h1p,psi_coef_1h1p,psi_2h1p,psi_coef_2h1p,psi_extra_1h_or_1p,psi_coef_extra_1h_or_1p)
!do i = 1, n_det_extra_1h_or_1p
! print*,'----'
! print*,'c = ',psi_coef_extra_1h_or_1p(i,1)
! call debug_det(psi_extra_1h_or_1p(1,1,i),N_int)
! print*,'----'
!enddo
!call provide_matrix_dressing_general(dressing_matrix_1h1p,psi_ref_out,psi_ref_coef_out,N_det_generators, &
! psi_1h1p,psi_coef_1h1p,n_det_1h1p)
!print*,'Dressing 1h1p '
!do j =1, N_det_generators
! print*,' dressing ',dressing_matrix_1h1p(j,:)
!enddo
!call provide_matrix_dressing_general(dressing_matrix_2h1p,psi_ref_out,psi_ref_coef_out,N_det_generators, &
! psi_2h1p,psi_coef_2h1p,n_det_2h1p)
!print*,'Dressing 2h1p '
!do j =1, N_det_generators
! print*,' dressing ',dressing_matrix_2h1p(j,:)
!enddo
!call provide_matrix_dressing_for_extra_1h_or_1p(dressing_matrix_extra_1h_or_1p,psi_ref_out,psi_ref_coef_out,N_det_generators, &
! psi_extra_1h_or_1p,psi_coef_extra_1h_or_1p,n_det_extra_1h_or_1p)
!print*,',dressing_matrix_extra_1h_or_1p'
!do j =1, N_det_generators
! print*,' dressing ',dressing_matrix_extra_1h_or_1p(j,:)
!enddo
!deallocate(psi_ref_out)
!deallocate(psi_1h1p)
!deallocate(psi_2h1p)
!deallocate(psi_extra_1h_or_1p)
!deallocate(psi_ref_coef_out)
!deallocate(psi_coef_1h1p)
!deallocate(psi_coef_2h1p)
!deallocate(psi_coef_extra_1h_or_1p)
end end
@ -197,47 +480,56 @@ subroutine all_single_split_for_1p(dressing_matrix_1h1p,dressing_matrix_1h2p)
soft_touch n_det_max_jacobi soft_touch n_det_max_jacobi
end end
subroutine all_single_for_1p(dressing_matrix_1h1p,dressing_matrix_1h2p) ! subroutine all_single_for_1p(i_particl,dressing_matrix_1h1p,dressing_matrix_1h2p,dressing_matrix_extra_1h_or_1p)
implicit none ! implicit none
use bitmasks ! use bitmasks
double precision, intent(inout) :: dressing_matrix_1h1p(N_det_generators,N_det_generators) ! integer, intent(in ) :: i_particl
double precision, intent(inout) :: dressing_matrix_1h2p(N_det_generators,N_det_generators) ! double precision, intent(inout) :: dressing_matrix_1h1p(N_det_generators,N_det_generators)
integer :: i,i_hole ! double precision, intent(inout) :: dressing_matrix_1h2p(N_det_generators,N_det_generators)
n_det_max_jacobi = 50 ! double precision, intent(inout) :: dressing_matrix_extra_1h_or_1p(N_det_generators,N_det_generators)
soft_touch n_det_max_jacobi ! integer :: i
! n_det_max_jacobi = 50
integer :: n_det_1h1p,n_det_1h2p ! soft_touch n_det_max_jacobi
integer(bit_kind), allocatable :: psi_ref_out(:,:,:) !
integer(bit_kind), allocatable :: psi_1h1p(:,:,:) ! integer :: n_det_1h1p,n_det_1h2p,n_det_extra_1h_or_1p
integer(bit_kind), allocatable :: psi_1h2p(:,:,:) ! integer(bit_kind), allocatable :: psi_ref_out(:,:,:)
double precision, allocatable :: psi_ref_coef_out(:,:) ! integer(bit_kind), allocatable :: psi_1h1p(:,:,:)
double precision, allocatable :: psi_coef_1h1p(:,:) ! integer(bit_kind), allocatable :: psi_1h2p(:,:,:)
double precision, allocatable :: psi_coef_1h2p(:,:) ! integer(bit_kind), allocatable :: psi_extra_1h_or_1p(:,:,:)
call all_single_no_1h_or_1p_or_2p ! double precision, allocatable :: psi_ref_coef_out(:,:)
! double precision, allocatable :: psi_coef_1h1p(:,:)
threshold_davidson = 1.d-12 ! double precision, allocatable :: psi_coef_1h2p(:,:)
soft_touch threshold_davidson davidson_criterion ! double precision, allocatable :: psi_coef_extra_1h_or_1p(:,:)
call diagonalize_CI !!!!call all_single_no_1h_or_1p_or_2p
call give_n_1h1p_and_n_1h2p_in_psi_det(n_det_1h1p,n_det_1h2p) ! call all_single
allocate(psi_ref_out(N_int,2,N_det_generators)) !
allocate(psi_1h1p(N_int,2,n_det_1h1p)) ! threshold_davidson = 1.d-12
allocate(psi_1h2p(N_int,2,n_det_1h2p)) ! soft_touch threshold_davidson davidson_criterion
allocate(psi_ref_coef_out(N_det_generators,N_states)) ! call diagonalize_CI
allocate(psi_coef_1h1p(n_det_1h1p,N_states)) ! call give_n_1h1p_and_n_1h2p_in_psi_det(i_particl,n_det_extra_1h_or_1p,n_det_1h1p,n_det_1h2p)
allocate(psi_coef_1h2p(n_det_1h2p,N_states)) ! allocate(psi_ref_out(N_int,2,N_det_generators))
call split_wf_generators_and_1h1p_and_1h2p(n_det_1h1p,n_det_1h2p,psi_ref_out,psi_ref_coef_out,psi_1h1p,psi_coef_1h1p,psi_1h2p,psi_coef_1h2p) ! allocate(psi_1h1p(N_int,2,n_det_1h1p))
call provide_matrix_dressing_general(dressing_matrix_1h1p,psi_ref_out,psi_ref_coef_out,N_det_generators, & ! allocate(psi_1h2p(N_int,2,n_det_1h2p))
psi_1h1p,psi_coef_1h1p,n_det_1h1p) ! allocate(psi_extra_1h_or_1p(N_int,2,n_det_extra_1h_or_1p))
call provide_matrix_dressing_general(dressing_matrix_1h2p,psi_ref_out,psi_ref_coef_out,N_det_generators, & ! allocate(psi_ref_coef_out(N_det_generators,N_states))
psi_1h2p,psi_coef_1h2p,n_det_1h2p) ! allocate(psi_coef_1h1p(n_det_1h1p,N_states))
! allocate(psi_coef_1h2p(n_det_1h2p,N_states))
deallocate(psi_ref_out) ! allocate(psi_coef_extra_1h_or_1p(n_det_extra_1h_or_1p,N_states))
deallocate(psi_1h1p) ! call split_wf_generators_and_1h1p_and_1h2p(i_particl,n_det_extra_1h_or_1p,n_det_1h1p,n_det_1h2p,psi_ref_out,psi_ref_coef_out,psi_1h1p,psi_coef_1h1p,psi_1h2p,psi_coef_1h2p,psi_extra_1h_or_1p,psi_coef_extra_1h_or_1p)
deallocate(psi_1h2p) ! call provide_matrix_dressing_general(dressing_matrix_1h1p,psi_ref_out,psi_ref_coef_out,N_det_generators, &
deallocate(psi_ref_coef_out) ! psi_1h1p,psi_coef_1h1p,n_det_1h1p)
deallocate(psi_coef_1h1p) ! call provide_matrix_dressing_general(dressing_matrix_1h2p,psi_ref_out,psi_ref_coef_out,N_det_generators, &
deallocate(psi_coef_1h2p) ! psi_1h2p,psi_coef_1h2p,n_det_1h2p)
! call provide_matrix_dressing_for_extra_1h_or_1p(dressing_matrix_extra_1h_or_1p,psi_ref_out,psi_ref_coef_out,N_det_generators, &
end ! psi_extra_1h_or_1p,psi_coef_extra_1h_or_1p,n_det_extra_1h_or_1p)
!
! deallocate(psi_ref_out)
! deallocate(psi_1h1p)
! deallocate(psi_1h2p)
! deallocate(psi_ref_coef_out)
! deallocate(psi_coef_1h1p)
! deallocate(psi_coef_1h2p)
!
! end

436
plugins/FOBOCI/collect_all_lmct.irp.f Normal file
View File

@ -0,0 +1,436 @@
use bitmasks
subroutine collect_lmct(hole_particle,n_couples)
implicit none
integer, intent(out) :: hole_particle(1000,2), n_couples
BEGIN_DOC
! Collect all the couple holes/particles of the important LMCT
! hole_particle(i,1) = ith hole
! hole_particle(i,2) = ith particle
! n_couples is the number of important excitations
END_DOC
print*,'COLLECTING THE PERTINENT LMCT (1h)'
double precision, allocatable :: tmp(:,:)
allocate(tmp(size(one_body_dm_mo_alpha_osoci,1),size(one_body_dm_mo_alpha_osoci,2)))
tmp = one_body_dm_mo_alpha_osoci + one_body_dm_mo_beta_osoci
integer :: i,j,iorb,jorb
n_couples = 0
do i = 1,n_act_orb
iorb = list_act(i)
do j = 1, n_inact_orb
jorb = list_inact(j)
if(dabs(tmp(iorb,jorb)).gt.1.d-2)then
n_couples +=1
hole_particle(n_couples,1) = jorb
hole_particle(n_couples,2) = iorb
print*,'DM'
print*,hole_particle(n_couples,1),hole_particle(n_couples,2),tmp(iorb,jorb)
endif
enddo
enddo
deallocate(tmp)
print*,'number of meaning full couples of holes/particles '
print*,'n_couples = ',n_couples
end
subroutine collect_mlct(hole_particle,n_couples)
implicit none
integer, intent(out) :: hole_particle(1000,2), n_couples
BEGIN_DOC
! Collect all the couple holes/particles of the important LMCT
! hole_particle(i,1) = ith hole
! hole_particle(i,2) = ith particle
! n_couples is the number of important excitations
END_DOC
print*,'COLLECTING THE PERTINENT MLCT (1p)'
double precision, allocatable :: tmp(:,:)
allocate(tmp(size(one_body_dm_mo_alpha_osoci,1),size(one_body_dm_mo_alpha_osoci,2)))
tmp = one_body_dm_mo_alpha_osoci + one_body_dm_mo_beta_osoci
integer :: i,j,iorb,jorb
n_couples = 0
do i = 1,n_act_orb
iorb = list_act(i)
do j = 1, n_virt_orb
jorb = list_virt(j)
if(dabs(tmp(iorb,jorb)).gt.1.d-3)then
n_couples +=1
hole_particle(n_couples,1) = iorb
hole_particle(n_couples,2) = jorb
print*,'DM'
print*,hole_particle(n_couples,1),hole_particle(n_couples,2),tmp(iorb,jorb)
endif
enddo
enddo
deallocate(tmp)
print*,'number of meaning full couples of holes/particles '
print*,'n_couples = ',n_couples
end
subroutine collect_lmct_mlct(hole_particle,n_couples)
implicit none
integer, intent(out) :: hole_particle(1000,2), n_couples
BEGIN_DOC
! Collect all the couple holes/particles of the important LMCT
! hole_particle(i,1) = ith hole
! hole_particle(i,2) = ith particle
! n_couples is the number of important excitations
END_DOC
double precision, allocatable :: tmp(:,:)
print*,'COLLECTING THE PERTINENT LMCT (1h)'
print*,'AND THE PERTINENT MLCT (1p)'
allocate(tmp(size(one_body_dm_mo_alpha_osoci,1),size(one_body_dm_mo_alpha_osoci,2)))
tmp = one_body_dm_mo_alpha_osoci + one_body_dm_mo_beta_osoci
integer :: i,j,iorb,jorb
n_couples = 0
do i = 1,n_act_orb
iorb = list_act(i)
do j = 1, n_inact_orb
jorb = list_inact(j)
if(dabs(tmp(iorb,jorb)).gt.threshold_lmct)then
n_couples +=1
hole_particle(n_couples,1) = jorb
hole_particle(n_couples,2) = iorb
print*,'DM'
print*,hole_particle(n_couples,1),hole_particle(n_couples,2),tmp(iorb,jorb)
endif
enddo
do j = 1, n_virt_orb
jorb = list_virt(j)
if(dabs(tmp(iorb,jorb)).gt.threshold_mlct)then
n_couples +=1
hole_particle(n_couples,1) = iorb
hole_particle(n_couples,2) = jorb
print*,'DM'
print*,hole_particle(n_couples,1),hole_particle(n_couples,2),tmp(iorb,jorb)
endif
enddo
enddo
deallocate(tmp)
print*,'number of meaning full couples of holes/particles '
print*,'n_couples = ',n_couples
end
subroutine collect_1h1p(hole_particle,n_couples)
implicit none
integer, intent(out) :: hole_particle(1000,2), n_couples
BEGIN_DOC
! Collect all the couple holes/particles of the important LMCT
! hole_particle(i,1) = ith hole
! hole_particle(i,2) = ith particle
! n_couples is the number of important excitations
END_DOC
double precision, allocatable :: tmp(:,:)
print*,'COLLECTING THE PERTINENT 1h1p'
allocate(tmp(size(one_body_dm_mo_alpha_osoci,1),size(one_body_dm_mo_alpha_osoci,2)))
tmp = one_body_dm_mo_alpha_osoci + one_body_dm_mo_beta_osoci
integer :: i,j,iorb,jorb
n_couples = 0
do i = 1,n_virt_orb
iorb = list_virt(i)
do j = 1, n_inact_orb
jorb = list_inact(j)
if(dabs(tmp(iorb,jorb)).gt.1.d-2)then
n_couples +=1
hole_particle(n_couples,1) = jorb
hole_particle(n_couples,2) = iorb
print*,'DM'
print*,hole_particle(n_couples,1),hole_particle(n_couples,2),tmp(iorb,jorb)
endif
enddo
enddo
deallocate(tmp)
print*,'number of meaning full couples of holes/particles '
print*,'n_couples = ',n_couples
end
subroutine set_lmct_to_generators_restart
implicit none
integer :: i,j,m,n,i_hole,i_particle
integer :: hole_particle(1000,2), n_couples
integer(bit_kind) :: key_tmp(N_int,2)
integer :: N_det_total,i_ok
call collect_lmct(hole_particle,n_couples)
call set_generators_to_generators_restart
N_det_total = N_det_generators_restart
do i = 1, n_couples
i_hole = hole_particle(i,1)
i_particle = hole_particle(i,2)
do m = 1, N_det_cas
do n = 1, N_int
key_tmp(n,1) = psi_cas(n,1,m)
key_tmp(n,2) = psi_cas(n,2,m)
enddo
! You excite the beta electron from i_hole to i_particle
print*,'i_hole,i_particle 2 = ',i_hole,i_particle
call do_mono_excitation(key_tmp,i_hole,i_particle,2,i_ok)
print*,'i_ok = ',i_ok
if(i_ok==1)then
N_det_total +=1
do n = 1, N_int
psi_det_generators(n,1,N_det_total) = key_tmp(n,1)
psi_det_generators(n,2,N_det_total) = key_tmp(n,2)
enddo
endif
do n = 1, N_int
key_tmp(n,1) = psi_cas(n,1,m)
key_tmp(n,2) = psi_cas(n,2,m)
enddo
! You excite the alpha electron from i_hole to i_particle
print*,'i_hole,i_particle 1 = ',i_hole,i_particle
call do_mono_excitation(key_tmp,i_hole,i_particle,1,i_ok)
print*,'i_ok = ',i_ok
if(i_ok==1)then
N_det_total +=1
do n = 1, N_int
psi_det_generators(n,1,N_det_total) = key_tmp(n,1)
psi_det_generators(n,2,N_det_total) = key_tmp(n,2)
enddo
endif
enddo
enddo
N_det_generators = N_det_total
do i = 1, N_det_generators
psi_coef_generators(i,1) = 1.d0/dsqrt(dble(N_det_total))
enddo
print*,'number of generators in total = ',N_det_generators
touch N_det_generators psi_coef_generators psi_det_generators
end
subroutine set_mlct_to_generators_restart
implicit none
integer :: i,j,m,n,i_hole,i_particle
integer :: hole_particle(1000,2), n_couples
integer(bit_kind) :: key_tmp(N_int,2)
integer :: N_det_total,i_ok
call collect_mlct(hole_particle,n_couples)
call set_generators_to_generators_restart
N_det_total = N_det_generators_restart
do i = 1, n_couples
i_hole = hole_particle(i,1)
i_particle = hole_particle(i,2)
do m = 1, N_det_cas
do n = 1, N_int
key_tmp(n,1) = psi_cas(n,1,m)
key_tmp(n,2) = psi_cas(n,2,m)
enddo
! You excite the beta electron from i_hole to i_particle
print*,'i_hole,i_particle 2 = ',i_hole,i_particle
call do_mono_excitation(key_tmp,i_hole,i_particle,2,i_ok)
print*,'i_ok = ',i_ok
if(i_ok==1)then
N_det_total +=1
do n = 1, N_int
psi_det_generators(n,1,N_det_total) = key_tmp(n,1)
psi_det_generators(n,2,N_det_total) = key_tmp(n,2)
enddo
endif
do n = 1, N_int
key_tmp(n,1) = psi_cas(n,1,m)
key_tmp(n,2) = psi_cas(n,2,m)
enddo
! You excite the alpha electron from i_hole to i_particle
print*,'i_hole,i_particle 1 = ',i_hole,i_particle
call do_mono_excitation(key_tmp,i_hole,i_particle,1,i_ok)
print*,'i_ok = ',i_ok
if(i_ok==1)then
N_det_total +=1
do n = 1, N_int
psi_det_generators(n,1,N_det_total) = key_tmp(n,1)
psi_det_generators(n,2,N_det_total) = key_tmp(n,2)
enddo
endif
enddo
enddo
N_det_generators = N_det_total
do i = 1, N_det_generators
psi_coef_generators(i,1) = 1.d0/dsqrt(dble(N_det_total))
enddo
print*,'number of generators in total = ',N_det_generators
touch N_det_generators psi_coef_generators psi_det_generators
end
subroutine set_lmct_mlct_to_generators_restart
implicit none
integer :: i,j,m,n,i_hole,i_particle
integer :: hole_particle(1000,2), n_couples
integer(bit_kind) :: key_tmp(N_int,2)
integer :: N_det_total,i_ok
call collect_lmct_mlct(hole_particle,n_couples)
call set_generators_to_generators_restart
N_det_total = N_det_generators_restart
do i = 1, n_couples
i_hole = hole_particle(i,1)
i_particle = hole_particle(i,2)
do m = 1, N_det_cas
do n = 1, N_int
key_tmp(n,1) = psi_cas(n,1,m)
key_tmp(n,2) = psi_cas(n,2,m)
enddo
! You excite the beta electron from i_hole to i_particle
call do_mono_excitation(key_tmp,i_hole,i_particle,2,i_ok)
if(i_ok==1)then
N_det_total +=1
do n = 1, N_int
psi_det_generators(n,1,N_det_total) = key_tmp(n,1)
psi_det_generators(n,2,N_det_total) = key_tmp(n,2)
enddo
endif
do n = 1, N_int
key_tmp(n,1) = psi_cas(n,1,m)
key_tmp(n,2) = psi_cas(n,2,m)
enddo
! You excite the alpha electron from i_hole to i_particle
call do_mono_excitation(key_tmp,i_hole,i_particle,1,i_ok)
if(i_ok==1)then
N_det_total +=1
do n = 1, N_int
psi_det_generators(n,1,N_det_total) = key_tmp(n,1)
psi_det_generators(n,2,N_det_total) = key_tmp(n,2)
enddo
endif
enddo
enddo
N_det_generators = N_det_total
do i = 1, N_det_generators
psi_coef_generators(i,1) = 1.d0/dsqrt(dble(N_det_total))
enddo
print*,'number of generators in total = ',N_det_generators
touch N_det_generators psi_coef_generators psi_det_generators
end
subroutine set_lmct_mlct_to_psi_det
implicit none
integer :: i,j,m,n,i_hole,i_particle
integer :: hole_particle(1000,2), n_couples
integer(bit_kind) :: key_tmp(N_int,2)
integer :: N_det_total,i_ok
call collect_lmct_mlct(hole_particle,n_couples)
call set_psi_det_to_generators_restart
N_det_total = N_det_generators_restart
do i = 1, n_couples
i_hole = hole_particle(i,1)
i_particle = hole_particle(i,2)
do m = 1, N_det_generators_restart
do n = 1, N_int
key_tmp(n,1) = psi_det_generators_restart(n,1,m)
key_tmp(n,2) = psi_det_generators_restart(n,2,m)
enddo
! You excite the beta electron from i_hole to i_particle
call do_mono_excitation(key_tmp,i_hole,i_particle,2,i_ok)
if(i_ok==1)then
N_det_total +=1
do n = 1, N_int
psi_det(n,1,N_det_total) = key_tmp(n,1)
psi_det(n,2,N_det_total) = key_tmp(n,2)
enddo
endif
do n = 1, N_int
key_tmp(n,1) = psi_det_generators_restart(n,1,m)
key_tmp(n,2) = psi_det_generators_restart(n,2,m)
enddo
! You excite the alpha electron from i_hole to i_particle
call do_mono_excitation(key_tmp,i_hole,i_particle,1,i_ok)
if(i_ok==1)then
N_det_total +=1
do n = 1, N_int
psi_det(n,1,N_det_total) = key_tmp(n,1)
psi_det(n,2,N_det_total) = key_tmp(n,2)
enddo
endif
enddo
enddo
N_det = N_det_total
integer :: k
do k = 1, N_states
do i = 1, N_det
psi_coef(i,k) = 1.d0/dsqrt(dble(N_det_total))
enddo
enddo
SOFT_TOUCH N_det psi_det psi_coef
logical :: found_duplicates
call remove_duplicates_in_psi_det(found_duplicates)
end
subroutine set_1h1p_to_psi_det
implicit none
integer :: i,j,m,n,i_hole,i_particle
integer :: hole_particle(1000,2), n_couples
integer(bit_kind) :: key_tmp(N_int,2)
integer :: N_det_total,i_ok
call collect_1h1p(hole_particle,n_couples)
call set_psi_det_to_generators_restart
N_det_total = N_det_generators_restart
do i = 1, n_couples
i_hole = hole_particle(i,1)
i_particle = hole_particle(i,2)
do m = 1, N_det_generators_restart
do n = 1, N_int
key_tmp(n,1) = psi_det_generators_restart(n,1,m)
key_tmp(n,2) = psi_det_generators_restart(n,2,m)
enddo
! You excite the beta electron from i_hole to i_particle
call do_mono_excitation(key_tmp,i_hole,i_particle,2,i_ok)
if(i_ok==1)then
N_det_total +=1
do n = 1, N_int
psi_det(n,1,N_det_total) = key_tmp(n,1)
psi_det(n,2,N_det_total) = key_tmp(n,2)
enddo
endif
do n = 1, N_int
key_tmp(n,1) = psi_det_generators_restart(n,1,m)
key_tmp(n,2) = psi_det_generators_restart(n,2,m)
enddo
! You excite the alpha electron from i_hole to i_particle
call do_mono_excitation(key_tmp,i_hole,i_particle,1,i_ok)
if(i_ok==1)then
N_det_total +=1
do n = 1, N_int
psi_det(n,1,N_det_total) = key_tmp(n,1)
psi_det(n,2,N_det_total) = key_tmp(n,2)
enddo
endif
enddo
enddo
N_det = N_det_total
integer :: k
do k = 1, N_states
do i = 1, N_det
psi_coef(i,k) = 1.d0/dsqrt(dble(N_det_total))
enddo
enddo
SOFT_TOUCH N_det psi_det psi_coef
logical :: found_duplicates
call remove_duplicates_in_psi_det(found_duplicates)
end

425
plugins/FOBOCI/corr_energy_2h2p.irp.f Normal file
View File

@ -0,0 +1,425 @@
BEGIN_PROVIDER [double precision, corr_energy_2h2p_per_orb_ab, (mo_tot_num)]
&BEGIN_PROVIDER [double precision, corr_energy_2h2p_ab_2_orb, (mo_tot_num,mo_tot_num)]
&BEGIN_PROVIDER [double precision, corr_energy_2h2p_bb_2_orb, (mo_tot_num,mo_tot_num)]
&BEGIN_PROVIDER [double precision, corr_energy_2h2p_for_1h1p_a, (mo_tot_num,mo_tot_num)]
&BEGIN_PROVIDER [double precision, corr_energy_2h2p_for_1h1p_b, (mo_tot_num,mo_tot_num)]
&BEGIN_PROVIDER [double precision, corr_energy_2h2p_for_1h1p_double, (mo_tot_num,mo_tot_num)]
&BEGIN_PROVIDER [double precision, corr_energy_2h2p_per_orb_aa, (mo_tot_num)]
&BEGIN_PROVIDER [double precision, corr_energy_2h2p_per_orb_bb, (mo_tot_num)]
&BEGIN_PROVIDER [ double precision, total_corr_e_2h2p]
use bitmasks
print*,''
print*,'Providing the 2h2p correlation energy'
print*,''
implicit none
integer(bit_kind) :: key_tmp(N_int,2)
integer :: i,j,k,l
integer :: i_hole,j_hole,k_part,l_part
double precision :: get_mo_bielec_integral_schwartz,hij,delta_e,exc,contrib
double precision :: diag_H_mat_elem
integer :: i_ok,ispin
! Alpha - Beta correlation energy
total_corr_e_2h2p = 0.d0
corr_energy_2h2p_ab_2_orb = 0.d0
corr_energy_2h2p_bb_2_orb = 0.d0
corr_energy_2h2p_per_orb_ab = 0.d0
corr_energy_2h2p_per_orb_aa = 0.d0
corr_energy_2h2p_per_orb_bb = 0.d0
corr_energy_2h2p_for_1h1p_a = 0.d0
corr_energy_2h2p_for_1h1p_b = 0.d0
corr_energy_2h2p_for_1h1p_double = 0.d0
do i = 1, n_inact_orb ! beta
i_hole = list_inact(i)
do k = 1, n_virt_orb ! beta
k_part = list_virt(k)
do j = 1, n_inact_orb ! alpha
j_hole = list_inact(j)
do l = 1, n_virt_orb ! alpha
l_part = list_virt(l)
key_tmp = ref_bitmask
ispin = 2
call do_mono_excitation(key_tmp,i_hole,k_part,ispin,i_ok)
if(i_ok .ne.1)cycle
ispin = 1
call do_mono_excitation(key_tmp,j_hole,l_part,ispin,i_ok)
if(i_ok .ne.1)cycle
delta_e = (ref_bitmask_energy - diag_H_mat_elem(key_tmp,N_int))
hij = get_mo_bielec_integral_schwartz(i_hole,j_hole,k_part,l_part,mo_integrals_map)
contrib = hij*hij/delta_e
total_corr_e_2h2p += contrib
! Single orbital contribution
corr_energy_2h2p_per_orb_ab(i_hole) += contrib
corr_energy_2h2p_per_orb_ab(k_part) += contrib
! Couple of orbital contribution for the single 1h1p
corr_energy_2h2p_for_1h1p_a(j_hole,l_part) += contrib
corr_energy_2h2p_for_1h1p_a(l_part,j_hole) += contrib
corr_energy_2h2p_for_1h1p_b(j_hole,l_part) += contrib
corr_energy_2h2p_for_1h1p_b(l_part,j_hole) += contrib
! Couple of orbital contribution for the double 1h1p
corr_energy_2h2p_for_1h1p_double(i_hole,l_part) += contrib
corr_energy_2h2p_for_1h1p_double(l_part,i_hole) += contrib
corr_energy_2h2p_ab_2_orb(i_hole,j_hole) += contrib
corr_energy_2h2p_ab_2_orb(j_hole,i_hole) += contrib
corr_energy_2h2p_ab_2_orb(i_hole,k_part) += contrib
corr_energy_2h2p_ab_2_orb(k_part,i_hole) += contrib
corr_energy_2h2p_ab_2_orb(k_part,l_part) += contrib
corr_energy_2h2p_ab_2_orb(l_part,k_part) += contrib
enddo
enddo
enddo
enddo
! alpha alpha correlation energy
do i = 1, n_inact_orb
i_hole = list_inact(i)
do j = i+1, n_inact_orb
j_hole = list_inact(j)
do k = 1, n_virt_orb
k_part = list_virt(k)
do l = k+1,n_virt_orb
l_part = list_virt(l)
hij = get_mo_bielec_integral_schwartz(i_hole,j_hole,k_part,l_part,mo_integrals_map)
exc = get_mo_bielec_integral_schwartz(i_hole,j_hole,l_part,k_part,mo_integrals_map)
key_tmp = ref_bitmask
ispin = 1
call do_mono_excitation(key_tmp,i_hole,k_part,ispin,i_ok)
if(i_ok .ne.1)cycle
ispin = 1
call do_mono_excitation(key_tmp,j_hole,l_part,ispin,i_ok)
if(i_ok .ne.1)cycle
delta_e = -(ref_bitmask_energy - diag_H_mat_elem(key_tmp,N_int))
hij = hij - exc
contrib = 0.5d0 * (delta_e - dsqrt(delta_e * delta_e + 4.d0 * hij*hij))
total_corr_e_2h2p += contrib
! Single orbital contribution
corr_energy_2h2p_per_orb_aa(i_hole) += contrib
corr_energy_2h2p_per_orb_aa(k_part) += contrib
! Couple of orbital contribution for the single 1h1p
corr_energy_2h2p_for_1h1p_a(i_hole,k_part) += contrib
corr_energy_2h2p_for_1h1p_a(k_part,i_hole) += contrib
enddo
enddo
enddo
enddo
! beta beta correlation energy
do i = 1, n_inact_orb
i_hole = list_inact(i)
do j = i+1, n_inact_orb
j_hole = list_inact(j)
do k = 1, n_virt_orb
k_part = list_virt(k)
do l = k+1,n_virt_orb
l_part = list_virt(l)
hij = get_mo_bielec_integral_schwartz(i_hole,j_hole,k_part,l_part,mo_integrals_map)
exc = get_mo_bielec_integral_schwartz(i_hole,j_hole,l_part,k_part,mo_integrals_map)
key_tmp = ref_bitmask
ispin = 2
call do_mono_excitation(key_tmp,i_hole,k_part,ispin,i_ok)
if(i_ok .ne.1)cycle
ispin = 2
call do_mono_excitation(key_tmp,j_hole,l_part,ispin,i_ok)
if(i_ok .ne.1)cycle
delta_e = -(ref_bitmask_energy - diag_H_mat_elem(key_tmp,N_int))
hij = hij - exc
contrib = 0.5d0 * (delta_e - dsqrt(delta_e * delta_e + 4.d0 * hij*hij))
total_corr_e_2h2p += contrib
! Single orbital contribution
corr_energy_2h2p_per_orb_bb(i_hole) += contrib
corr_energy_2h2p_per_orb_bb(k_part) += contrib
corr_energy_2h2p_for_1h1p_b(i_hole,k_part) += contrib
corr_energy_2h2p_for_1h1p_b(k_part,i_hole) += contrib
! Two particle correlation energy
corr_energy_2h2p_bb_2_orb(i_hole,j_hole) += contrib
corr_energy_2h2p_bb_2_orb(j_hole,i_hole) += contrib
corr_energy_2h2p_bb_2_orb(i_hole,k_part) += contrib
corr_energy_2h2p_bb_2_orb(k_part,i_hole) += contrib
corr_energy_2h2p_bb_2_orb(k_part,l_part) += contrib
corr_energy_2h2p_bb_2_orb(l_part,k_part) += contrib
enddo
enddo
enddo
enddo
END_PROVIDER
BEGIN_PROVIDER [double precision, corr_energy_2h1p_ab_bb_per_2_orb, (mo_tot_num,mo_tot_num)]
&BEGIN_PROVIDER [double precision, corr_energy_2h1p_for_1h1p_a, (mo_tot_num,mo_tot_num)]
&BEGIN_PROVIDER [double precision, corr_energy_2h1p_for_1h1p_b, (mo_tot_num,mo_tot_num)]
&BEGIN_PROVIDER [double precision, corr_energy_2h1p_for_1h1p_double, (mo_tot_num,mo_tot_num)]
&BEGIN_PROVIDER [double precision, corr_energy_2h1p_per_orb_ab, (mo_tot_num)]
&BEGIN_PROVIDER [double precision, corr_energy_2h1p_per_orb_aa, (mo_tot_num)]
&BEGIN_PROVIDER [double precision, corr_energy_2h1p_per_orb_bb, (mo_tot_num)]
&BEGIN_PROVIDER [ double precision, total_corr_e_2h1p]
use bitmasks
implicit none
integer(bit_kind) :: key_tmp(N_int,2)
integer :: i,j,k,l
integer :: i_hole,j_hole,k_part,l_part
double precision :: get_mo_bielec_integral_schwartz,hij,delta_e,exc,contrib
double precision :: diag_H_mat_elem
integer :: i_ok,ispin
! Alpha - Beta correlation energy
total_corr_e_2h1p = 0.d0
corr_energy_2h1p_per_orb_ab = 0.d0
corr_energy_2h1p_per_orb_aa = 0.d0
corr_energy_2h1p_per_orb_bb = 0.d0
corr_energy_2h1p_ab_bb_per_2_orb = 0.d0
corr_energy_2h1p_for_1h1p_a = 0.d0
corr_energy_2h1p_for_1h1p_b = 0.d0
corr_energy_2h1p_for_1h1p_double = 0.d0
do i = 1, n_inact_orb
i_hole = list_inact(i)
do k = 1, n_act_orb
k_part = list_act(k)
do j = 1, n_inact_orb
j_hole = list_inact(j)
do l = 1, n_virt_orb
l_part = list_virt(l)
key_tmp = ref_bitmask
ispin = 2
call do_mono_excitation(key_tmp,i_hole,k_part,ispin,i_ok)
if(i_ok .ne.1)cycle
ispin = 1
call do_mono_excitation(key_tmp,j_hole,l_part,ispin,i_ok)
if(i_ok .ne.1)cycle
delta_e = -(ref_bitmask_energy - diag_H_mat_elem(key_tmp,N_int))
hij = get_mo_bielec_integral_schwartz(i_hole,j_hole,k_part,l_part,mo_integrals_map)
contrib = 0.5d0 * (delta_e - dsqrt(delta_e * delta_e + 4.d0 * hij*hij))
total_corr_e_2h1p += contrib
corr_energy_2h1p_ab_bb_per_2_orb(i_hole,j_hole) += contrib
corr_energy_2h1p_per_orb_ab(i_hole) += contrib
corr_energy_2h1p_per_orb_ab(l_part) += contrib
enddo
enddo
enddo
enddo
! Alpha Alpha spin correlation energy
do i = 1, n_inact_orb
i_hole = list_inact(i)
do j = i+1, n_inact_orb
j_hole = list_inact(j)
do k = 1, n_act_orb
k_part = list_act(k)
do l = 1,n_virt_orb
l_part = list_virt(l)
hij = get_mo_bielec_integral_schwartz(i_hole,j_hole,k_part,l_part,mo_integrals_map)
exc = get_mo_bielec_integral_schwartz(i_hole,j_hole,l_part,k_part,mo_integrals_map)
key_tmp = ref_bitmask
ispin = 1
call do_mono_excitation(key_tmp,i_hole,k_part,ispin,i_ok)
if(i_ok .ne.1)cycle
ispin = 1
call do_mono_excitation(key_tmp,j_hole,l_part,ispin,i_ok)
if(i_ok .ne.1)cycle
delta_e = -(ref_bitmask_energy - diag_H_mat_elem(key_tmp,N_int))
hij = hij - exc
contrib = 0.5d0 * (delta_e - dsqrt(delta_e * delta_e + 4.d0 * hij*hij))
total_corr_e_2h1p += contrib
corr_energy_2h1p_per_orb_aa(i_hole) += contrib
corr_energy_2h1p_per_orb_aa(l_part) += contrib
enddo
enddo
enddo
enddo
! Beta Beta correlation energy
do i = 1, n_inact_orb
i_hole = list_inact(i)
do j = i+1, n_inact_orb
j_hole = list_inact(j)
do k = 1, n_act_orb
k_part = list_act(k)
do l = 1,n_virt_orb
l_part = list_virt(l)
hij = get_mo_bielec_integral_schwartz(i_hole,j_hole,k_part,l_part,mo_integrals_map)
exc = get_mo_bielec_integral_schwartz(i_hole,j_hole,l_part,k_part,mo_integrals_map)
key_tmp = ref_bitmask
ispin = 2
call do_mono_excitation(key_tmp,i_hole,k_part,ispin,i_ok)
if(i_ok .ne.1)cycle
ispin = 2
call do_mono_excitation(key_tmp,j_hole,l_part,ispin,i_ok)
if(i_ok .ne.1)cycle
delta_e = -(ref_bitmask_energy - diag_H_mat_elem(key_tmp,N_int))
hij = hij - exc
contrib = 0.5d0 * (delta_e - dsqrt(delta_e * delta_e + 4.d0 * hij*hij))
corr_energy_2h1p_ab_bb_per_2_orb(i_hole,j_hole) += contrib
total_corr_e_2h1p += contrib
corr_energy_2h1p_per_orb_bb(i_hole) += contrib
corr_energy_2h1p_per_orb_aa(l_part) += contrib
enddo
enddo
enddo
enddo
END_PROVIDER
BEGIN_PROVIDER [double precision, corr_energy_1h2p_per_orb_ab, (mo_tot_num)]
&BEGIN_PROVIDER [double precision, corr_energy_1h2p_two_orb, (mo_tot_num,mo_tot_num)]
&BEGIN_PROVIDER [double precision, corr_energy_1h2p_per_orb_aa, (mo_tot_num)]
&BEGIN_PROVIDER [double precision, corr_energy_1h2p_per_orb_bb, (mo_tot_num)]
&BEGIN_PROVIDER [ double precision, total_corr_e_1h2p]
use bitmasks
implicit none
integer(bit_kind) :: key_tmp(N_int,2)
integer :: i,j,k,l
integer :: i_hole,j_hole,k_part,l_part
double precision :: get_mo_bielec_integral_schwartz,hij,delta_e,exc,contrib
double precision :: diag_H_mat_elem
integer :: i_ok,ispin
! Alpha - Beta correlation energy
total_corr_e_1h2p = 0.d0
corr_energy_1h2p_per_orb_ab = 0.d0
corr_energy_1h2p_per_orb_aa = 0.d0
corr_energy_1h2p_per_orb_bb = 0.d0
do i = 1, n_virt_orb
i_hole = list_virt(i)
do k = 1, n_act_orb
k_part = list_act(k)
do j = 1, n_inact_orb
j_hole = list_inact(j)
do l = 1, n_virt_orb
l_part = list_virt(l)
key_tmp = ref_bitmask
ispin = 2
call do_mono_excitation(key_tmp,i_hole,k_part,ispin,i_ok)
if(i_ok .ne.1)cycle
ispin = 1
call do_mono_excitation(key_tmp,j_hole,l_part,ispin,i_ok)
if(i_ok .ne.1)cycle
delta_e = -(ref_bitmask_energy - diag_H_mat_elem(key_tmp,N_int))
hij = get_mo_bielec_integral_schwartz(i_hole,j_hole,k_part,l_part,mo_integrals_map)
contrib = 0.5d0 * (delta_e - dsqrt(delta_e * delta_e + 4.d0 * hij*hij))
total_corr_e_1h2p += contrib
corr_energy_1h2p_per_orb_ab(i_hole) += contrib
corr_energy_1h2p_per_orb_ab(j_hole) += contrib
corr_energy_1h2p_two_orb(k_part,l_part) += contrib
corr_energy_1h2p_two_orb(l_part,k_part) += contrib
enddo
enddo
enddo
enddo
! Alpha Alpha correlation energy
do i = 1, n_virt_orb
i_hole = list_virt(i)
do j = 1, n_inact_orb
j_hole = list_inact(j)
do k = 1, n_act_orb
k_part = list_act(k)
do l = i+1,n_virt_orb
l_part = list_virt(l)
hij = get_mo_bielec_integral_schwartz(i_hole,j_hole,k_part,l_part,mo_integrals_map)
exc = get_mo_bielec_integral_schwartz(i_hole,j_hole,l_part,k_part,mo_integrals_map)
key_tmp = ref_bitmask
ispin = 1
call do_mono_excitation(key_tmp,i_hole,k_part,ispin,i_ok)
if(i_ok .ne.1)cycle
ispin = 1
call do_mono_excitation(key_tmp,j_hole,l_part,ispin,i_ok)
if(i_ok .ne.1)cycle
delta_e = -(ref_bitmask_energy - diag_H_mat_elem(key_tmp,N_int))
hij = hij - exc
contrib = 0.5d0 * (delta_e - dsqrt(delta_e * delta_e + 4.d0 * hij*hij))
total_corr_e_1h2p += contrib
corr_energy_1h2p_per_orb_aa(i_hole) += contrib
corr_energy_1h2p_per_orb_ab(j_hole) += contrib
corr_energy_1h2p_two_orb(k_part,l_part) += contrib
corr_energy_1h2p_two_orb(l_part,k_part) += contrib
enddo
enddo
enddo
enddo
! Beta Beta correlation energy
do i = 1, n_virt_orb
i_hole = list_virt(i)
do j = 1, n_inact_orb
j_hole = list_inact(j)
do k = 1, n_act_orb
k_part = list_act(k)
do l = i+1,n_virt_orb
l_part = list_virt(l)
hij = get_mo_bielec_integral_schwartz(i_hole,j_hole,k_part,l_part,mo_integrals_map)
exc = get_mo_bielec_integral_schwartz(i_hole,j_hole,l_part,k_part,mo_integrals_map)
key_tmp = ref_bitmask
ispin = 2
call do_mono_excitation(key_tmp,i_hole,k_part,ispin,i_ok)
if(i_ok .ne.1)cycle
ispin = 2
call do_mono_excitation(key_tmp,j_hole,l_part,ispin,i_ok)
if(i_ok .ne.1)cycle
delta_e = -(ref_bitmask_energy - diag_H_mat_elem(key_tmp,N_int))
hij = hij - exc
contrib = 0.5d0 * (delta_e - dsqrt(delta_e * delta_e + 4.d0 * hij*hij))
total_corr_e_1h2p += contrib
corr_energy_1h2p_per_orb_bb(i_hole) += contrib
corr_energy_1h2p_per_orb_ab(j_hole) += contrib
corr_energy_1h2p_two_orb(k_part,l_part) += contrib
corr_energy_1h2p_two_orb(l_part,k_part) += contrib
enddo
enddo
enddo
enddo
END_PROVIDER
BEGIN_PROVIDER [double precision, corr_energy_1h1p_spin_flip_per_orb, (mo_tot_num)]
&BEGIN_PROVIDER [ double precision, total_corr_e_1h1p_spin_flip]
use bitmasks
implicit none
integer(bit_kind) :: key_tmp(N_int,2)
integer :: i,j,k,l
integer :: i_hole,j_hole,k_part,l_part
double precision :: get_mo_bielec_integral_schwartz,hij,delta_e,exc,contrib
double precision :: diag_H_mat_elem
integer :: i_ok,ispin
! Alpha - Beta correlation energy
total_corr_e_1h1p_spin_flip = 0.d0
corr_energy_1h1p_spin_flip_per_orb = 0.d0
do i = 1, n_inact_orb
i_hole = list_inact(i)
do k = 1, n_act_orb
k_part = list_act(k)
do j = 1, n_act_orb
j_hole = list_act(j)
do l = 1, n_virt_orb
l_part = list_virt(l)
key_tmp = ref_bitmask
ispin = 2
call do_mono_excitation(key_tmp,i_hole,k_part,ispin,i_ok)
if(i_ok .ne.1)cycle
ispin = 1
call do_mono_excitation(key_tmp,j_hole,l_part,ispin,i_ok)
if(i_ok .ne.1)cycle
delta_e = -(ref_bitmask_energy - diag_H_mat_elem(key_tmp,N_int))
hij = get_mo_bielec_integral_schwartz(i_hole,j_hole,k_part,l_part,mo_integrals_map)
contrib = 0.5d0 * (delta_e - dsqrt(delta_e * delta_e + 4.d0 * hij*hij))
total_corr_e_1h1p_spin_flip += contrib
corr_energy_1h1p_spin_flip_per_orb(i_hole) += contrib
enddo
enddo
enddo
enddo
END_PROVIDER

48
plugins/FOBOCI/diag_fock_inactiv_virt.irp.f
View File

@ -3,6 +3,7 @@ subroutine diag_inactive_virt_and_update_mos
integer :: i,j,i_inact,j_inact,i_virt,j_virt integer :: i,j,i_inact,j_inact,i_virt,j_virt
double precision :: tmp(mo_tot_num_align,mo_tot_num) double precision :: tmp(mo_tot_num_align,mo_tot_num)
character*(64) :: label character*(64) :: label
print*,'Diagonalizing the occ and virt Fock operator'
tmp = 0.d0 tmp = 0.d0
do i = 1, mo_tot_num do i = 1, mo_tot_num
tmp(i,i) = Fock_matrix_mo(i,i) tmp(i,i) = Fock_matrix_mo(i,i)
@ -33,3 +34,50 @@ subroutine diag_inactive_virt_and_update_mos
end end
subroutine diag_inactive_virt_new_and_update_mos
implicit none
integer :: i,j,i_inact,j_inact,i_virt,j_virt,k,k_act
double precision :: tmp(mo_tot_num_align,mo_tot_num),accu,get_mo_bielec_integral_schwartz
character*(64) :: label
tmp = 0.d0
do i = 1, mo_tot_num
tmp(i,i) = Fock_matrix_mo(i,i)
enddo
do i = 1, n_inact_orb
i_inact = list_inact(i)
do j = i+1, n_inact_orb
j_inact = list_inact(j)
accu =0.d0
do k = 1, n_act_orb
k_act = list_act(k)
accu += get_mo_bielec_integral_schwartz(i_inact,k_act,j_inact,k_act,mo_integrals_map)
accu -= get_mo_bielec_integral_schwartz(i_inact,k_act,k_act,j_inact,mo_integrals_map)
enddo
tmp(i_inact,j_inact) = Fock_matrix_mo(i_inact,j_inact) + accu
tmp(j_inact,i_inact) = Fock_matrix_mo(j_inact,i_inact) + accu
enddo
enddo
do i = 1, n_virt_orb
i_virt = list_virt(i)
do j = i+1, n_virt_orb
j_virt = list_virt(j)
accu =0.d0
do k = 1, n_act_orb
k_act = list_act(k)
accu += get_mo_bielec_integral_schwartz(i_virt,k_act,j_virt,k_act,mo_integrals_map)
enddo
tmp(i_virt,j_virt) = Fock_matrix_mo(i_virt,j_virt) - accu
tmp(j_virt,i_virt) = Fock_matrix_mo(j_virt,i_virt) - accu
enddo
enddo
label = "Canonical"
call mo_as_eigvectors_of_mo_matrix(tmp,size(tmp,1),size(tmp,2),label,1)
soft_touch mo_coef
end

61
plugins/FOBOCI/dress_simple.irp.f
View File

@ -58,24 +58,24 @@ subroutine standard_dress(delta_ij_generators_,size_buffer,Ndet_generators,i_gen
call i_h_j(det_buffer(1,1,i),det_buffer(1,1,i),Nint,haa) call i_h_j(det_buffer(1,1,i),det_buffer(1,1,i),Nint,haa)
f = 1.d0/(E_ref-haa) f = 1.d0/(E_ref-haa)
if(second_order_h)then ! if(second_order_h)then
lambda_i = f lambda_i = f
else ! else
! You write the new Hamiltonian matrix ! ! You write the new Hamiltonian matrix
do k = 1, Ndet_generators ! do k = 1, Ndet_generators
H_matrix_tmp(k,Ndet_generators+1) = H_array(k) ! H_matrix_tmp(k,Ndet_generators+1) = H_array(k)
H_matrix_tmp(Ndet_generators+1,k) = H_array(k) ! H_matrix_tmp(Ndet_generators+1,k) = H_array(k)
enddo ! enddo
H_matrix_tmp(Ndet_generators+1,Ndet_generators+1) = haa ! H_matrix_tmp(Ndet_generators+1,Ndet_generators+1) = haa
! Then diagonalize it ! ! Then diagonalize it
call lapack_diag(eigenvalues,eigenvectors,H_matrix_tmp,Ndet_generators+1,Ndet_generators+1) ! call lapack_diag(eigenvalues,eigenvectors,H_matrix_tmp,Ndet_generators+1,Ndet_generators+1)
! Then you extract the effective denominator ! ! Then you extract the effective denominator
accu = 0.d0 ! accu = 0.d0
do k = 1, Ndet_generators ! do k = 1, Ndet_generators
accu += eigenvectors(k,1) * H_array(k) ! accu += eigenvectors(k,1) * H_array(k)
enddo ! enddo
lambda_i = eigenvectors(Ndet_generators+1,1)/accu ! lambda_i = eigenvectors(Ndet_generators+1,1)/accu
endif ! endif
do k=1,idx(0) do k=1,idx(0)
contrib = H_array(idx(k)) * H_array(idx(k)) * lambda_i contrib = H_array(idx(k)) * H_array(idx(k)) * lambda_i
delta_ij_generators_(idx(k), idx(k)) += contrib delta_ij_generators_(idx(k), idx(k)) += contrib
@ -85,33 +85,6 @@ subroutine standard_dress(delta_ij_generators_,size_buffer,Ndet_generators,i_gen
delta_ij_generators_(idx(j), idx(k)) += contrib delta_ij_generators_(idx(j), idx(k)) += contrib
enddo enddo
enddo enddo
! H_matrix_tmp_bis(idx(k),idx(k)) += contrib
! H_matrix_tmp_bis(idx(k),idx(j)) += contrib
! H_matrix_tmp_bis(idx(j),idx(k)) += contrib
! do k = 1, Ndet_generators
! do j = 1, Ndet_generators
! H_matrix_tmp_bis(k,j) = H_matrix_tmp(k,j)
! enddo
! enddo
! double precision :: H_matrix_tmp_bis(Ndet_generators,Ndet_generators)
! double precision :: eigenvectors_bis(Ndet_generators,Ndet_generators), eigenvalues_bis(Ndet_generators)
! call lapack_diag(eigenvalues_bis,eigenvectors_bis,H_matrix_tmp_bis,Ndet_generators,Ndet_generators)
! print*,'f,lambda_i = ',f,lambda_i
! print*,'eigenvalues_bi(1)',eigenvalues_bis(1)
! print*,'eigenvalues ',eigenvalues(1)
! do k = 1, Ndet_generators
! print*,'coef,coef_dres = ', eigenvectors(k,1), eigenvectors_bis(k,1)
! enddo
! pause
! accu = 0.d0
! do k = 1, Ndet_generators
! do j = 1, Ndet_generators
! accu += eigenvectors(k,1) * eigenvectors(j,1) * (H_matrix_tmp(k,j) + delta_ij_generators_(k,j))
! enddo
! enddo
! print*,'accu,eigv = ',accu,eigenvalues(1)
! pause
enddo enddo
end end

59
plugins/FOBOCI/fobo_scf.irp.f Normal file
View File

@ -0,0 +1,59 @@
program foboscf
implicit none
call run_prepare
no_oa_or_av_opt = .True.
touch no_oa_or_av_opt
call routine_fobo_scf
call save_mos
end
subroutine run_prepare
implicit none
no_oa_or_av_opt = .False.
touch no_oa_or_av_opt
call damping_SCF
call diag_inactive_virt_and_update_mos
end
subroutine routine_fobo_scf
implicit none
integer :: i,j
print*,''
print*,''
character*(64) :: label
label = "Natural"
do i = 1, 5
print*,'*******************************************************************************'
print*,'*******************************************************************************'
print*,'FOBO-SCF Iteration ',i
print*,'*******************************************************************************'
print*,'*******************************************************************************'
if(speed_up_convergence_foboscf)then
if(i==3)then
threshold_lmct = max(threshold_lmct,0.001)
threshold_mlct = max(threshold_mlct,0.05)
soft_touch threshold_lmct threshold_mlct
endif
if(i==4)then
threshold_lmct = max(threshold_lmct,0.005)
threshold_mlct = max(threshold_mlct,0.07)
soft_touch threshold_lmct threshold_mlct
endif
if(i==5)then
threshold_lmct = max(threshold_lmct,0.01)
threshold_mlct = max(threshold_mlct,0.1)
soft_touch threshold_lmct threshold_mlct
endif
endif
call FOBOCI_lmct_mlct_old_thr
call save_osoci_natural_mos
call damping_SCF
call diag_inactive_virt_and_update_mos
call clear_mo_map
call provide_properties
enddo
end

124
plugins/FOBOCI/foboci_lmct_mlct_threshold_old.irp.f
View File

@ -9,12 +9,9 @@ subroutine FOBOCI_lmct_mlct_old_thr
double precision :: norm_tmp(N_states),norm_total(N_states) double precision :: norm_tmp(N_states),norm_total(N_states)
logical :: test_sym logical :: test_sym
double precision :: thr,hij double precision :: thr,hij
double precision :: threshold
double precision, allocatable :: dressing_matrix(:,:) double precision, allocatable :: dressing_matrix(:,:)
logical :: verbose,is_ok logical :: verbose,is_ok
verbose = .True. verbose = .True.
threshold = threshold_singles
print*,'threshold = ',threshold
thr = 1.d-12 thr = 1.d-12
allocate(unpaired_bitmask(N_int,2)) allocate(unpaired_bitmask(N_int,2))
allocate (occ(N_int*bit_kind_size,2)) allocate (occ(N_int*bit_kind_size,2))
@ -36,7 +33,14 @@ subroutine FOBOCI_lmct_mlct_old_thr
print*,'' print*,''
print*,'' print*,''
print*,'DOING FIRST LMCT !!' print*,'DOING FIRST LMCT !!'
print*,'Threshold_lmct = ',threshold_lmct
integer(bit_kind) , allocatable :: zero_bitmask(:,:)
integer(bit_kind) , allocatable :: psi_singles(:,:,:)
logical :: lmct
double precision, allocatable :: psi_singles_coef(:,:)
allocate( zero_bitmask(N_int,2) )
do i = 1, n_inact_orb do i = 1, n_inact_orb
lmct = .True.
integer :: i_hole_osoci integer :: i_hole_osoci
i_hole_osoci = list_inact(i) i_hole_osoci = list_inact(i)
print*,'--------------------------' print*,'--------------------------'
@ -51,27 +55,91 @@ subroutine FOBOCI_lmct_mlct_old_thr
print*,'Passed set generators' print*,'Passed set generators'
call set_bitmask_particl_as_input(reunion_of_bitmask) call set_bitmask_particl_as_input(reunion_of_bitmask)
call set_bitmask_hole_as_input(reunion_of_bitmask) call set_bitmask_hole_as_input(reunion_of_bitmask)
call is_a_good_candidate(threshold,is_ok,verbose) call is_a_good_candidate(threshold_lmct,is_ok,verbose)
print*,'is_ok = ',is_ok print*,'is_ok = ',is_ok
if(.not.is_ok)cycle if(.not.is_ok)cycle
! so all the mono excitation on the new generators
allocate(dressing_matrix(N_det_generators,N_det_generators)) allocate(dressing_matrix(N_det_generators,N_det_generators))
dressing_matrix = 0.d0
if(.not.do_it_perturbative)then if(.not.do_it_perturbative)then
! call all_single
dressing_matrix = 0.d0
do k = 1, N_det_generators do k = 1, N_det_generators
do l = 1, N_det_generators do l = 1, N_det_generators
call i_h_j(psi_det_generators(1,1,k),psi_det_generators(1,1,l),N_int,hkl) call i_h_j(psi_det_generators(1,1,k),psi_det_generators(1,1,l),N_int,hkl)
dressing_matrix(k,l) = hkl dressing_matrix(k,l) = hkl
enddo enddo
enddo enddo
double precision :: hkl hkl = dressing_matrix(1,1)
! call all_single_split(psi_det_generators,psi_coef_generators,N_det_generators,dressing_matrix) do k = 1, N_det_generators
! call diag_dressed_matrix_and_set_to_psi_det(psi_det_generators,N_det_generators,dressing_matrix) dressing_matrix(k,k) = dressing_matrix(k,k) - hkl
call debug_det(reunion_of_bitmask,N_int) enddo
print*,'Naked matrix'
do k = 1, N_det_generators
write(*,'(100(F12.5,X))')dressing_matrix(k,:)
enddo
! Do all the single excitations on top of the CAS and 1h determinants
call set_bitmask_particl_as_input(reunion_of_bitmask)
call set_bitmask_hole_as_input(reunion_of_bitmask)
call all_single call all_single
! if(dressing_2h2p)then
! call diag_dressed_2h2p_hamiltonian_and_update_psi_det(i_hole_osoci,lmct)
! endif
! ! Change the mask of the holes and particles to perform all the
! ! double excitations that starts from the active space in order
! ! to introduce the Coulomb hole in the active space
! ! These are the 1h2p excitations that have the i_hole_osoci hole in common
! ! and the 2p if there is more than one electron in the active space
! do k = 1, N_int
! zero_bitmask(k,1) = 0_bit_kind
! zero_bitmask(k,2) = 0_bit_kind
! enddo
! ! hole is possible only in the orbital i_hole_osoci
! call set_bit_to_integer(i_hole_osoci,zero_bitmask(1,1),N_int)
! call set_bit_to_integer(i_hole_osoci,zero_bitmask(1,2),N_int)
! ! and in the active space
! do k = 1, n_act_orb
! call set_bit_to_integer(list_act(k),zero_bitmask(1,1),N_int)
! call set_bit_to_integer(list_act(k),zero_bitmask(1,2),N_int)
! enddo
! call set_bitmask_hole_as_input(zero_bitmask)
! call set_bitmask_particl_as_input(reunion_of_bitmask)
! call all_1h2p
! call diagonalize_CI_SC2
! call provide_matrix_dressing(dressing_matrix,n_det_generators,psi_det_generators)
! ! Change the mask of the holes and particles to perform all the
! ! double excitations that from the orbital i_hole_osoci
! do k = 1, N_int
! zero_bitmask(k,1) = 0_bit_kind
! zero_bitmask(k,2) = 0_bit_kind
! enddo
! ! hole is possible only in the orbital i_hole_osoci
! call set_bit_to_integer(i_hole_osoci,zero_bitmask(1,1),N_int)
! call set_bit_to_integer(i_hole_osoci,zero_bitmask(1,2),N_int)
! call set_bitmask_hole_as_input(zero_bitmask)
! call set_bitmask_particl_as_input(reunion_of_bitmask)
! call set_psi_det_to_generators
! call all_2h2p
! call diagonalize_CI_SC2
double precision :: hkl
call provide_matrix_dressing(dressing_matrix,n_det_generators,psi_det_generators)
hkl = dressing_matrix(1,1)
do k = 1, N_det_generators
dressing_matrix(k,k) = dressing_matrix(k,k) - hkl
enddo
print*,'Dressed matrix'
do k = 1, N_det_generators
write(*,'(100(F12.5,X))')dressing_matrix(k,:)
enddo
! call diag_dressed_matrix_and_set_to_psi_det(psi_det_generators,N_det_generators,dressing_matrix)
endif endif
call set_intermediate_normalization_lmct_old(norm_tmp,i_hole_osoci) call set_intermediate_normalization_lmct_old(norm_tmp,i_hole_osoci)
do k = 1, N_states do k = 1, N_states
print*,'norm_tmp = ',norm_tmp(k) print*,'norm_tmp = ',norm_tmp(k)
norm_total(k) += norm_tmp(k) norm_total(k) += norm_tmp(k)
@ -83,9 +151,12 @@ subroutine FOBOCI_lmct_mlct_old_thr
if(.True.)then if(.True.)then
print*,'' print*,''
print*,'DOING THEN THE MLCT !!' print*,'DOING THEN THE MLCT !!'
print*,'Threshold_mlct = ',threshold_mlct
lmct = .False.
do i = 1, n_virt_orb do i = 1, n_virt_orb
integer :: i_particl_osoci integer :: i_particl_osoci
i_particl_osoci = list_virt(i) i_particl_osoci = list_virt(i)
print*,'--------------------------' print*,'--------------------------'
! First set the current generators to the one of restart ! First set the current generators to the one of restart
call set_generators_to_generators_restart call set_generators_to_generators_restart
@ -107,7 +178,7 @@ subroutine FOBOCI_lmct_mlct_old_thr
call set_bitmask_particl_as_input(reunion_of_bitmask) call set_bitmask_particl_as_input(reunion_of_bitmask)
call set_bitmask_hole_as_input(reunion_of_bitmask) call set_bitmask_hole_as_input(reunion_of_bitmask)
!! ! so all the mono excitation on the new generators !! ! so all the mono excitation on the new generators
call is_a_good_candidate(threshold,is_ok,verbose) call is_a_good_candidate(threshold_mlct,is_ok,verbose)
print*,'is_ok = ',is_ok print*,'is_ok = ',is_ok
if(.not.is_ok)cycle if(.not.is_ok)cycle
allocate(dressing_matrix(N_det_generators,N_det_generators)) allocate(dressing_matrix(N_det_generators,N_det_generators))
@ -122,6 +193,9 @@ subroutine FOBOCI_lmct_mlct_old_thr
! call all_single_split(psi_det_generators,psi_coef_generators,N_det_generators,dressing_matrix) ! call all_single_split(psi_det_generators,psi_coef_generators,N_det_generators,dressing_matrix)
! call diag_dressed_matrix_and_set_to_psi_det(psi_det_generators,N_det_generators,dressing_matrix) ! call diag_dressed_matrix_and_set_to_psi_det(psi_det_generators,N_det_generators,dressing_matrix)
call all_single call all_single
! if(dressing_2h2p)then
! call diag_dressed_2h2p_hamiltonian_and_update_psi_det(i_particl_osoci,lmct)
! endif
endif endif
call set_intermediate_normalization_mlct_old(norm_tmp,i_particl_osoci) call set_intermediate_normalization_mlct_old(norm_tmp,i_particl_osoci)
do k = 1, N_states do k = 1, N_states
@ -132,24 +206,6 @@ subroutine FOBOCI_lmct_mlct_old_thr
deallocate(dressing_matrix) deallocate(dressing_matrix)
enddo enddo
endif endif
if(.False.)then
print*,'LAST loop for all the 1h-1p'
print*,'--------------------------'
! First set the current generators to the one of restart
call set_generators_to_generators_restart
call set_psi_det_to_generators
call initialize_bitmask_to_restart_ones
! Impose that only the hole i_hole_osoci can be done
call set_bitmask_particl_as_input(inact_virt_bitmask)
call set_bitmask_hole_as_input(inact_virt_bitmask)
! call set_bitmask_particl_as_input(reunion_of_bitmask)
! call set_bitmask_hole_as_input(reunion_of_bitmask)
call all_single
call set_intermediate_normalization_1h1p(norm_tmp)
norm_total += norm_tmp
call update_density_matrix_osoci
endif
print*,'norm_total = ',norm_total print*,'norm_total = ',norm_total
norm_total = norm_generators_restart norm_total = norm_generators_restart
@ -174,10 +230,8 @@ subroutine FOBOCI_mlct_old
double precision :: norm_tmp,norm_total double precision :: norm_tmp,norm_total
logical :: test_sym logical :: test_sym
double precision :: thr double precision :: thr
double precision :: threshold
logical :: verbose,is_ok logical :: verbose,is_ok
verbose = .False. verbose = .False.
threshold = 1.d-2
thr = 1.d-12 thr = 1.d-12
allocate(unpaired_bitmask(N_int,2)) allocate(unpaired_bitmask(N_int,2))
allocate (occ(N_int*bit_kind_size,2)) allocate (occ(N_int*bit_kind_size,2))
@ -216,7 +270,7 @@ subroutine FOBOCI_mlct_old
call set_bitmask_particl_as_input(reunion_of_bitmask) call set_bitmask_particl_as_input(reunion_of_bitmask)
call set_bitmask_hole_as_input(reunion_of_bitmask) call set_bitmask_hole_as_input(reunion_of_bitmask)
! ! so all the mono excitation on the new generators ! ! so all the mono excitation on the new generators
call is_a_good_candidate(threshold,is_ok,verbose) call is_a_good_candidate(threshold_mlct,is_ok,verbose)
print*,'is_ok = ',is_ok print*,'is_ok = ',is_ok
is_ok =.True. is_ok =.True.
if(.not.is_ok)cycle if(.not.is_ok)cycle
@ -250,10 +304,8 @@ subroutine FOBOCI_lmct_old
double precision :: norm_tmp,norm_total double precision :: norm_tmp,norm_total
logical :: test_sym logical :: test_sym
double precision :: thr double precision :: thr
double precision :: threshold
logical :: verbose,is_ok logical :: verbose,is_ok
verbose = .False. verbose = .False.
threshold = 1.d-2
thr = 1.d-12 thr = 1.d-12
allocate(unpaired_bitmask(N_int,2)) allocate(unpaired_bitmask(N_int,2))
allocate (occ(N_int*bit_kind_size,2)) allocate (occ(N_int*bit_kind_size,2))
@ -290,7 +342,7 @@ subroutine FOBOCI_lmct_old
call set_generators_to_psi_det call set_generators_to_psi_det
call set_bitmask_particl_as_input(reunion_of_bitmask) call set_bitmask_particl_as_input(reunion_of_bitmask)
call set_bitmask_hole_as_input(reunion_of_bitmask) call set_bitmask_hole_as_input(reunion_of_bitmask)
call is_a_good_candidate(threshold,is_ok,verbose) call is_a_good_candidate(threshold_lmct,is_ok,verbose)
print*,'is_ok = ',is_ok print*,'is_ok = ',is_ok
if(.not.is_ok)cycle if(.not.is_ok)cycle
! ! so all the mono excitation on the new generators ! ! so all the mono excitation on the new generators

18
plugins/FOBOCI/foboci_reunion.irp.f Normal file
View File

@ -0,0 +1,18 @@
program osoci_program
implicit none
do_it_perturbative = .True.
touch do_it_perturbative
call FOBOCI_lmct_mlct_old_thr
call provide_all_the_rest
end
subroutine provide_all_the_rest
implicit none
integer :: i
call update_one_body_dm_mo
call set_lmct_mlct_to_psi_det
call diagonalize_CI
call save_wavefunction
end

158
plugins/FOBOCI/generators_restart_save.irp.f
View File

@ -1,126 +1,74 @@
use bitmasks
use bitmasks
BEGIN_PROVIDER [ integer, N_det_generators_restart ] BEGIN_PROVIDER [ integer, N_det_generators_restart ]
implicit none implicit none
BEGIN_DOC BEGIN_DOC
! Number of determinants in the wave function ! Read the wave function
END_DOC END_DOC
logical :: exists integer :: i
character*64 :: label
integer, save :: ifirst = 0 integer, save :: ifirst = 0
!if(ifirst == 0)then double precision :: norm
PROVIDE ezfio_filename if(ifirst == 0)then
call ezfio_has_determinants_n_det(exists) call ezfio_get_determinants_n_det(N_det_generators_restart)
print*,'exists = ',exists
if(.not.exists)then
print*,'The OSOCI needs a restart WF'
print*,'There are none in the EZFIO file ...'
print*,'Stopping ...'
stop
endif
print*,'passed N_det_generators_restart'
call ezfio_get_determinants_n_det(N_det_generators_restart)
ASSERT (N_det_generators_restart > 0)
ifirst = 1 ifirst = 1
!endif else
print*,'PB in generators_restart restart !!!'
endif
call write_int(output_determinants,N_det_generators_restart,'Number of generators_restart')
END_PROVIDER END_PROVIDER
BEGIN_PROVIDER [ integer(bit_kind), psi_det_generators_restart, (N_int,2,psi_det_size) ] BEGIN_PROVIDER [ integer(bit_kind), psi_det_generators_restart, (N_int,2,N_det_generators_restart) ]
&BEGIN_PROVIDER [ integer(bit_kind), ref_generators_restart, (N_int,2) ] &BEGIN_PROVIDER [ integer(bit_kind), ref_generators_restart, (N_int,2) ]
&BEGIN_PROVIDER [ double precision, psi_coef_generators_restart, (N_det_generators_restart,N_states) ]
implicit none implicit none
BEGIN_DOC BEGIN_DOC
! The wave function determinants. Initialized with Hartree-Fock if the EZFIO file ! read wf
! is empty !
END_DOC END_DOC
integer :: i integer :: i, k
logical :: exists
character*64 :: label
integer, save :: ifirst = 0 integer, save :: ifirst = 0
!if(ifirst == 0)then double precision, allocatable :: psi_coef_read(:,:)
provide N_det_generators_restart if(ifirst == 0)then
if(.True.)then call read_dets(psi_det_generators_restart,N_int,N_det_generators_restart)
call ezfio_has_determinants_N_int(exists) do k = 1, N_int
if (exists) then ref_generators_restart(k,1) = psi_det_generators_restart(k,1,1)
call ezfio_has_determinants_bit_kind(exists) ref_generators_restart(k,2) = psi_det_generators_restart(k,2,1)
if (exists) then enddo
call ezfio_has_determinants_N_det(exists) allocate (psi_coef_read(N_det_generators_restart,N_states))
if (exists) then call ezfio_get_determinants_psi_coef(psi_coef_read)
call ezfio_has_determinants_N_states(exists) do k = 1, N_states
if (exists) then do i = 1, N_det_generators_restart
call ezfio_has_determinants_psi_det(exists) psi_coef_generators_restart(i,k) = psi_coef_read(i,k)
endif enddo
endif enddo
endif
endif
if(.not.exists)then
print*,'The OSOCI needs a restart WF'
print*,'There are none in the EZFIO file ...'
print*,'Stopping ...'
stop
endif
print*,'passed psi_det_generators_restart'
call read_dets(psi_det_generators_restart,N_int,N_det_generators_restart)
do i = 1, N_int
ref_generators_restart(i,1) = psi_det_generators_restart(i,1,1)
ref_generators_restart(i,2) = psi_det_generators_restart(i,2,1)
enddo
endif
ifirst = 1 ifirst = 1
!endif deallocate(psi_coef_read)
else
print*,'PB in generators_restart restart !!!'
endif
END_PROVIDER END_PROVIDER
BEGIN_PROVIDER [ integer, size_select_max]
implicit none
BEGIN_PROVIDER [ double precision, psi_coef_generators_restart, (psi_det_size,N_states_diag) ] BEGIN_DOC
implicit none ! Size of the select_max array
BEGIN_DOC END_DOC
! The wave function coefficients. Initialized with Hartree-Fock if the EZFIO file size_select_max = 10000
! is empty
END_DOC
integer :: i,k, N_int2
logical :: exists
double precision, allocatable :: psi_coef_read(:,:)
character*(64) :: label
integer, save :: ifirst = 0
!if(ifirst == 0)then
psi_coef_generators_restart = 0.d0
do i=1,N_states_diag
psi_coef_generators_restart(i,i) = 1.d0
enddo
call ezfio_has_determinants_psi_coef(exists)
if(.not.exists)then
print*,'The OSOCI needs a restart WF'
print*,'There are none in the EZFIO file ...'
print*,'Stopping ...'
stop
endif
print*,'passed psi_coef_generators_restart'
if (exists) then
allocate (psi_coef_read(N_det_generators_restart,N_states))
call ezfio_get_determinants_psi_coef(psi_coef_read)
do k=1,N_states
do i=1,N_det_generators_restart
psi_coef_generators_restart(i,k) = psi_coef_read(i,k)
enddo
enddo
deallocate(psi_coef_read)
endif
ifirst = 1
!endif
END_PROVIDER END_PROVIDER
BEGIN_PROVIDER [ double precision, select_max, (size_select_max) ]
implicit none
BEGIN_DOC
! Memo to skip useless selectors
END_DOC
select_max = huge(1.d0)
END_PROVIDER
BEGIN_PROVIDER [ integer, N_det_generators ]
&BEGIN_PROVIDER [ integer(bit_kind), psi_det_generators, (N_int,2,10000) ]
&BEGIN_PROVIDER [ double precision, psi_coef_generators, (10000,N_states) ]
END_PROVIDER

83
plugins/FOBOCI/hcc_1h1p.irp.f Normal file
View File

@ -0,0 +1,83 @@
program test_sc2
implicit none
read_wf = .True.
touch read_wf
call routine
end
subroutine routine
implicit none
double precision, allocatable :: energies(:),diag_H_elements(:)
double precision, allocatable :: H_matrix(:,:)
allocate(energies(N_states),diag_H_elements(N_det))
call diagonalize_CI
call test_hcc
call test_mulliken
! call SC2_1h1p(psi_det,psi_coef,energies, &
! diag_H_elements,size(psi_coef,1),N_det,N_states_diag,N_int,threshold_convergence_SC2)
allocate(H_matrix(N_det,N_det))
call SC2_1h1p_full(psi_det,psi_coef,energies, &
H_matrix,size(psi_coef,1),N_det,N_states_diag,N_int,threshold_convergence_SC2)
deallocate(H_matrix)
integer :: i,j
double precision :: accu,coef_hf
! coef_hf = 1.d0/psi_coef(1,1)
! do i = 1, N_det
! psi_coef(i,1) *= coef_hf
! enddo
touch psi_coef
call pouet
end
subroutine pouet
implicit none
double precision :: accu,coef_hf
! provide one_body_dm_mo_alpha one_body_dm_mo_beta
! call density_matrix_1h1p(psi_det,psi_coef,one_body_dm_mo_alpha,one_body_dm_mo_beta,accu,size(psi_coef,1),N_det,N_states_diag,N_int)
! touch one_body_dm_mo_alpha one_body_dm_mo_beta
call test_hcc
call test_mulliken
! call save_wavefunction
end
subroutine test_hcc
implicit none
double precision :: accu
integer :: i,j
print*,'Z AU GAUSS MHZ cm^-1'
do i = 1, nucl_num
write(*,'(I2,X,F3.1,X,4(F16.6,X))')i,nucl_charge(i),spin_density_at_nucleous(i),iso_hcc_gauss(i),iso_hcc_mhz(i),iso_hcc_cm_1(i)
enddo
end
subroutine test_mulliken
double precision :: accu
integer :: i
integer :: j
accu= 0.d0
do i = 1, nucl_num
print*,i,nucl_charge(i),mulliken_spin_densities(i)
accu += mulliken_spin_densities(i)
enddo
print*,'Sum of Mulliken SD = ',accu
!print*,'AO SPIN POPULATIONS'
accu = 0.d0
!do i = 1, ao_num
! accu += spin_gross_orbital_product(i)
! write(*,'(X,I3,X,A4,X,I2,X,A4,X,F10.7)')i,trim(element_name(int(nucl_charge(ao_nucl(i))))),ao_nucl(i),trim(l_to_charater(ao_l(i))),spin_gross_orbital_product(i)
!enddo
!print*,'sum = ',accu
!accu = 0.d0
!print*,'Angular momentum analysis'
!do i = 0, ao_l_max
! accu += spin_population_angular_momentum(i)
! print*,' ',trim(l_to_charater(i)),spin_population_angular_momentum(i)
!print*,'sum = ',accu
!enddo
end

1
plugins/FOBOCI/modify_generators.irp.f
View File

@ -6,6 +6,7 @@ subroutine set_generators_to_psi_det
END_DOC END_DOC
N_det_generators = N_det N_det_generators = N_det
integer :: i,k integer :: i,k
print*,'N_det = ',N_det
do i=1,N_det_generators do i=1,N_det_generators
do k=1,N_int do k=1,N_int
psi_det_generators(k,1,i) = psi_det(k,1,i) psi_det_generators(k,1,i) = psi_det(k,1,i)

339
plugins/FOBOCI/new_approach.irp.f
View File

@ -24,6 +24,7 @@ subroutine new_approach
double precision, allocatable :: dressing_matrix_1h1p(:,:) double precision, allocatable :: dressing_matrix_1h1p(:,:)
double precision, allocatable :: dressing_matrix_2h1p(:,:) double precision, allocatable :: dressing_matrix_2h1p(:,:)
double precision, allocatable :: dressing_matrix_1h2p(:,:) double precision, allocatable :: dressing_matrix_1h2p(:,:)
double precision, allocatable :: dressing_matrix_extra_1h_or_1p(:,:)
double precision, allocatable :: H_matrix_tmp(:,:) double precision, allocatable :: H_matrix_tmp(:,:)
logical :: verbose,is_ok logical :: verbose,is_ok
@ -45,7 +46,7 @@ subroutine new_approach
verbose = .True. verbose = .True.
threshold = threshold_singles threshold = threshold_lmct
print*,'threshold = ',threshold print*,'threshold = ',threshold
thr = 1.d-12 thr = 1.d-12
print*,'' print*,''
@ -81,12 +82,14 @@ subroutine new_approach
! so all the mono excitation on the new generators ! so all the mono excitation on the new generators
allocate(dressing_matrix_1h1p(N_det_generators,N_det_generators)) allocate(dressing_matrix_1h1p(N_det_generators,N_det_generators))
allocate(dressing_matrix_2h1p(N_det_generators,N_det_generators)) allocate(dressing_matrix_2h1p(N_det_generators,N_det_generators))
allocate(dressing_matrix_extra_1h_or_1p(N_det_generators,N_det_generators))
dressing_matrix_1h1p = 0.d0 dressing_matrix_1h1p = 0.d0
dressing_matrix_2h1p = 0.d0 dressing_matrix_2h1p = 0.d0
dressing_matrix_extra_1h_or_1p = 0.d0
if(.not.do_it_perturbative)then if(.not.do_it_perturbative)then
n_good_hole +=1 n_good_hole +=1
! call all_single_split_for_1h(dressing_matrix_1h1p,dressing_matrix_2h1p) ! call all_single_split_for_1h(dressing_matrix_1h1p,dressing_matrix_2h1p)
call all_single_for_1h(dressing_matrix_1h1p,dressing_matrix_2h1p) call all_single_for_1h(i_hole_foboci,dressing_matrix_1h1p,dressing_matrix_2h1p,dressing_matrix_extra_1h_or_1p)
allocate(H_matrix_tmp(N_det_generators,N_det_generators)) allocate(H_matrix_tmp(N_det_generators,N_det_generators))
do j = 1,N_det_generators do j = 1,N_det_generators
do k = 1, N_det_generators do k = 1, N_det_generators
@ -96,7 +99,7 @@ subroutine new_approach
enddo enddo
do j = 1, N_det_generators do j = 1, N_det_generators
do k = 1, N_det_generators do k = 1, N_det_generators
H_matrix_tmp(j,k) += dressing_matrix_1h1p(j,k) + dressing_matrix_2h1p(j,k) H_matrix_tmp(j,k) += dressing_matrix_1h1p(j,k) + dressing_matrix_2h1p(j,k) + dressing_matrix_extra_1h_or_1p(j,k)
enddo enddo
enddo enddo
hjk = H_matrix_tmp(1,1) hjk = H_matrix_tmp(1,1)
@ -130,6 +133,7 @@ subroutine new_approach
endif endif
deallocate(dressing_matrix_1h1p) deallocate(dressing_matrix_1h1p)
deallocate(dressing_matrix_2h1p) deallocate(dressing_matrix_2h1p)
deallocate(dressing_matrix_extra_1h_or_1p)
enddo enddo
print*,'' print*,''
@ -155,12 +159,14 @@ subroutine new_approach
! so all the mono excitation on the new generators ! so all the mono excitation on the new generators
allocate(dressing_matrix_1h1p(N_det_generators,N_det_generators)) allocate(dressing_matrix_1h1p(N_det_generators,N_det_generators))
allocate(dressing_matrix_1h2p(N_det_generators,N_det_generators)) allocate(dressing_matrix_1h2p(N_det_generators,N_det_generators))
allocate(dressing_matrix_extra_1h_or_1p(N_det_generators,N_det_generators))
dressing_matrix_1h1p = 0.d0 dressing_matrix_1h1p = 0.d0
dressing_matrix_1h2p = 0.d0 dressing_matrix_1h2p = 0.d0
dressing_matrix_extra_1h_or_1p = 0.d0
if(.not.do_it_perturbative)then if(.not.do_it_perturbative)then
n_good_hole +=1 n_good_hole +=1
! call all_single_split_for_1p(dressing_matrix_1h1p,dressing_matrix_1h2p) ! call all_single_split_for_1p(dressing_matrix_1h1p,dressing_matrix_1h2p)
call all_single_for_1p(dressing_matrix_1h1p,dressing_matrix_1h2p) call all_single_for_1p(i_particl_osoci,dressing_matrix_1h1p,dressing_matrix_1h2p,dressing_matrix_extra_1h_or_1p)
allocate(H_matrix_tmp(N_det_generators,N_det_generators)) allocate(H_matrix_tmp(N_det_generators,N_det_generators))
do j = 1,N_det_generators do j = 1,N_det_generators
do k = 1, N_det_generators do k = 1, N_det_generators
@ -170,7 +176,7 @@ subroutine new_approach
enddo enddo
do j = 1, N_det_generators do j = 1, N_det_generators
do k = 1, N_det_generators do k = 1, N_det_generators
H_matrix_tmp(j,k) += dressing_matrix_1h1p(j,k) + dressing_matrix_1h2p(j,k) H_matrix_tmp(j,k) += dressing_matrix_1h1p(j,k) + dressing_matrix_1h2p(j,k) + dressing_matrix_extra_1h_or_1p(j,k)
enddo enddo
enddo enddo
hjk = H_matrix_tmp(1,1) hjk = H_matrix_tmp(1,1)
@ -205,7 +211,10 @@ subroutine new_approach
endif endif
deallocate(dressing_matrix_1h1p) deallocate(dressing_matrix_1h1p)
deallocate(dressing_matrix_1h2p) deallocate(dressing_matrix_1h2p)
deallocate(dressing_matrix_extra_1h_or_1p)
enddo enddo
double precision, allocatable :: H_matrix_total(:,:) double precision, allocatable :: H_matrix_total(:,:)
integer :: n_det_total integer :: n_det_total
n_det_total = N_det_generators_restart + n_good_det n_det_total = N_det_generators_restart + n_good_det
@ -221,7 +230,7 @@ subroutine new_approach
!!! Adding the averaged dressing coming from the 1h1p that are redundant for each of the "n_good_hole" 1h !!! Adding the averaged dressing coming from the 1h1p that are redundant for each of the "n_good_hole" 1h
H_matrix_total(i,j) += dressing_matrix_restart_1h1p(i,j)/dble(n_good_hole+n_good_particl) H_matrix_total(i,j) += dressing_matrix_restart_1h1p(i,j)/dble(n_good_hole+n_good_particl)
!!! Adding the dressing coming from the 2h1p that are not redundant for the any of CI calculations !!! Adding the dressing coming from the 2h1p that are not redundant for the any of CI calculations
H_matrix_total(i,j) += dressing_matrix_restart_2h1p(i,j) H_matrix_total(i,j) += dressing_matrix_restart_2h1p(i,j) + dressing_matrix_restart_1h2p(i,j)
enddo enddo
enddo enddo
do i = 1, n_good_det do i = 1, n_good_det
@ -244,25 +253,79 @@ subroutine new_approach
H_matrix_total(n_det_generators_restart+j,n_det_generators_restart+i) = hij H_matrix_total(n_det_generators_restart+j,n_det_generators_restart+i) = hij
enddo enddo
enddo enddo
print*,'H matrix to diagonalize'
double precision :: href ! Adding the correlation energy
href = H_matrix_total(1,1) logical :: orb_taken_good_det(mo_tot_num)
do i = 1, n_det_total double precision :: phase
H_matrix_total(i,i) -= href integer :: n_h,n_p,number_of_holes,number_of_particles
integer :: exc(0:2,2,2)
integer :: degree
integer :: h1,h2,p1,p2,s1,s2
logical, allocatable :: one_hole_or_one_p(:)
integer, allocatable :: holes_or_particle(:)
allocate(one_hole_or_one_p(n_good_det), holes_or_particle(n_good_det))
orb_taken_good_det = .False.
do i = 1, n_good_det
n_h = number_of_holes(psi_good_det(1,1,i))
n_p = number_of_particles(psi_good_det(1,1,i))
call get_excitation(ref_bitmask,psi_good_det(1,1,i),exc,degree,phase,N_int)
call decode_exc(exc,degree,h1,p1,h2,p2,s1,s2)
if(n_h == 0 .and. n_p == 1)then
orb_taken_good_det(h1) = .True.
one_hole_or_one_p(i) = .True.
holes_or_particle(i) = h1
endif
if(n_h == 1 .and. n_p == 0)then
orb_taken_good_det(p1) = .True.
one_hole_or_one_p(i) = .False.
holes_or_particle(i) = p1
endif
enddo enddo
do i = 1, n_det_total
write(*,'(100(X,F16.8))')H_matrix_total(i,:) do i = 1, N_det_generators_restart
enddo ! Add the 2h2p, 2h1p and 1h2p correlation energy
double precision, allocatable :: eigvalues(:),eigvectors(:,:) H_matrix_total(i,i) += total_corr_e_2h2p + total_corr_e_2h1p + total_corr_e_1h2p + total_corr_e_1h1p_spin_flip
allocate(eigvalues(n_det_total),eigvectors(n_det_total,n_det_total)) ! Substract the 2h1p part that have already been taken into account
call lapack_diag(eigvalues,eigvectors,H_matrix_total,n_det_total,n_det_total) do j = 1, n_inact_orb
print*,'e_dressed = ',eigvalues(1) + nuclear_repulsion + href iorb = list_inact(j)
do i = 1, n_det_total if(.not.orb_taken_good_det(iorb))cycle
print*,'coef = ',eigvectors(i,1) H_matrix_total(i,i) -= corr_energy_2h1p_per_orb_ab(iorb) - corr_energy_2h1p_per_orb_bb(iorb) - corr_energy_1h1p_spin_flip_per_orb(iorb)
enddo enddo
integer(bit_kind), allocatable :: psi_det_final(:,:,:) ! Substract the 1h2p part that have already been taken into account
double precision, allocatable :: psi_coef_final(:,:) do j = 1, n_virt_orb
double precision :: norm iorb = list_virt(j)
if(.not.orb_taken_good_det(iorb))cycle
H_matrix_total(i,i) -= corr_energy_1h2p_per_orb_ab(iorb) - corr_energy_1h2p_per_orb_aa(iorb)
enddo
enddo
do i = 1, N_good_det
! Repeat the 2h2p correlation energy
H_matrix_total(N_det_generators_restart+i,N_det_generators_restart+i) += total_corr_e_2h2p
! Substract the part that can not be repeated
! If it is a 1h
if(one_hole_or_one_p(i))then
! 2h2p
H_matrix_total(N_det_generators_restart+i,N_det_generators_restart+i) += -corr_energy_2h2p_per_orb_ab(holes_or_particle(i)) &
-corr_energy_2h2p_per_orb_bb(holes_or_particle(i))
! You can repeat a certain part of the 1h2p correlation energy
! that is everything except the part that involves the hole of the 1h
H_matrix_total(N_det_generators_restart+i,N_det_generators_restart+i) += total_corr_e_1h2p
H_matrix_total(N_det_generators_restart+i,N_det_generators_restart+i) += -corr_energy_1h2p_per_orb_ab(holes_or_particle(i)) &
-corr_energy_1h2p_per_orb_bb(holes_or_particle(i))
else
! 2h2p
H_matrix_total(N_det_generators_restart+i,N_det_generators_restart+i) += -corr_energy_2h2p_per_orb_ab(holes_or_particle(i)) &
-corr_energy_2h2p_per_orb_aa(holes_or_particle(i))
! You can repeat a certain part of the 2h1p correlation energy
! that is everything except the part that involves the hole of the 1p
! 2h1p
H_matrix_total(N_det_generators_restart+i,N_det_generators_restart+i) += -corr_energy_2h1p_per_orb_ab(holes_or_particle(i)) &
-corr_energy_2h1p_per_orb_aa(holes_or_particle(i))
endif
enddo
allocate(psi_coef_final(n_det_total, N_states)) allocate(psi_coef_final(n_det_total, N_states))
allocate(psi_det_final(N_int,2,n_det_total)) allocate(psi_det_final(N_int,2,n_det_total))
do i = 1, N_det_generators_restart do i = 1, N_det_generators_restart
@ -277,22 +340,222 @@ subroutine new_approach
psi_det_final(j,2,n_det_generators_restart+i) = psi_good_det(j,2,i) psi_det_final(j,2,n_det_generators_restart+i) = psi_good_det(j,2,i)
enddo enddo
enddo enddo
norm = 0.d0
double precision :: href
double precision, allocatable :: eigvalues(:),eigvectors(:,:)
integer(bit_kind), allocatable :: psi_det_final(:,:,:)
double precision, allocatable :: psi_coef_final(:,:)
double precision :: norm
allocate(eigvalues(n_det_total),eigvectors(n_det_total,n_det_total))
call lapack_diag(eigvalues,eigvectors,H_matrix_total,n_det_total,n_det_total)
print*,''
print*,''
print*,'H_matrix_total(1,1) = ',H_matrix_total(1,1)
print*,'e_dressed = ',eigvalues(1) + nuclear_repulsion
do i = 1, n_det_total do i = 1, n_det_total
do j = 1, N_states print*,'coef = ',eigvectors(i,1),H_matrix_total(i,i) - H_matrix_total(1,1)
psi_coef_final(i,j) = eigvectors(i,j)
enddo
norm += psi_coef_final(i,1)**2
! call debug_det(psi_det_final(1, 1, i), N_int)
enddo enddo
print*,'norm = ',norm
integer(bit_kind), allocatable :: psi_det_remaining_1h_or_1p(:,:,:)
integer(bit_kind), allocatable :: key_tmp(:,:)
integer :: n_det_remaining_1h_or_1p
integer :: ispin,i_ok
allocate(key_tmp(N_int,2),psi_det_remaining_1h_or_1p(N_int,2,n_inact_orb*n_act_orb+n_virt_orb*n_act_orb))
logical :: is_already_present
logical, allocatable :: one_hole_or_one_p_bis(:)
integer, allocatable :: holes_or_particle_bis(:)
double precision,allocatable :: H_array(:)
allocate(one_hole_or_one_p_bis(n_inact_orb*n_act_orb+n_virt_orb*n_act_orb), holes_or_particle_bis(n_inact_orb*n_act_orb+n_virt_orb*n_act_orb))
allocate(H_array(n_det_total))
! Dressing with the remaining 1h determinants
print*,''
print*,''
print*,'Dressing with the remaining 1h determinants'
n_det_remaining_1h_or_1p = 0
do i = 1, n_inact_orb
iorb = list_inact(i)
if(orb_taken_good_det(iorb))cycle
do j = 1, n_act_orb
jorb = list_act(j)
ispin = 2
key_tmp = ref_bitmask
call do_mono_excitation(key_tmp,iorb,jorb,ispin,i_ok)
if(i_ok .ne.1)cycle
is_already_present = .False.
H_array = 0.d0
call i_h_j(key_tmp,key_tmp,N_int,hij)
href = ref_bitmask_energy - hij
href = 1.d0/href
do k = 1, n_det_total
call get_excitation_degree(psi_det_final(1,1,k),key_tmp,degree,N_int)
if(degree == 0)then
is_already_present = .True.
exit
endif
enddo
if(is_already_present)cycle
n_det_remaining_1h_or_1p +=1
one_hole_or_one_p_bis(n_det_remaining_1h_or_1p) = .True.
holes_or_particle_bis(n_det_remaining_1h_or_1p) = iorb
do k = 1, N_int
psi_det_remaining_1h_or_1p(k,1,n_det_remaining_1h_or_1p) = key_tmp(k,1)
psi_det_remaining_1h_or_1p(k,2,n_det_remaining_1h_or_1p) = key_tmp(k,2)
enddo
! do k = 1, n_det_total
! call i_h_j(psi_det_final(1,1,k),key_tmp,N_int,hij)
! H_array(k) = hij
! enddo
! do k = 1, n_det_total
! do l = 1, n_det_total
! H_matrix_total(k,l) += H_array(k) * H_array(l) * href
! enddo
! enddo
enddo
enddo
! Dressing with the remaining 1p determinants
print*,'n_det_remaining_1h_or_1p = ',n_det_remaining_1h_or_1p
print*,'Dressing with the remaining 1p determinants'
do i = 1, n_virt_orb
iorb = list_virt(i)
if(orb_taken_good_det(iorb))cycle
do j = 1, n_act_orb
jorb = list_act(j)
ispin = 1
key_tmp = ref_bitmask
call do_mono_excitation(key_tmp,jorb,iorb,ispin,i_ok)
if(i_ok .ne.1)cycle
is_already_present = .False.
H_array = 0.d0
call i_h_j(key_tmp,key_tmp,N_int,hij)
href = ref_bitmask_energy - hij
href = 1.d0/href
do k = 1, n_det_total
call get_excitation_degree(psi_det_final(1,1,k),key_tmp,degree,N_int)
if(degree == 0)then
is_already_present = .True.
exit
endif
enddo
if(is_already_present)cycle
n_det_remaining_1h_or_1p +=1
one_hole_or_one_p_bis(n_det_remaining_1h_or_1p) = .False.
holes_or_particle_bis(n_det_remaining_1h_or_1p) = iorb
do k = 1, N_int
psi_det_remaining_1h_or_1p(k,1,n_det_remaining_1h_or_1p) = key_tmp(k,1)
psi_det_remaining_1h_or_1p(k,2,n_det_remaining_1h_or_1p) = key_tmp(k,2)
enddo
! do k = 1, n_det_total
! call i_h_j(psi_det_final(1,1,k),key_tmp,N_int,hij)
! H_array(k) = hij
! enddo
! do k = 1, n_det_total
! do l = 1, n_det_total
! H_matrix_total(k,l) += H_array(k) * H_array(l) * href
! enddo
! enddo
enddo
enddo
print*,'n_det_remaining_1h_or_1p = ',n_det_remaining_1h_or_1p
deallocate(key_tmp,H_array)
double precision, allocatable :: eigvalues_bis(:),eigvectors_bis(:,:),H_matrix_total_bis(:,:)
integer :: n_det_final
n_det_final = n_det_total + n_det_remaining_1h_or_1p
allocate(eigvalues_bis(n_det_final),eigvectors_bis(n_det_final,n_det_final),H_matrix_total_bis(n_det_final,n_det_final))
print*,'passed the allocate, building the big matrix'
do i = 1, n_det_total
do j = 1, n_det_total
H_matrix_total_bis(i,j) = H_matrix_total(i,j)
enddo
enddo
do i = 1, n_det_remaining_1h_or_1p
do j = 1, n_det_remaining_1h_or_1p
call i_h_j(psi_det_remaining_1h_or_1p(1,1,i),psi_det_remaining_1h_or_1p(1,1,j),N_int,hij)
H_matrix_total_bis(n_det_total+i,n_det_total+j) = hij
enddo
enddo
do i = 1, n_det_total
do j = 1, n_det_remaining_1h_or_1p
call i_h_j(psi_det_final(1,1,i),psi_det_remaining_1h_or_1p(1,1,j),N_int,hij)
H_matrix_total_bis(i,n_det_total+j) = hij
H_matrix_total_bis(n_det_total+j,i) = hij
enddo
enddo
print*,'passed the matrix'
do i = 1, n_det_remaining_1h_or_1p
if(one_hole_or_one_p_bis(i))then
H_matrix_total_bis(n_det_total+i,n_det_total+i) += total_corr_e_2h2p -corr_energy_2h2p_per_orb_ab(holes_or_particle_bis(i)) &
-corr_energy_2h2p_per_orb_bb(holes_or_particle_bis(i))
H_matrix_total_bis(n_det_total+i,n_det_total+i) += total_corr_e_1h2p -corr_energy_1h2p_per_orb_ab(holes_or_particle_bis(i)) &
-corr_energy_1h2p_per_orb_bb(holes_or_particle_bis(i))
else
H_matrix_total_bis(n_det_total+i,n_det_total+i) += total_corr_e_2h2p -corr_energy_2h2p_per_orb_ab(holes_or_particle_bis(i)) &
-corr_energy_2h2p_per_orb_aa(holes_or_particle_bis(i))
H_matrix_total_bis(n_det_total+i,n_det_total+i) += total_corr_e_1h2p -corr_energy_2h1p_per_orb_ab(holes_or_particle_bis(i)) &
-corr_energy_2h1p_per_orb_aa(holes_or_particle_bis(i))
endif
enddo
do i = 2, n_det_final
do j = i+1, n_det_final
H_matrix_total_bis(i,j) = 0.d0
H_matrix_total_bis(j,i) = 0.d0
enddo
enddo
do i = 1, n_det_final
write(*,'(500(F10.5,X))')H_matrix_total_bis(i,:)
enddo
call lapack_diag(eigvalues_bis,eigvectors_bis,H_matrix_total_bis,n_det_final,n_det_final)
print*,'e_dressed = ',eigvalues_bis(1) + nuclear_repulsion
do i = 1, n_det_final
print*,'coef = ',eigvectors_bis(i,1),H_matrix_total_bis(i,i) - H_matrix_total_bis(1,1)
enddo
do j = 1, N_states
do i = 1, n_det_total
psi_coef_final(i,j) = eigvectors_bis(i,j)
norm += psi_coef_final(i,j)**2
enddo
norm = 1.d0/dsqrt(norm)
do i = 1, n_det_total
psi_coef_final(i,j) = psi_coef_final(i,j) * norm
enddo
enddo
deallocate(eigvalues_bis,eigvectors_bis,H_matrix_total_bis)
!print*,'H matrix to diagonalize'
!href = H_matrix_total(1,1)
!do i = 1, n_det_total
! H_matrix_total(i,i) -= href
!enddo
!do i = 1, n_det_total
! write(*,'(100(X,F16.8))')H_matrix_total(i,:)
!enddo
!call lapack_diag(eigvalues,eigvectors,H_matrix_total,n_det_total,n_det_total)
!print*,'H_matrix_total(1,1) = ',H_matrix_total(1,1)
!print*,'e_dressed = ',eigvalues(1) + nuclear_repulsion
!do i = 1, n_det_total
! print*,'coef = ',eigvectors(i,1),H_matrix_total(i,i) - H_matrix_total(1,1)
!enddo
!norm = 0.d0
!do i = 1, n_det_total
! do j = 1, N_states
! psi_coef_final(i,j) = eigvectors(i,j)
! enddo
! norm += psi_coef_final(i,1)**2
!enddo
!print*,'norm = ',norm
call set_psi_det_as_input_psi(n_det_total,psi_det_final,psi_coef_final) call set_psi_det_as_input_psi(n_det_total,psi_det_final,psi_coef_final)
print*,''
!do i = 1, N_det do i = 1, N_det
! call debug_det(psi_det(1,1,i),N_int) call debug_det(psi_det(1,1,i),N_int)
! print*,'coef = ',psi_coef(i,1) print*,'coef = ',psi_coef(i,1)
!enddo enddo
provide one_body_dm_mo provide one_body_dm_mo
integer :: i_core,iorb,jorb,i_inact,j_inact,i_virt,j_virt,j_core integer :: i_core,iorb,jorb,i_inact,j_inact,i_virt,j_virt,j_core
@ -360,14 +623,14 @@ subroutine new_approach
print*,'ACTIVE ORBITAL ',iorb print*,'ACTIVE ORBITAL ',iorb
do j = 1, n_inact_orb do j = 1, n_inact_orb
jorb = list_inact(j) jorb = list_inact(j)
if(dabs(one_body_dm_mo(iorb,jorb)).gt.threshold_singles)then if(dabs(one_body_dm_mo(iorb,jorb)).gt.threshold_lmct)then
print*,'INACTIVE ' print*,'INACTIVE '
print*,'DM ',iorb,jorb,dabs(one_body_dm_mo(iorb,jorb)) print*,'DM ',iorb,jorb,dabs(one_body_dm_mo(iorb,jorb))
endif endif
enddo enddo
do j = 1, n_virt_orb do j = 1, n_virt_orb
jorb = list_virt(j) jorb = list_virt(j)
if(dabs(one_body_dm_mo(iorb,jorb)).gt.threshold_singles)then if(dabs(one_body_dm_mo(iorb,jorb)).gt.threshold_mlct)then
print*,'VIRT ' print*,'VIRT '
print*,'DM ',iorb,jorb,dabs(one_body_dm_mo(iorb,jorb)) print*,'DM ',iorb,jorb,dabs(one_body_dm_mo(iorb,jorb))
endif endif

132
plugins/FOBOCI/new_new_approach.irp.f Normal file
View File

@ -0,0 +1,132 @@
program test_new_new
implicit none
read_wf = .True.
touch read_wf
call test
end
subroutine test
implicit none
integer :: i,j,k,l
call diagonalize_CI
call set_generators_to_psi_det
print*,'Initial coefficients'
do i = 1, N_det
print*,''
call debug_det(psi_det(1,1,i),N_int)
print*,'psi_coef = ',psi_coef(i,1)
print*,''
enddo
double precision, allocatable :: dressing_matrix(:,:)
double precision :: hij
double precision :: phase
integer :: n_h,n_p,number_of_holes,number_of_particles
integer :: exc(0:2,2,2)
integer :: degree
integer :: h1,h2,p1,p2,s1,s2
allocate(dressing_matrix(N_det_generators,N_det_generators))
do i = 1, N_det_generators
do j = 1, N_det_generators
call i_h_j(psi_det_generators(1,1,i),psi_det_generators(1,1,j),N_int,hij)
dressing_matrix(i,j) = hij
enddo
enddo
href = dressing_matrix(1,1)
print*,'Diagonal part of the dressing'
do i = 1, N_det_generators
print*,'delta e = ',dressing_matrix(i,i) - href
enddo
call all_single_split(psi_det_generators,psi_coef_generators,N_det_generators,dressing_matrix)
double precision :: href
print*,''
! One considers that the following excitation classes are not repeatable on the 1h and 1p determinants :
! + 1h1p spin flip
! + 2h1p
! + 1h2p
! But the 2h2p are correctly taken into account
!dressing_matrix(1,1) += total_corr_e_1h2p + total_corr_e_2h1p + total_corr_e_1h1p_spin_flip
!do i = 1, N_det_generators
! dressing_matrix(i,i) += total_corr_e_2h2p
! n_h = number_of_holes(psi_det(1,1,i))
! n_p = number_of_particles(psi_det(1,1,i))
! if(n_h == 1 .and. n_p ==0)then
!
! call get_excitation(ref_bitmask,psi_det_generators(1,1,i),exc,degree,phase,N_int)
! call decode_exc(exc,degree,h1,p1,h2,p2,s1,s2)
! print*,''
! print*,' 1h det '
! print*,''
! call debug_det(psi_det_generators(1,1,i),N_int)
! print*,'h1,p1 = ',h1,p1
! print*,'total_corr_e_2h2p ',total_corr_e_2h2p
! print*,'corr_energy_2h2p_per_orb_ab(h1)',corr_energy_2h2p_per_orb_ab(h1)
! print*,'corr_energy_2h2p_per_orb_bb(h1)',corr_energy_2h2p_per_orb_bb(h1)
! dressing_matrix(i,i) += -corr_energy_2h2p_per_orb_ab(h1) - corr_energy_2h2p_per_orb_bb(h1)
! dressing_matrix(1,1) += -corr_energy_2h1p_per_orb_aa(h1) - corr_energy_2h1p_per_orb_ab(h1) -corr_energy_2h1p_per_orb_bb(h1) &
! -corr_energy_1h1p_spin_flip_per_orb(h1)
! endif
! if(n_h == 0 .and. n_p ==1)then
! call get_excitation(ref_bitmask,psi_det_generators(1,1,i),exc,degree,phase,N_int)
! call decode_exc(exc,degree,h1,p1,h2,p2,s1,s2)
! print*,''
! print*,' 1p det '
! print*,''
! call debug_det(psi_det_generators(1,1,i),N_int)
! print*,'h1,p1 = ',h1,p1
! print*,'total_corr_e_2h2p ',total_corr_e_2h2p
! print*,'corr_energy_2h2p_per_orb_ab(p1)',corr_energy_2h2p_per_orb_ab(p1)
! print*,'corr_energy_2h2p_per_orb_aa(p1)',corr_energy_2h2p_per_orb_aa(p1)
! dressing_matrix(i,i) += -corr_energy_2h2p_per_orb_ab(p1) - corr_energy_2h2p_per_orb_aa(p1)
! dressing_matrix(1,1) += -corr_energy_1h2p_per_orb_aa(p1) - corr_energy_1h2p_per_orb_ab(p1) -corr_energy_1h2p_per_orb_bb(p1)
! endif
!enddo
!href = dressing_matrix(1,1)
!print*,'Diagonal part of the dressing'
!do i = 1, N_det_generators
! print*,'delta e = ',dressing_matrix(i,i) - href
!enddo
call diag_dressed_matrix_and_set_to_psi_det(psi_det_generators,N_det_generators,dressing_matrix)
print*,'After dressing matrix'
print*,''
print*,''
do i = 1, N_det
print*,'psi_coef = ',psi_coef(i,1)
enddo
!print*,''
!print*,''
!print*,'Canceling the dressing part of the interaction between 1h and 1p'
!do i = 2, N_det_generators
! do j = i+1, N_det_generators
! call i_h_j(psi_det_generators(1,1,i),psi_det_generators(1,1,j),N_int,hij)
! dressing_matrix(i,j) = hij
! dressing_matrix(j,i) = hij
! enddo
!enddo
!call diag_dressed_matrix_and_set_to_psi_det(psi_det_generators,N_det_generators,dressing_matrix)
!print*,''
!print*,''
!do i = 1, N_det
! print*,'psi_coef = ',psi_coef(i,1)
!enddo
!print*,''
!print*,''
!print*,'Canceling the interaction between 1h and 1p'
!print*,''
!print*,''
!do i = 2, N_det_generators
! do j = i+1, N_det_generators
! dressing_matrix(i,j) = 0.d0
! dressing_matrix(j,i) = 0.d0
! enddo
!enddo
!call diag_dressed_matrix_and_set_to_psi_det(psi_det_generators,N_det_generators,dressing_matrix)
!do i = 1, N_det
! print*,'psi_coef = ',psi_coef(i,1)
!enddo
call save_natural_mos
deallocate(dressing_matrix)
end

497
plugins/FOBOCI/routines_dressing.irp.f
View File

@ -55,15 +55,11 @@ subroutine provide_matrix_dressing(dressing_matrix,ndet_generators_input,psi_det
i_pert = 0 i_pert = 0
endif endif
do j = 1, ndet_generators_input do j = 1, ndet_generators_input
if(dabs(H_array(j)*lambda_i).gt.0.5d0)then if(dabs(H_array(j)*lambda_i).gt.0.1d0)then
i_pert = 1 i_pert = 1
exit exit
endif endif
enddo enddo
! print*,''
! print*,'lambda_i,f = ',lambda_i,f
! print*,'i_pert = ',i_pert
! print*,''
if(i_pert==1)then if(i_pert==1)then
lambda_i = f lambda_i = f
i_pert_count +=1 i_pert_count +=1
@ -79,9 +75,122 @@ subroutine provide_matrix_dressing(dressing_matrix,ndet_generators_input,psi_det
enddo enddo
enddo enddo
enddo enddo
href = dressing_matrix(1,1)
print*,'Diagonal part of the dressing'
do i = 1, ndet_generators_input
print*,'delta e = ',dressing_matrix(i,i) - href
enddo
!print*,'i_pert_count = ',i_pert_count !print*,'i_pert_count = ',i_pert_count
end end
subroutine update_matrix_dressing_sc2(dressing_matrix,ndet_generators_input,psi_det_generators_input,H_jj_in)
use bitmasks
implicit none
integer, intent(in) :: ndet_generators_input
integer(bit_kind), intent(in) :: psi_det_generators_input(N_int,2,ndet_generators_input)
double precision, intent(in) :: H_jj_in(N_det)
double precision, intent(inout) :: dressing_matrix(ndet_generators_input,ndet_generators_input)
integer :: i,j,n_det_ref_tmp,degree
double precision :: href
n_det_ref_tmp = 0
do i = 1, N_det
do j = 1, Ndet_generators_input
call get_excitation_degree(psi_det(1,1,i),psi_det_generators_input(1,1,j),degree,N_int)
if(degree == 0)then
dressing_matrix(j,j) += H_jj_in(i)
n_det_ref_tmp +=1
exit
endif
enddo
enddo
if( ndet_generators_input .ne. n_det_ref_tmp)then
print*,'Problem !!!! '
print*,' ndet_generators .ne. n_det_ref_tmp !!!'
print*,'ndet_generators,n_det_ref_tmp'
print*,ndet_generators_input,n_det_ref_tmp
stop
endif
href = dressing_matrix(1,1)
print*,''
print*,'Update with the SC2 dressing'
print*,''
print*,'Diagonal part of the dressing'
do i = 1, ndet_generators_input
print*,'delta e = ',dressing_matrix(i,i) - href
enddo
end
subroutine provide_matrix_dressing_for_extra_1h_or_1p(dressing_matrix,psi_det_ref_input,psi_coef_ref_input,n_det_ref_input, &
psi_det_outer_input,psi_coef_outer_input,n_det_outer_input)
use bitmasks
implicit none
integer, intent(in) :: n_det_ref_input
integer(bit_kind), intent(in) :: psi_det_ref_input(N_int,2,n_det_ref_input)
double precision, intent(in) :: psi_coef_ref_input(n_det_ref_input,N_states)
integer, intent(in) :: n_det_outer_input
integer(bit_kind), intent(in) :: psi_det_outer_input(N_int,2,n_det_outer_input)
double precision, intent(in) :: psi_coef_outer_input(n_det_outer_input,N_states)
double precision, intent(inout) :: dressing_matrix(n_det_ref_input,n_det_ref_input)
integer :: i_pert, i_pert_count,i,j,k
double precision :: f,href,hka,lambda_i
double precision :: H_array(n_det_ref_input),accu
integer :: n_h_out,n_p_out,n_p_in,n_h_in,number_of_holes,number_of_particles
call i_h_j(psi_det_ref_input(1,1,1),psi_det_ref_input(1,1,1),N_int,href)
i_pert_count = 0
do i = 1, n_det_outer_input
call i_h_j(psi_det_outer_input(1,1,i),psi_det_outer_input(1,1,i),N_int,hka)
f = 1.d0/(href - hka)
H_array = 0.d0
accu = 0.d0
! n_h_out = number_of_holes(psi_det_outer_input(1,1,i))
! n_p_out = number_of_particles(psi_det_outer_input(1,1,i))
do j=1,n_det_ref_input
n_h_in = number_of_holes(psi_det_ref_input(1,1,j))
n_p_in = number_of_particles(psi_det_ref_input(1,1,j))
! if(n_h_in == 0 .and. n_h_in == 0)then
call i_h_j(psi_det_outer_input(1,1,i),psi_det_ref_input(1,1,j),N_int,hka)
! else
! hka = 0.d0
! endif
H_array(j) = hka
accu += psi_coef_ref_input(j,1) * hka
enddo
lambda_i = psi_coef_outer_input(i,1)/accu
i_pert = 1
if(accu * f / psi_coef_outer_input(i,1) .gt. 0.5d0 .and. accu * f/psi_coef_outer_input(i,1).gt.0.d0)then
i_pert = 0
endif
do j = 1, n_det_ref_input
if(dabs(H_array(j)*lambda_i).gt.0.5d0)then
i_pert = 1
exit
endif
enddo
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! i_pert = 0
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
if(i_pert==1)then
lambda_i = f
i_pert_count +=1
endif
do k=1,n_det_ref_input
double precision :: contrib
contrib = H_array(k) * H_array(k) * lambda_i
dressing_matrix(k, k) += contrib
do j=k+1,n_det_ref_input
contrib = H_array(k) * H_array(j) * lambda_i
dressing_matrix(k, j) += contrib
dressing_matrix(j, k) += contrib
enddo
enddo
enddo
end
subroutine provide_matrix_dressing_general(dressing_matrix,psi_det_ref_input,psi_coef_ref_input,n_det_ref_input, & subroutine provide_matrix_dressing_general(dressing_matrix,psi_det_ref_input,psi_coef_ref_input,n_det_ref_input, &
psi_det_outer_input,psi_coef_outer_input,n_det_outer_input) psi_det_outer_input,psi_coef_outer_input,n_det_outer_input)
use bitmasks use bitmasks
@ -112,16 +221,17 @@ subroutine provide_matrix_dressing_general(dressing_matrix,psi_det_ref_input,psi
accu += psi_coef_ref_input(j,1) * hka accu += psi_coef_ref_input(j,1) * hka
enddo enddo
lambda_i = psi_coef_outer_input(i,1)/accu lambda_i = psi_coef_outer_input(i,1)/accu
i_pert = 1 i_pert = 0
if(accu * f / psi_coef_outer_input(i,1) .gt. 0.5d0 .and. accu * f/psi_coef_outer_input(i,1).gt.0.d0)then if(accu * f / psi_coef_outer_input(i,1) .gt. 0.5d0 .and. accu * f/psi_coef_outer_input(i,1).gt.0.d0)then
i_pert = 0 i_pert = 0
endif endif
do j = 1, n_det_ref_input do j = 1, n_det_ref_input
if(dabs(H_array(j)*lambda_i).gt.0.3d0)then if(dabs(H_array(j)*lambda_i).gt.0.5d0)then
i_pert = 1 i_pert = 1
exit exit
endif endif
enddo enddo
! i_pert = 0
if(i_pert==1)then if(i_pert==1)then
lambda_i = f lambda_i = f
i_pert_count +=1 i_pert_count +=1
@ -170,114 +280,379 @@ subroutine diag_dressed_matrix_and_set_to_psi_det(psi_det_generators_input,Ndet_
end end
subroutine give_n_1h1p_and_n_2h1p_in_psi_det(n_det_1h1p,n_det_2h1p) subroutine give_n_1h1p_and_n_2h1p_in_psi_det(i_hole,n_det_extra_1h_or_1p,n_det_1h1p,n_det_2h1p)
use bitmasks use bitmasks
implicit none implicit none
integer, intent(out) :: n_det_1h1p, n_det_2h1p integer, intent(in) :: i_hole
integer, intent(out) :: n_det_1h1p, n_det_2h1p,n_det_extra_1h_or_1p
integer :: i integer :: i
integer :: n_det_ref_restart_tmp,n_det_1h integer :: n_det_ref_restart_tmp,n_det_1h
integer :: number_of_holes,n_h, number_of_particles,n_p integer :: number_of_holes,n_h, number_of_particles,n_p
logical :: is_the_hole_in_det
n_det_ref_restart_tmp = 0 n_det_ref_restart_tmp = 0
n_det_1h = 0 n_det_1h = 0
n_det_1h1p = 0 n_det_1h1p = 0
n_det_2h1p = 0 n_det_2h1p = 0
n_det_extra_1h_or_1p = 0
do i = 1, N_det do i = 1, N_det
n_h = number_of_holes(psi_det(1,1,i)) n_h = number_of_holes(psi_det(1,1,i))
n_p = number_of_particles(psi_det(1,1,i)) n_p = number_of_particles(psi_det(1,1,i))
if(n_h == 0 .and. n_p == 0)then if(n_h == 0 .and. n_p == 0)then
n_det_ref_restart_tmp +=1 n_det_ref_restart_tmp +=1
else if (n_h ==1 .and. n_p==0)then else if (n_h ==1 .and. n_p==0)then
n_det_1h +=1 if(is_the_hole_in_det(psi_det(1,1,i),1,i_hole).or.is_the_hole_in_det(psi_det(1,1,i),2,i_hole))then
n_det_1h +=1
else
n_det_extra_1h_or_1p +=1
endif
else if (n_h ==0 .and. n_p==1)then
n_det_extra_1h_or_1p +=1
else if (n_h ==1 .and. n_p==1)then else if (n_h ==1 .and. n_p==1)then
n_det_1h1p +=1 n_det_1h1p +=1
else if (n_h ==2 .and. n_p==1)then else if (n_h ==2 .and. n_p==1)then
n_det_2h1p +=1 n_det_2h1p +=1
else else
print*,'PB !!!!' print*,'PB !!!!'
print*,'You have something else than a 1h, 1h1p or 2h1p' print*,'You have something else than a 1h, 1p, 1h1p or 2h1p'
print*,'n_h,n_p = ',n_h,n_p
call debug_det(psi_det(1,1,i),N_int) call debug_det(psi_det(1,1,i),N_int)
stop stop
endif endif
enddo enddo
! if(n_det_1h.ne.1)then
! print*,'PB !! You have more than one 1h'
! stop
! endif
if(n_det_ref_restart_tmp + n_det_1h .ne. n_det_generators)then if(n_det_ref_restart_tmp + n_det_1h .ne. n_det_generators)then
print*,'PB !!!!' print*,'PB !!!!'
print*,'You have forgotten something in your generators ... ' print*,'You have forgotten something in your generators ... '
stop stop
endif endif
if(n_det_2h1p + n_det_1h1p + n_det_extra_1h_or_1p + n_det_generators .ne. N_det)then
print*,'PB !!!!'
print*,'You have forgotten something in your generators ... '
stop
endif
end end
subroutine give_n_1h1p_and_n_1h2p_in_psi_det(n_det_1h1p,n_det_1h2p) subroutine give_n_ref_1h_1p_and_n_2h1p_1h1p_in_psi_det(n_det_ref_1h_1p,n_det_2h1p,n_det_1h1p)
use bitmasks use bitmasks
implicit none implicit none
integer, intent(out) :: n_det_1h1p, n_det_1h2p integer, intent(out) :: n_det_ref_1h_1p,n_det_2h1p,n_det_1h1p
integer :: i integer :: i
integer :: n_det_ref_restart_tmp,n_det_1h integer :: n_det_ref_restart_tmp,n_det_1h
integer :: number_of_holes,n_h, number_of_particles,n_p integer :: number_of_holes,n_h, number_of_particles,n_p
n_det_ref_restart_tmp = 0 logical :: is_the_hole_in_det
n_det_1h = 0 n_det_ref_1h_1p = 0
n_det_2h1p = 0
n_det_1h1p = 0 n_det_1h1p = 0
n_det_1h2p = 0
do i = 1, N_det do i = 1, N_det
n_h = number_of_holes(psi_det(1,1,i)) n_h = number_of_holes(psi_det(1,1,i))
n_p = number_of_particles(psi_det(1,1,i)) n_p = number_of_particles(psi_det(1,1,i))
if(n_h == 0 .and. n_p == 0)then if(n_h == 0 .and. n_p == 0)then
n_det_ref_restart_tmp +=1 n_det_ref_1h_1p +=1
else if (n_h ==1 .and. n_p==0)then
n_det_ref_1h_1p +=1
else if (n_h ==0 .and. n_p==1)then else if (n_h ==0 .and. n_p==1)then
n_det_1h +=1 n_det_ref_1h_1p +=1
else if (n_h ==1 .and. n_p==1)then
n_det_1h1p +=1
else if (n_h ==2 .and. n_p==1)then
n_det_2h1p +=1
else
print*,'PB !!!!'
print*,'You have something else than a 1h, 1p, 1h1p or 2h1p'
print*,'n_h,n_p = ',n_h,n_p
call debug_det(psi_det(1,1,i),N_int)
stop
endif
enddo
end
subroutine give_n_ref_1h_1p_and_n_1h2p_1h1p_in_psi_det(n_det_ref_1h_1p,n_det_1h2p,n_det_1h1p)
use bitmasks
implicit none
integer, intent(out) :: n_det_ref_1h_1p,n_det_1h2p,n_det_1h1p
integer :: i
integer :: n_det_ref_restart_tmp,n_det_1h
integer :: number_of_holes,n_h, number_of_particles,n_p
logical :: is_the_hole_in_det
n_det_ref_1h_1p = 0
n_det_1h2p = 0
n_det_1h1p = 0
do i = 1, N_det
n_h = number_of_holes(psi_det(1,1,i))
n_p = number_of_particles(psi_det(1,1,i))
if(n_h == 0 .and. n_p == 0)then
n_det_ref_1h_1p +=1
else if (n_h ==1 .and. n_p==0)then
n_det_ref_1h_1p +=1
else if (n_h ==0 .and. n_p==1)then
n_det_ref_1h_1p +=1
else if (n_h ==1 .and. n_p==1)then else if (n_h ==1 .and. n_p==1)then
n_det_1h1p +=1 n_det_1h1p +=1
else if (n_h ==1 .and. n_p==2)then else if (n_h ==1 .and. n_p==2)then
n_det_1h2p +=1 n_det_1h2p +=1
else else
print*,'PB !!!!' print*,'PB !!!!'
print*,'You have something else than a 1p, 1h1p or 1h2p' print*,'You have something else than a 1h, 1p, 1h1p or 1h2p'
print*,'n_h,n_p = ',n_h,n_p
call debug_det(psi_det(1,1,i),N_int) call debug_det(psi_det(1,1,i),N_int)
stop stop
endif endif
enddo enddo
if(n_det_ref_restart_tmp + n_det_1h .ne. n_det_generators)then
end
subroutine give_wf_n_ref_1h_1p_and_n_2h1p_1h1p_in_psi_det(n_det_ref_1h_1p,n_det_2h1p,n_det_1h1p,psi_det_ref_1h_1p,psi_coef_ref_1h_1p,&
psi_det_2h1p,psi_coef_2h1p,psi_det_1h1p,psi_coef_1h1p)
use bitmasks
implicit none
integer, intent(in) :: n_det_ref_1h_1p,n_det_2h1p,n_det_1h1p
integer(bit_kind), intent(out) :: psi_det_ref_1h_1p(N_int,2,n_det_ref_1h_1p)
integer(bit_kind), intent(out) :: psi_det_2h1p(N_int,2,n_det_2h1p)
integer(bit_kind), intent(out) :: psi_det_1h1p(N_int,2,n_det_1h1p)
double precision, intent(out) :: psi_coef_ref_1h_1p(n_det_ref_1h_1p,N_states)
double precision, intent(out) :: psi_coef_2h1p(n_det_2h1p,N_states)
double precision, intent(out) :: psi_coef_1h1p(n_det_1h1p,N_states)
integer :: n_det_ref_1h_1p_tmp,n_det_2h1p_tmp,n_det_1h1p_tmp
integer :: i,j
integer :: n_det_ref_restart_tmp,n_det_1h
integer :: number_of_holes,n_h, number_of_particles,n_p
logical :: is_the_hole_in_det
integer, allocatable :: index_ref_1h_1p(:)
integer, allocatable :: index_2h1p(:)
integer, allocatable :: index_1h1p(:)
allocate(index_ref_1h_1p(n_det))
allocate(index_2h1p(n_det))
allocate(index_1h1p(n_det))
n_det_ref_1h_1p_tmp = 0
n_det_2h1p_tmp = 0
n_det_1h1p_tmp = 0
do i = 1, N_det
n_h = number_of_holes(psi_det(1,1,i))
n_p = number_of_particles(psi_det(1,1,i))
if(n_h == 0 .and. n_p == 0)then
n_det_ref_1h_1p_tmp +=1
index_ref_1h_1p(n_det_ref_1h_1p_tmp) = i
else if (n_h ==1 .and. n_p==0)then
n_det_ref_1h_1p_tmp +=1
index_ref_1h_1p(n_det_ref_1h_1p_tmp) = i
else if (n_h ==0 .and. n_p==1)then
n_det_ref_1h_1p_tmp +=1
index_ref_1h_1p(n_det_ref_1h_1p_tmp) = i
else if (n_h ==1 .and. n_p==1)then
n_det_1h1p_tmp +=1
index_1h1p(n_det_1h1p_tmp) = i
else if (n_h ==2 .and. n_p==1)then
n_det_2h1p_tmp +=1
index_2h1p(n_det_2h1p_tmp) = i
else
print*,'PB !!!!' print*,'PB !!!!'
print*,'You have forgotten something in your generators ... ' print*,'You have something else than a 1h, 1p, 1h1p or 2h1p'
stop print*,'n_h,n_p = ',n_h,n_p
endif call debug_det(psi_det(1,1,i),N_int)
stop
endif
enddo
do i = 1, n_det_2h1p
do j = 1, N_int
psi_det_2h1p(j,1,i) = psi_det(j,1,index_2h1p(i))
psi_det_2h1p(j,2,i) = psi_det(j,2,index_2h1p(i))
enddo
do j = 1, N_states
psi_coef_2h1p(i,j) = psi_coef(index_2h1p(i),j)
enddo
enddo
do i = 1, n_det_1h1p
do j = 1, N_int
psi_det_1h1p(j,1,i) = psi_det(j,1,index_1h1p(i))
psi_det_1h1p(j,2,i) = psi_det(j,2,index_1h1p(i))
enddo
do j = 1, N_states
psi_coef_1h1p(i,j) = psi_coef(index_1h1p(i),j)
enddo
enddo
do i = 1, n_det_ref_1h_1p
do j = 1, N_int
psi_det_ref_1h_1p(j,1,i) = psi_det(j,1,index_ref_1h_1p(i))
psi_det_ref_1h_1p(j,2,i) = psi_det(j,2,index_ref_1h_1p(i))
enddo
do j = 1, N_states
psi_coef_ref_1h_1p(i,j) = psi_coef(index_ref_1h_1p(i),j)
enddo
enddo
end
subroutine give_wf_n_ref_1h_1p_and_n_1h2p_1h1p_in_psi_det(n_det_ref_1h_1p,n_det_1h2p,n_det_1h1p,psi_det_ref_1h_1p,psi_coef_ref_1h_1p,&
psi_det_1h2p,psi_coef_1h2p,psi_det_1h1p,psi_coef_1h1p)
use bitmasks
implicit none
integer, intent(in) :: n_det_ref_1h_1p,n_det_1h2p,n_det_1h1p
integer(bit_kind), intent(out) :: psi_det_ref_1h_1p(N_int,2,n_det_ref_1h_1p)
integer(bit_kind), intent(out) :: psi_det_1h2p(N_int,2,n_det_1h2p)
integer(bit_kind), intent(out) :: psi_det_1h1p(N_int,2,n_det_1h1p)
double precision, intent(out) :: psi_coef_ref_1h_1p(n_det_ref_1h_1p,N_states)
double precision, intent(out) :: psi_coef_1h2p(n_det_1h2p,N_states)
double precision, intent(out) :: psi_coef_1h1p(n_det_1h1p,N_states)
integer :: n_det_ref_1h_1p_tmp,n_det_1h2p_tmp,n_det_1h1p_tmp
integer :: i,j
integer :: n_det_ref_restart_tmp,n_det_1h
integer :: number_of_holes,n_h, number_of_particles,n_p
logical :: is_the_hole_in_det
integer, allocatable :: index_ref_1h_1p(:)
integer, allocatable :: index_1h2p(:)
integer, allocatable :: index_1h1p(:)
allocate(index_ref_1h_1p(n_det))
allocate(index_1h2p(n_det))
allocate(index_1h1p(n_det))
n_det_ref_1h_1p_tmp = 0
n_det_1h2p_tmp = 0
n_det_1h1p_tmp = 0
do i = 1, N_det
n_h = number_of_holes(psi_det(1,1,i))
n_p = number_of_particles(psi_det(1,1,i))
if(n_h == 0 .and. n_p == 0)then
n_det_ref_1h_1p_tmp +=1
index_ref_1h_1p(n_det_ref_1h_1p_tmp) = i
else if (n_h ==1 .and. n_p==0)then
n_det_ref_1h_1p_tmp +=1
index_ref_1h_1p(n_det_ref_1h_1p_tmp) = i
else if (n_h ==0 .and. n_p==1)then
n_det_ref_1h_1p_tmp +=1
index_ref_1h_1p(n_det_ref_1h_1p_tmp) = i
else if (n_h ==1 .and. n_p==1)then
n_det_1h1p_tmp +=1
index_1h1p(n_det_1h1p_tmp) = i
else if (n_h ==1 .and. n_p==2)then
n_det_1h2p_tmp +=1
index_1h2p(n_det_1h2p_tmp) = i
else
print*,'PB !!!!'
print*,'You have something else than a 1h, 1p, 1h1p or 1h2p'
print*,'n_h,n_p = ',n_h,n_p
call debug_det(psi_det(1,1,i),N_int)
stop
endif
enddo
do i = 1, n_det_1h2p
do j = 1, N_int
psi_det_1h2p(j,1,i) = psi_det(j,1,index_1h2p(i))
psi_det_1h2p(j,2,i) = psi_det(j,2,index_1h2p(i))
enddo
do j = 1, N_states
psi_coef_1h2p(i,j) = psi_coef(index_1h2p(i),j)
enddo
enddo
do i = 1, n_det_1h1p
do j = 1, N_int
psi_det_1h1p(j,1,i) = psi_det(j,1,index_1h1p(i))
psi_det_1h1p(j,2,i) = psi_det(j,2,index_1h1p(i))
enddo
do j = 1, N_states
psi_coef_1h1p(i,j) = psi_coef(index_1h1p(i),j)
enddo
enddo
do i = 1, n_det_ref_1h_1p
do j = 1, N_int
psi_det_ref_1h_1p(j,1,i) = psi_det(j,1,index_ref_1h_1p(i))
psi_det_ref_1h_1p(j,2,i) = psi_det(j,2,index_ref_1h_1p(i))
enddo
do j = 1, N_states
psi_coef_ref_1h_1p(i,j) = psi_coef(index_ref_1h_1p(i),j)
enddo
enddo
end
subroutine give_n_1h1p_and_n_1h2p_in_psi_det(i_particl,n_det_extra_1h_or_1p,n_det_1h1p,n_det_1h2p)
use bitmasks
implicit none
integer, intent(in) ::i_particl
integer, intent(out) :: n_det_1h1p, n_det_1h2p,n_det_extra_1h_or_1p
integer :: i
integer :: n_det_ref_restart_tmp,n_det_1p
integer :: number_of_holes,n_h, number_of_particles,n_p
logical :: is_the_particl_in_det
n_det_ref_restart_tmp = 0
n_det_1p = 0
n_det_1h1p = 0
n_det_1h2p = 0
n_det_extra_1h_or_1p = 0
do i = 1, N_det
n_h = number_of_holes(psi_det(1,1,i))
n_p = number_of_particles(psi_det(1,1,i))
if(n_h == 0 .and. n_p == 0)then
n_det_ref_restart_tmp +=1
else if (n_h ==0 .and. n_p==1)then
if(is_the_particl_in_det(psi_det(1,1,i),1,i_particl).or.is_the_particl_in_det(psi_det(1,1,i),2,i_particl))then
n_det_1p +=1
else
n_det_extra_1h_or_1p +=1
endif
else if (n_h ==1 .and. n_p==0)then
n_det_extra_1h_or_1p +=1
else if (n_h ==1 .and. n_p==1)then
n_det_1h1p +=1
else if (n_h ==1 .and. n_p==2)then
n_det_1h2p +=1
else
print*,'PB !!!!'
print*,'You have something else than a 1h, 1p, 1h1p or 1h2p'
call debug_det(psi_det(1,1,i),N_int)
stop
endif
enddo
!if(n_det_ref_restart_tmp + n_det_1h .ne. n_det_generators)then
! print*,'PB !!!!'
! print*,'You have forgotten something in your generators ... '
! stop
!endif
end end
subroutine split_wf_generators_and_1h1p_and_2h1p(n_det_1h1p,n_det_2h1p,psi_ref_out,psi_ref_coef_out,psi_1h1p,psi_coef_1h1p,psi_2h1p,psi_coef_2h1p) subroutine split_wf_generators_and_1h1p_and_2h1p(i_hole,n_det_extra_1h_or_1p,n_det_1h1p,n_det_2h1p,psi_ref_out,psi_ref_coef_out,psi_1h1p,psi_coef_1h1p,psi_2h1p,psi_coef_2h1p,psi_extra_1h_or_1p,psi_coef_extra_1h_or_1p)
use bitmasks use bitmasks
implicit none implicit none
integer, intent(in) :: n_det_1h1p,n_det_2h1p integer, intent(in) :: n_det_1h1p,n_det_2h1p,n_det_extra_1h_or_1p,i_hole
integer(bit_kind), intent(out) :: psi_ref_out(N_int,2,N_det_generators) integer(bit_kind), intent(out) :: psi_ref_out(N_int,2,N_det_generators)
integer(bit_kind), intent(out) :: psi_1h1p(N_int,2,n_det_1h1p) integer(bit_kind), intent(out) :: psi_1h1p(N_int,2,n_det_1h1p)
integer(bit_kind), intent(out) :: psi_2h1p(N_int,2,n_det_2h1p) integer(bit_kind), intent(out) :: psi_2h1p(N_int,2,n_det_2h1p)
integer(bit_kind), intent(out) :: psi_extra_1h_or_1p(N_int,2,n_det_extra_1h_or_1p)
double precision, intent(out) :: psi_ref_coef_out(N_det_generators,N_states) double precision, intent(out) :: psi_ref_coef_out(N_det_generators,N_states)
double precision, intent(out) :: psi_coef_1h1p(n_det_1h1p, N_states) double precision, intent(out) :: psi_coef_1h1p(n_det_1h1p, N_states)
double precision, intent(out) :: psi_coef_2h1p(n_det_2h1p, N_states) double precision, intent(out) :: psi_coef_2h1p(n_det_2h1p, N_states)
double precision, intent(out) :: psi_coef_extra_1h_or_1p(n_det_extra_1h_or_1p, N_states)
integer :: i,j integer :: i,j
integer :: degree integer :: degree
integer :: number_of_holes,n_h, number_of_particles,n_p integer :: number_of_holes,n_h, number_of_particles,n_p
integer :: n_det_generators_tmp,n_det_1h1p_tmp,n_det_2h1p_tmp integer :: n_det_generators_tmp,n_det_1h1p_tmp,n_det_2h1p_tmp,n_det_extra_1h_or_1p_tmp
integer :: n_det_1h_tmp
integer, allocatable :: index_generator(:) integer, allocatable :: index_generator(:)
integer, allocatable :: index_1h1p(:) integer, allocatable :: index_1h1p(:)
integer, allocatable :: index_2h1p(:) integer, allocatable :: index_2h1p(:)
integer, allocatable :: index_extra_1h_or_1p(:)
logical :: is_the_hole_in_det
allocate(index_1h1p(n_det)) allocate(index_1h1p(n_det))
allocate(index_2h1p(n_det)) allocate(index_2h1p(n_det))
allocate(index_extra_1h_or_1p(n_det))
allocate(index_generator(N_det)) allocate(index_generator(N_det))
n_det_generators_tmp = 0 n_det_generators_tmp = 0
n_det_1h1p_tmp = 0 n_det_1h1p_tmp = 0
n_det_2h1p_tmp = 0 n_det_2h1p_tmp = 0
n_det_extra_1h_or_1p_tmp = 0
n_det_1h_tmp = 0
do i = 1, n_det do i = 1, n_det
n_h = number_of_holes(psi_det(1,1,i)) n_h = number_of_holes(psi_det(1,1,i))
n_p = number_of_particles(psi_det(1,1,i)) n_p = number_of_particles(psi_det(1,1,i))
@ -287,6 +662,16 @@ subroutine split_wf_generators_and_1h1p_and_2h1p(n_det_1h1p,n_det_2h1p,psi_ref_o
else if (n_h ==2 .and. n_p==1)then else if (n_h ==2 .and. n_p==1)then
n_det_2h1p_tmp +=1 n_det_2h1p_tmp +=1
index_2h1p(n_det_2h1p_tmp) = i index_2h1p(n_det_2h1p_tmp) = i
else if (n_h ==0 .and. n_p==1)then
n_det_extra_1h_or_1p_tmp +=1
index_extra_1h_or_1p(n_det_extra_1h_or_1p_tmp) = i
else if (n_h ==1 .and. n_p==0)then
if(is_the_hole_in_det(psi_det(1,1,i),1,i_hole).or.is_the_hole_in_det(psi_det(1,1,i),2,i_hole))then
n_det_1h_tmp +=1
else
n_det_extra_1h_or_1p_tmp +=1
index_extra_1h_or_1p(n_det_extra_1h_or_1p_tmp) = i
endif
endif endif
do j = 1, N_det_generators do j = 1, N_det_generators
call get_excitation_degree(psi_det_generators(1,1,j),psi_det(1,1,i), degree, N_int) call get_excitation_degree(psi_det_generators(1,1,j),psi_det(1,1,i), degree, N_int)
@ -315,6 +700,12 @@ subroutine split_wf_generators_and_1h1p_and_2h1p(n_det_1h1p,n_det_2h1p,psi_ref_o
stop stop
endif endif
if(n_det_extra_1h_or_1p.ne.n_det_extra_1h_or_1p_tmp)then
print*,'PB !!!'
print*,'n_det_extra_1h_or_1p.ne.n_det_extra_1h_or_1p_tmp'
stop
endif
do i = 1,N_det_generators do i = 1,N_det_generators
do j = 1, N_int do j = 1, N_int
psi_ref_out(j,1,i) = psi_det(j,1,index_generator(i)) psi_ref_out(j,1,i) = psi_det(j,1,index_generator(i))
@ -345,41 +736,59 @@ subroutine split_wf_generators_and_1h1p_and_2h1p(n_det_1h1p,n_det_2h1p,psi_ref_o
enddo enddo
enddo enddo
do i = 1, n_det_extra_1h_or_1p
do j = 1, N_int
psi_extra_1h_or_1p(j,1,i) = psi_det(j,1,index_extra_1h_or_1p(i))
psi_extra_1h_or_1p(j,2,i) = psi_det(j,2,index_extra_1h_or_1p(i))
enddo
do j = 1, N_states
psi_coef_extra_1h_or_1p(i,j) = psi_coef(index_extra_1h_or_1p(i),j)
enddo
enddo
deallocate(index_generator) deallocate(index_generator)
deallocate(index_1h1p) deallocate(index_1h1p)
deallocate(index_2h1p) deallocate(index_2h1p)
deallocate(index_extra_1h_or_1p)
end end
subroutine split_wf_generators_and_1h1p_and_1h2p(n_det_1h1p,n_det_1h2p,psi_ref_out,psi_ref_coef_out,psi_1h1p,psi_coef_1h1p,psi_1h2p,psi_coef_1h2p) subroutine split_wf_generators_and_1h1p_and_1h2p(i_particl,n_det_extra_1h_or_1p,n_det_1h1p,n_det_1h2p,psi_ref_out,psi_ref_coef_out,psi_1h1p,psi_coef_1h1p,psi_1h2p,psi_coef_1h2p,psi_extra_1h_or_1p,psi_coef_extra_1h_or_1p)
use bitmasks use bitmasks
implicit none implicit none
integer, intent(in) :: n_det_1h1p,n_det_1h2p integer, intent(in) :: n_det_1h1p,n_det_1h2p,n_det_extra_1h_or_1p,i_particl
integer(bit_kind), intent(out) :: psi_ref_out(N_int,2,N_det_generators) integer(bit_kind), intent(out) :: psi_ref_out(N_int,2,N_det_generators)
integer(bit_kind), intent(out) :: psi_1h1p(N_int,2,n_det_1h1p) integer(bit_kind), intent(out) :: psi_1h1p(N_int,2,n_det_1h1p)
integer(bit_kind), intent(out) :: psi_1h2p(N_int,2,n_det_1h2p) integer(bit_kind), intent(out) :: psi_1h2p(N_int,2,n_det_1h2p)
integer(bit_kind), intent(out) :: psi_extra_1h_or_1p(N_int,2,n_det_extra_1h_or_1p)
double precision, intent(out) :: psi_ref_coef_out(N_det_generators,N_states) double precision, intent(out) :: psi_ref_coef_out(N_det_generators,N_states)
double precision, intent(out) :: psi_coef_1h1p(n_det_1h1p, N_states) double precision, intent(out) :: psi_coef_1h1p(n_det_1h1p, N_states)
double precision, intent(out) :: psi_coef_1h2p(n_det_1h2p, N_states) double precision, intent(out) :: psi_coef_1h2p(n_det_1h2p, N_states)
double precision, intent(out) :: psi_coef_extra_1h_or_1p(n_det_extra_1h_or_1p, N_states)
integer :: i,j integer :: i,j
integer :: degree integer :: degree
integer :: number_of_holes,n_h, number_of_particles,n_p integer :: number_of_holes,n_h, number_of_particles,n_p
integer :: n_det_generators_tmp,n_det_1h1p_tmp,n_det_1h2p_tmp integer :: n_det_generators_tmp,n_det_1h1p_tmp,n_det_1h2p_tmp,n_det_extra_1h_or_1p_tmp
integer, allocatable :: index_generator(:) integer, allocatable :: index_generator(:)
integer, allocatable :: index_1h1p(:) integer, allocatable :: index_1h1p(:)
integer, allocatable :: index_1h2p(:) integer, allocatable :: index_1h2p(:)
integer, allocatable :: index_extra_1h_or_1p(:)
logical :: is_the_particl_in_det
integer :: n_det_1p_tmp
allocate(index_1h1p(n_det)) allocate(index_1h1p(n_det))
allocate(index_1h2p(n_det)) allocate(index_1h2p(n_det))
allocate(index_extra_1h_or_1p(n_det))
allocate(index_generator(N_det)) allocate(index_generator(N_det))
n_det_generators_tmp = 0 n_det_generators_tmp = 0
n_det_1h1p_tmp = 0 n_det_1h1p_tmp = 0
n_det_1h2p_tmp = 0 n_det_1h2p_tmp = 0
n_det_extra_1h_or_1p_tmp = 0
n_det_1p_tmp = 0
do i = 1, n_det do i = 1, n_det
n_h = number_of_holes(psi_det(1,1,i)) n_h = number_of_holes(psi_det(1,1,i))
n_p = number_of_particles(psi_det(1,1,i)) n_p = number_of_particles(psi_det(1,1,i))
@ -389,6 +798,15 @@ subroutine split_wf_generators_and_1h1p_and_1h2p(n_det_1h1p,n_det_1h2p,psi_ref_o
else if (n_h ==1 .and. n_p==2)then else if (n_h ==1 .and. n_p==2)then
n_det_1h2p_tmp +=1 n_det_1h2p_tmp +=1
index_1h2p(n_det_1h2p_tmp) = i index_1h2p(n_det_1h2p_tmp) = i
else if (n_h ==1 .and. n_p==0)then
n_det_extra_1h_or_1p_tmp +=1
index_extra_1h_or_1p(n_det_extra_1h_or_1p_tmp) = i
else if (n_h ==0 .and. n_p==1)then
if(is_the_particl_in_det(psi_det(1,1,i),1,i_particl).or.is_the_particl_in_det(psi_det(1,1,i),2,i_particl))then
n_det_1p_tmp +=1
else
n_det_extra_1h_or_1p_tmp +=1
endif
endif endif
do j = 1, N_det_generators do j = 1, N_det_generators
call get_excitation_degree(psi_det_generators(1,1,j),psi_det(1,1,i), degree, N_int) call get_excitation_degree(psi_det_generators(1,1,j),psi_det(1,1,i), degree, N_int)
@ -448,9 +866,20 @@ subroutine split_wf_generators_and_1h1p_and_1h2p(n_det_1h1p,n_det_1h2p,psi_ref_o
enddo enddo
do i = 1, n_det_extra_1h_or_1p
do j = 1, N_int
psi_extra_1h_or_1p(j,1,i) = psi_det(j,1,index_extra_1h_or_1p(i))
psi_extra_1h_or_1p(j,2,i) = psi_det(j,2,index_extra_1h_or_1p(i))
enddo
do j = 1, N_states
psi_coef_extra_1h_or_1p(i,j) = psi_coef(index_extra_1h_or_1p(i),j)
enddo
enddo
deallocate(index_generator) deallocate(index_generator)
deallocate(index_1h1p) deallocate(index_1h1p)
deallocate(index_1h2p) deallocate(index_1h2p)
deallocate(index_extra_1h_or_1p)
end end

262
plugins/FOBOCI/routines_foboci.irp.f
View File

@ -332,20 +332,20 @@ subroutine save_osoci_natural_mos
enddo enddo
tmp = tmp_bis tmp = tmp_bis
!! Symetrization act-virt !!! Symetrization act-virt
do j = 1, n_virt_orb ! do j = 1, n_virt_orb
j_virt= list_virt(j) ! j_virt= list_virt(j)
accu = 0.d0 ! accu = 0.d0
do i = 1, n_act_orb ! do i = 1, n_act_orb
jorb = list_act(i) ! jorb = list_act(i)
accu += dabs(tmp_bis(j_virt,jorb)) ! accu += dabs(tmp_bis(j_virt,jorb))
enddo ! enddo
do i = 1, n_act_orb ! do i = 1, n_act_orb
iorb = list_act(i) ! iorb = list_act(i)
tmp(j_virt,iorb) = dsign(accu/dble(n_act_orb),tmp_bis(j_virt,iorb)) ! tmp(j_virt,iorb) = dsign(accu/dble(n_act_orb),tmp_bis(j_virt,iorb))
tmp(iorb,j_virt) = dsign(accu/dble(n_act_orb),tmp_bis(j_virt,iorb)) ! tmp(iorb,j_virt) = dsign(accu/dble(n_act_orb),tmp_bis(j_virt,iorb))
enddo ! enddo
enddo ! enddo
!! Symetrization act-inact !! Symetrization act-inact
!do j = 1, n_inact_orb !do j = 1, n_inact_orb
@ -387,16 +387,16 @@ subroutine save_osoci_natural_mos
print*,'ACTIVE ORBITAL ',iorb print*,'ACTIVE ORBITAL ',iorb
do j = 1, n_inact_orb do j = 1, n_inact_orb
jorb = list_inact(j) jorb = list_inact(j)
if(dabs(tmp(iorb,jorb)).gt.threshold_singles)then if(dabs(tmp(iorb,jorb)).gt.threshold_lmct)then
print*,'INACTIVE ' print*,'INACTIVE '
print*,'DM ',iorb,jorb,dabs(tmp(iorb,jorb)) print*,'DM ',iorb,jorb,(tmp(iorb,jorb))
endif endif
enddo enddo
do j = 1, n_virt_orb do j = 1, n_virt_orb
jorb = list_virt(j) jorb = list_virt(j)
if(dabs(tmp(iorb,jorb)).gt.threshold_singles)then if(dabs(tmp(iorb,jorb)).gt.threshold_mlct)then
print*,'VIRT ' print*,'VIRT '
print*,'DM ',iorb,jorb,dabs(tmp(iorb,jorb)) print*,'DM ',iorb,jorb,(tmp(iorb,jorb))
endif endif
enddo enddo
enddo enddo
@ -410,8 +410,9 @@ subroutine save_osoci_natural_mos
enddo enddo
label = "Natural" label = "Natural"
call mo_as_eigvectors_of_mo_matrix(tmp,size(tmp,1),size(tmp,2),label,1) call mo_as_eigvectors_of_mo_matrix(tmp,size(tmp,1),size(tmp,2),label,1)
soft_touch mo_coef !soft_touch mo_coef
deallocate(tmp,occ) deallocate(tmp,occ)
@ -518,16 +519,16 @@ subroutine set_osoci_natural_mos
print*,'ACTIVE ORBITAL ',iorb print*,'ACTIVE ORBITAL ',iorb
do j = 1, n_inact_orb do j = 1, n_inact_orb
jorb = list_inact(j) jorb = list_inact(j)
if(dabs(tmp(iorb,jorb)).gt.threshold_singles)then if(dabs(tmp(iorb,jorb)).gt.threshold_lmct)then
print*,'INACTIVE ' print*,'INACTIVE '
print*,'DM ',iorb,jorb,dabs(tmp(iorb,jorb)) print*,'DM ',iorb,jorb,(tmp(iorb,jorb))
endif endif
enddo enddo
do j = 1, n_virt_orb do j = 1, n_virt_orb
jorb = list_virt(j) jorb = list_virt(j)
if(dabs(tmp(iorb,jorb)).gt.threshold_singles)then if(dabs(tmp(iorb,jorb)).gt.threshold_mlct)then
print*,'VIRT ' print*,'VIRT '
print*,'DM ',iorb,jorb,dabs(tmp(iorb,jorb)) print*,'DM ',iorb,jorb,(tmp(iorb,jorb))
endif endif
enddo enddo
enddo enddo
@ -602,15 +603,210 @@ end
subroutine provide_properties subroutine provide_properties
implicit none implicit none
integer :: i call print_mulliken_sd
double precision :: accu call print_hcc
if(.True.)then
accu= 0.d0
do i = 1, nucl_num
accu += mulliken_spin_densities(i)
print*,i,nucl_charge(i),mulliken_spin_densities(i)
enddo
print*,'Sum of Mulliken SD = ',accu
endif
end end
subroutine dress_diag_elem_2h1p(dressing_H_mat_elem,ndet,lmct,i_hole)
use bitmasks
double precision, intent(inout) :: dressing_H_mat_elem(Ndet)
integer, intent(in) :: ndet,i_hole
logical, intent(in) :: lmct
! if lmct = .True. ===> LMCT
! else ===> MLCT
implicit none
integer :: i
integer :: n_p,n_h,number_of_holes,number_of_particles
integer :: exc(0:2,2,2)
integer :: degree
double precision :: phase
integer :: h1,h2,p1,p2,s1,s2
do i = 1, N_det
n_h = number_of_holes(psi_det(1,1,i))
n_p = number_of_particles(psi_det(1,1,i))
call get_excitation(ref_bitmask,psi_det(1,1,i),exc,degree,phase,N_int)
call decode_exc(exc,degree,h1,p1,h2,p2,s1,s2)
if (n_h == 0.and.n_p==0)then ! CAS
dressing_H_mat_elem(i)+= total_corr_e_2h1p
if(lmct)then
dressing_H_mat_elem(i) += - corr_energy_2h1p_per_orb_ab(i_hole) - corr_energy_2h1p_per_orb_bb(i_hole)
endif
endif
if (n_h == 1.and.n_p==0)then ! 1h
dressing_H_mat_elem(i)+= 0.d0
else if (n_h == 0.and.n_p==1)then ! 1p
dressing_H_mat_elem(i)+= total_corr_e_2h1p
dressing_H_mat_elem(i) += - corr_energy_2h1p_per_orb_ab(p1) - corr_energy_2h1p_per_orb_aa(p1)
else if (n_h == 1.and.n_p==1)then ! 1h1p
! if(degree==1)then
dressing_H_mat_elem(i)+= total_corr_e_2h1p
dressing_H_mat_elem(i)+= - corr_energy_2h1p_per_orb_ab(h1)
! else
! dressing_H_mat_elem(i) += - corr_energy_2h2p_per_orb_ab(h1) &
! - 0.5d0 * (corr_energy_2h2p_per_orb_aa(h1) + corr_energy_2h2p_per_orb_bb(h1))
! dressing_H_mat_elem(i) += - corr_energy_2h2p_per_orb_ab(p2) &
! - 0.5d0 * (corr_energy_2h2p_per_orb_aa(p2) + corr_energy_2h2p_per_orb_bb(p2))
! dressing_H_mat_elem(i) += 0.5d0 * (corr_energy_2h2p_for_1h1p_double(h1,p1))
! endif
else if (n_h == 2.and.n_p==1)then ! 2h1p
dressing_H_mat_elem(i)+= 0.d0
else if (n_h == 1.and.n_p==2)then ! 1h2p
dressing_H_mat_elem(i)+= total_corr_e_2h1p
dressing_H_mat_elem(i) += - corr_energy_2h1p_per_orb_ab(h1)
endif
enddo
end
subroutine dress_diag_elem_1h2p(dressing_H_mat_elem,ndet,lmct,i_hole)
use bitmasks
double precision, intent(inout) :: dressing_H_mat_elem(Ndet)
integer, intent(in) :: ndet,i_hole
logical, intent(in) :: lmct
! if lmct = .True. ===> LMCT
! else ===> MLCT
implicit none
integer :: i
integer :: n_p,n_h,number_of_holes,number_of_particles
integer :: exc(0:2,2,2)
integer :: degree
double precision :: phase
integer :: h1,h2,p1,p2,s1,s2
do i = 1, N_det
n_h = number_of_holes(psi_det(1,1,i))
n_p = number_of_particles(psi_det(1,1,i))
call get_excitation(ref_bitmask,psi_det(1,1,i),exc,degree,phase,N_int)
call decode_exc(exc,degree,h1,p1,h2,p2,s1,s2)
if (n_h == 0.and.n_p==0)then ! CAS
dressing_H_mat_elem(i)+= total_corr_e_1h2p
if(.not.lmct)then
dressing_H_mat_elem(i) += - corr_energy_1h2p_per_orb_ab(i_hole) - corr_energy_1h2p_per_orb_aa(i_hole)
endif
endif
if (n_h == 1.and.n_p==0)then ! 1h
dressing_H_mat_elem(i)+= total_corr_e_1h2p - corr_energy_1h2p_per_orb_ab(h1)
else if (n_h == 0.and.n_p==1)then ! 1p
dressing_H_mat_elem(i)+= 0.d0
else if (n_h == 1.and.n_p==1)then ! 1h1p
if(degree==1)then
dressing_H_mat_elem(i)+= total_corr_e_1h2p
dressing_H_mat_elem(i)+= - corr_energy_1h2p_per_orb_ab(h1)
else
dressing_H_mat_elem(i) +=0.d0
endif
! dressing_H_mat_elem(i) += - corr_energy_2h2p_per_orb_ab(h1) &
! - 0.5d0 * (corr_energy_2h2p_per_orb_aa(h1) + corr_energy_2h2p_per_orb_bb(h1))
! dressing_H_mat_elem(i) += - corr_energy_2h2p_per_orb_ab(p2) &
! - 0.5d0 * (corr_energy_2h2p_per_orb_aa(p2) + corr_energy_2h2p_per_orb_bb(p2))
! dressing_H_mat_elem(i) += 0.5d0 * (corr_energy_2h2p_for_1h1p_double(h1,p1))
! endif
else if (n_h == 2.and.n_p==1)then ! 2h1p
dressing_H_mat_elem(i)+= total_corr_e_1h2p
dressing_H_mat_elem(i)+= - corr_energy_1h2p_per_orb_ab(h1) - corr_energy_1h2p_per_orb_ab(h1)
else if (n_h == 1.and.n_p==2)then ! 1h2p
dressing_H_mat_elem(i) += 0.d0
endif
enddo
end
subroutine dress_diag_elem_2h2p(dressing_H_mat_elem,ndet)
use bitmasks
double precision, intent(inout) :: dressing_H_mat_elem(Ndet)
integer, intent(in) :: ndet
implicit none
integer :: i
integer :: n_p,n_h,number_of_holes,number_of_particles
integer :: exc(0:2,2,2)
integer :: degree
double precision :: phase
integer :: h1,h2,p1,p2,s1,s2
do i = 1, N_det
dressing_H_mat_elem(i)+= total_corr_e_2h2p
n_h = number_of_holes(psi_det(1,1,i))
n_p = number_of_particles(psi_det(1,1,i))
call get_excitation(ref_bitmask,psi_det(1,1,i),exc,degree,phase,N_int)
call decode_exc(exc,degree,h1,p1,h2,p2,s1,s2)
if (n_h == 1.and.n_p==0)then ! 1h
dressing_H_mat_elem(i) += - corr_energy_2h2p_per_orb_ab(h1) &
- 0.5d0 * (corr_energy_2h2p_per_orb_aa(h1) + corr_energy_2h2p_per_orb_bb(h1))
else if (n_h == 0.and.n_p==1)then ! 1p
dressing_H_mat_elem(i) += - corr_energy_2h2p_per_orb_ab(p1) &
- 0.5d0 * (corr_energy_2h2p_per_orb_aa(p1) + corr_energy_2h2p_per_orb_bb(p1))
else if (n_h == 1.and.n_p==1)then ! 1h1p
if(degree==1)then
dressing_H_mat_elem(i) += - corr_energy_2h2p_per_orb_ab(h1) &
- 0.5d0 * (corr_energy_2h2p_per_orb_aa(h1) + corr_energy_2h2p_per_orb_bb(h1))
dressing_H_mat_elem(i) += - corr_energy_2h2p_per_orb_ab(p1) &
- 0.5d0 * (corr_energy_2h2p_per_orb_aa(p1) + corr_energy_2h2p_per_orb_bb(p1))
dressing_H_mat_elem(i) += 0.5d0 * (corr_energy_2h2p_for_1h1p_a(h1,p1) + corr_energy_2h2p_for_1h1p_b(h1,p1))
else
dressing_H_mat_elem(i) += - corr_energy_2h2p_per_orb_ab(h1) &
- 0.5d0 * (corr_energy_2h2p_per_orb_aa(h1) + corr_energy_2h2p_per_orb_bb(h1))
dressing_H_mat_elem(i) += - corr_energy_2h2p_per_orb_ab(p2) &
- 0.5d0 * (corr_energy_2h2p_per_orb_aa(p2) + corr_energy_2h2p_per_orb_bb(p2))
dressing_H_mat_elem(i) += 0.5d0 * (corr_energy_2h2p_for_1h1p_double(h1,p1))
endif
else if (n_h == 2.and.n_p==1)then ! 2h1p
dressing_H_mat_elem(i) += - corr_energy_2h2p_per_orb_ab(h1) - corr_energy_2h2p_per_orb_bb(h1) &
- corr_energy_2h2p_per_orb_ab(h2) &
- 0.5d0 * ( corr_energy_2h2p_per_orb_bb(h2) + corr_energy_2h2p_per_orb_bb(h2))
dressing_H_mat_elem(i) += - corr_energy_2h2p_per_orb_ab(p1)
if(s1.ne.s2)then
dressing_H_mat_elem(i) += corr_energy_2h2p_ab_2_orb(h1,h2)
else
dressing_H_mat_elem(i) += corr_energy_2h2p_bb_2_orb(h1,h2)
endif
else if (n_h == 1.and.n_p==2)then ! 1h2p
dressing_H_mat_elem(i) += - corr_energy_2h2p_per_orb_ab(h1) &
- 0.5d0 * (corr_energy_2h2p_per_orb_aa(h1) + corr_energy_2h2p_per_orb_bb(h1))
dressing_H_mat_elem(i) += - corr_energy_2h2p_per_orb_ab(p1) &
- 0.5d0 * (corr_energy_2h2p_per_orb_aa(p1) + corr_energy_2h2p_per_orb_bb(p1))
dressing_H_mat_elem(i) += - corr_energy_2h2p_per_orb_ab(p2) &
- 0.5d0 * (corr_energy_2h2p_per_orb_aa(p2) + corr_energy_2h2p_per_orb_bb(p2))
if(s1.ne.s2)then
dressing_H_mat_elem(i) += corr_energy_2h2p_ab_2_orb(p1,p2)
else
dressing_H_mat_elem(i) += corr_energy_2h2p_bb_2_orb(p1,p2)
endif
endif
enddo
end
subroutine diag_dressed_2h2p_hamiltonian_and_update_psi_det(i_hole,lmct)
implicit none
double precision, allocatable :: dressing_H_mat_elem(:),energies(:)
integer, intent(in) :: i_hole
logical, intent(in) :: lmct
! if lmct = .True. ===> LMCT
! else ===> MLCT
integer :: i
double precision :: hij
allocate(dressing_H_mat_elem(N_det),energies(N_states_diag))
print*,''
print*,'dressing with the 2h2p in a CC logic'
print*,''
do i = 1, N_det
call i_h_j(psi_det(1,1,i),psi_det(1,1,i),N_int,hij)
dressing_H_mat_elem(i) = hij
enddo
call dress_diag_elem_2h2p(dressing_H_mat_elem,N_det)
call dress_diag_elem_2h1p(dressing_H_mat_elem,N_det,lmct,i_hole)
call dress_diag_elem_1h2p(dressing_H_mat_elem,N_det,lmct,i_hole)
call davidson_diag_hjj(psi_det,psi_coef,dressing_H_mat_elem,energies,size(psi_coef,1),N_det,N_states_diag,N_int,output_determinants)
do i = 1, 2
print*,'psi_coef = ',psi_coef(i,1)
enddo
deallocate(dressing_H_mat_elem)
end

5
plugins/Full_CI/H_apply.irp.f
View File

@ -7,6 +7,11 @@ s.set_selection_pt2("epstein_nesbet_2x2")
#s.unset_openmp() #s.unset_openmp()
print s print s
#s = H_apply("FCI_PT2")
#s.set_perturbation("epstein_nesbet_2x2")
#s.unset_openmp()
#print s
s = H_apply_zmq("FCI_PT2") s = H_apply_zmq("FCI_PT2")
s.set_perturbation("epstein_nesbet_2x2") s.set_perturbation("epstein_nesbet_2x2")
s.unset_openmp() s.unset_openmp()

6
plugins/Full_CI/micro_pt2.irp.f
View File

@ -24,8 +24,12 @@ subroutine run_wf
integer(ZMQ_PTR) :: zmq_to_qp_run_socket integer(ZMQ_PTR) :: zmq_to_qp_run_socket
print *, 'Getting wave function' print *, 'Getting wave function'
zmq_context = f77_zmq_ctx_new ()
zmq_to_qp_run_socket = new_zmq_to_qp_run_socket() zmq_to_qp_run_socket = new_zmq_to_qp_run_socket()
! TODO : do loop here
! TODO : wait_state
call zmq_get_psi(zmq_to_qp_run_socket, 1) call zmq_get_psi(zmq_to_qp_run_socket, 1)
call write_double(6,ci_energy,'Energy') call write_double(6,ci_energy,'Energy')
zmq_state = 'h_apply_fci_pt2' zmq_state = 'h_apply_fci_pt2'
@ -33,6 +37,8 @@ subroutine run_wf
call provide_everything call provide_everything
integer :: rc, i integer :: rc, i
print *, 'Contribution to PT2 running'
!$OMP PARALLEL PRIVATE(i) !$OMP PARALLEL PRIVATE(i)
i = omp_get_thread_num() i = omp_get_thread_num()
call H_apply_FCI_PT2_slave_tcp(i) call H_apply_FCI_PT2_slave_tcp(i)

5
plugins/Full_CI/var_pt2_ratio.irp.f
View File

@ -11,7 +11,7 @@ program var_pt2_ratio_run
double precision, allocatable :: psi_det_save(:,:,:), psi_coef_save(:,:) double precision, allocatable :: psi_det_save(:,:,:), psi_coef_save(:,:)
double precision :: E_fci, E_var, ratio, E_ref double precision :: E_fci, E_var, ratio, E_ref, selection_criterion_save
integer :: Nmin, Nmax integer :: Nmin, Nmax
pt2 = 1.d0 pt2 = 1.d0
@ -30,6 +30,7 @@ program var_pt2_ratio_run
threshold_selectors = 1.d0 threshold_selectors = 1.d0
threshold_generators = 0.999d0 threshold_generators = 0.999d0
selection_criterion_save = selection_criterion
call diagonalize_CI call diagonalize_CI
call H_apply_FCI_PT2(pt2, norm_pert, H_pert_diag, N_st) call H_apply_FCI_PT2(pt2, norm_pert, H_pert_diag, N_st)
E_ref = CI_energy(1) + pt2(1) E_ref = CI_energy(1) + pt2(1)
@ -46,6 +47,8 @@ program var_pt2_ratio_run
Nmax = max(Nmax,Nmin+10) Nmax = max(Nmax,Nmin+10)
! Select new determinants ! Select new determinants
call H_apply_FCI(pt2, norm_pert, H_pert_diag, N_st) call H_apply_FCI(pt2, norm_pert, H_pert_diag, N_st)
selection_criterion = selection_criterion_save
SOFT_TOUCH selection_criterion selection_criterion_min selection_criterion_factor
else else
Nmax = N_det Nmax = N_det
N_det = Nmin + (Nmax-Nmin)/2 N_det = Nmin + (Nmax-Nmin)/2

45
plugins/Full_CI_ZMQ/fci_zmq.irp.f
View File

@ -1,3 +1,4 @@
<<<<<<< HEAD
program fci_zmq program fci_zmq
@ -270,3 +271,47 @@ end
! end do ! end do
! !
! end ! end
=======
program Full_CI_ZMQ
use f77_zmq
implicit none
BEGIN_DOC
! Massively parallel Full-CI
END_DOC
integer :: i,ithread
integer(ZMQ_PTR) :: zmq_socket_push
integer(ZMQ_PTR) :: new_zmq_push_socket
zmq_context = f77_zmq_ctx_new ()
PROVIDE nproc
!$OMP PARALLEL PRIVATE(i,ithread,zmq_socket_push) num_threads(nproc+1)
ithread = omp_get_thread_num()
if (ithread == 0) then
call receive_selected_determinants()
else
zmq_socket_push = new_zmq_push_socket()
do i=ithread,N_det_generators,nproc
print *, i , N_det_generators
!$OMP TASK DEFAULT(SHARED)
call select_connected(i, 1.d-6, ci_electronic_energy,zmq_socket_push)
!$OMP END TASK
enddo
!$OMP TASKWAIT
if (ithread == 1) then
integer :: rc
rc = f77_zmq_send(zmq_socket_push,0,1,0)
if (rc /= 1) then
stop 'Error sending termination signal'
endif
endif
call end_zmq_push_socket(zmq_socket_push)
endif
!$OMP END PARALLEL
end
>>>>>>> e681b7c37d564071ada2146699aa5013655cf8ab

28
plugins/Generators_restart/generators.irp.f
View File

@ -1,5 +1,5 @@
use bitmasks use bitmasks
BEGIN_PROVIDER [ integer, N_det_generators ] BEGIN_PROVIDER [ integer, N_det_generators ]
implicit none implicit none
BEGIN_DOC BEGIN_DOC
@ -8,17 +8,18 @@ BEGIN_PROVIDER [ integer, N_det_generators ]
integer :: i integer :: i
integer, save :: ifirst = 0 integer, save :: ifirst = 0
double precision :: norm double precision :: norm
read_wf = .True.
if(ifirst == 0)then if(ifirst == 0)then
N_det_generators = N_det call ezfio_get_determinants_n_det(N_det_generators)
ifirst = 1 ifirst = 1
else
print*,'PB in generators restart !!!'
endif endif
call write_int(output_determinants,N_det_generators,'Number of generators') call write_int(output_determinants,N_det_generators,'Number of generators')
END_PROVIDER END_PROVIDER
BEGIN_PROVIDER [ integer(bit_kind), psi_det_generators, (N_int,2,psi_det_size) ] BEGIN_PROVIDER [ integer(bit_kind), psi_det_generators, (N_int,2,N_det_generators) ]
&BEGIN_PROVIDER [ double precision, psi_coef_generators, (psi_det_size,N_states) ] &BEGIN_PROVIDER [ double precision, psi_coef_generators, (N_det_generators,N_states) ]
implicit none implicit none
BEGIN_DOC BEGIN_DOC
! read wf ! read wf
@ -26,17 +27,20 @@ END_PROVIDER
END_DOC END_DOC
integer :: i, k integer :: i, k
integer, save :: ifirst = 0 integer, save :: ifirst = 0
double precision, allocatable :: psi_coef_read(:,:)
if(ifirst == 0)then if(ifirst == 0)then
do i=1,N_det_generators call read_dets(psi_det_generators,N_int,N_det_generators)
do k=1,N_int allocate (psi_coef_read(N_det_generators,N_states))
psi_det_generators(k,1,i) = psi_det(k,1,i) call ezfio_get_determinants_psi_coef(psi_coef_read)
psi_det_generators(k,2,i) = psi_det(k,2,i)
enddo
do k = 1, N_states do k = 1, N_states
psi_coef_generators(i,k) = psi_coef(i,k) do i = 1, N_det_generators
psi_coef_generators(i,k) = psi_coef_read(i,k)
enddo
enddo enddo
enddo
ifirst = 1 ifirst = 1
deallocate(psi_coef_read)
else
print*,'PB in generators restart !!!'
endif endif
END_PROVIDER END_PROVIDER

1
plugins/Hartree_Fock/Fock_matrix.irp.f
View File

@ -223,6 +223,7 @@ END_PROVIDER
ao_bi_elec_integral_beta_tmp = 0.d0 ao_bi_elec_integral_beta_tmp = 0.d0
!$OMP DO SCHEDULE(dynamic) !$OMP DO SCHEDULE(dynamic)
!DIR$ NOVECTOR
do i8=0_8,ao_integrals_map%map_size do i8=0_8,ao_integrals_map%map_size
n_elements = n_elements_max n_elements = n_elements_max
call get_cache_map(ao_integrals_map,i8,keys,values,n_elements) call get_cache_map(ao_integrals_map,i8,keys,values,n_elements)

6
plugins/Hartree_Fock/damping_SCF.irp.f
View File

@ -96,7 +96,7 @@ subroutine damping_SCF
a = (E_new + E - 2.d0*E_half)*2.d0 a = (E_new + E - 2.d0*E_half)*2.d0
b = -E_new - 3.d0*E + 4.d0*E_half b = -E_new - 3.d0*E + 4.d0*E_half
lambda = -lambda*b/a lambda = -lambda*b/(a+1.d-16)
D_alpha = (1.d0-lambda) * D_alpha + lambda * D_new_alpha D_alpha = (1.d0-lambda) * D_alpha + lambda * D_new_alpha
D_beta = (1.d0-lambda) * D_beta + lambda * D_new_beta D_beta = (1.d0-lambda) * D_beta + lambda * D_new_beta
delta_E = HF_energy - E delta_E = HF_energy - E
@ -119,7 +119,9 @@ subroutine damping_SCF
write(output_hartree_fock,'(A4,1X,A16, 1X, A16, 1X, A16, 1X, A4 )') '====','================','================','================', '====' write(output_hartree_fock,'(A4,1X,A16, 1X, A16, 1X, A16, 1X, A4 )') '====','================','================','================', '===='
write(output_hartree_fock,*) write(output_hartree_fock,*)
call mo_as_eigvectors_of_mo_matrix(Fock_matrix_mo,size(Fock_matrix_mo,1),size(Fock_matrix_mo,2),mo_label,1) if(.not.no_oa_or_av_opt)then
call mo_as_eigvectors_of_mo_matrix(Fock_matrix_mo,size(Fock_matrix_mo,1),size(Fock_matrix_mo,2),mo_label,1)
endif
call write_double(output_hartree_fock, E_min, 'Hartree-Fock energy') call write_double(output_hartree_fock, E_min, 'Hartree-Fock energy')
call ezfio_set_hartree_fock_energy(E_min) call ezfio_set_hartree_fock_energy(E_min)

13
plugins/MRCC_CASSD/mrcc_cassd.irp.f
View File

@ -65,8 +65,17 @@ subroutine run_pt2(N_st,energy)
threshold_selectors = 1.d0 threshold_selectors = 1.d0
threshold_generators = 0.999d0 threshold_generators = 0.999d0
N_det_generators = lambda_mrcc_pt2(0) N_det_generators = lambda_mrcc_pt2(0) + N_det_cas
do i=1,N_det_generators do i=1,N_det_cas
do k=1,N_int
psi_det_generators(k,1,i) = psi_ref(k,1,i)
psi_det_generators(k,2,i) = psi_ref(k,2,i)
enddo
do k=1,N_st
psi_coef_generators(i,k) = psi_ref_coef(i,k)
enddo
enddo
do i=N_det_cas+1,N_det_generators
j = lambda_mrcc_pt2(i) j = lambda_mrcc_pt2(i)
do k=1,N_int do k=1,N_int
psi_det_generators(k,1,i) = psi_non_ref(k,1,j) psi_det_generators(k,1,i) = psi_non_ref(k,1,j)

2
plugins/MRCC_Utils/H_apply.irp.f
View File

@ -25,7 +25,7 @@ print s
s = H_apply_zmq("mrcc_PT2") s = H_apply("mrcc_PT2")
s.energy = "ci_electronic_energy_dressed" s.energy = "ci_electronic_energy_dressed"
s.set_perturbation("epstein_nesbet_2x2") s.set_perturbation("epstein_nesbet_2x2")
s.unset_openmp() s.unset_openmp()

356
plugins/MRCC_Utils/mrcc_utils.irp.f
View File

@ -1,93 +1,11 @@
use bitmasks use bitmasks
BEGIN_PROVIDER [ integer, mrmode ] BEGIN_PROVIDER [ integer, mrmode ]
&BEGIN_PROVIDER [ logical, old_lambda ]
&BEGIN_PROVIDER [ logical, no_mono_dressing ]
implicit none
CHARACTER(len=255) :: test
CALL get_environment_variable("OLD_LAMBDA", test)
old_lambda = trim(test) /= "" .and. trim(test) /= "0"
CALL get_environment_variable("NO_MONO_DRESSING", test)
no_mono_dressing = trim(test) /= "" .and. trim(test) /= "0"
print *, "old", old_lambda, "mono", no_mono_dressing
mrmode = 0 mrmode = 0
END_PROVIDER END_PROVIDER
BEGIN_PROVIDER [ double precision, lambda_mrcc, (N_states, N_det_non_ref) ]
BEGIN_PROVIDER [ double precision, lambda_mrcc_old, (N_states,psi_det_size) ]
&BEGIN_PROVIDER [ integer, lambda_mrcc_pt2_old, (0:psi_det_size) ]
&BEGIN_PROVIDER [ integer, lambda_mrcc_pt3_old, (0:psi_det_size) ]
implicit none
BEGIN_DOC
cm/<Psi_0|H|D_m> or perturbative 1/Delta_E(m)
END_DOC
integer :: i,k
double precision :: ihpsi_current(N_states)
integer :: i_pert_count
double precision :: hii, lambda_pert
integer :: N_lambda_mrcc_pt2, N_lambda_mrcc_pt3
double precision, parameter :: x = 2.d0
double precision :: nurm
i_pert_count = 0
lambda_mrcc_old = 0.d0
N_lambda_mrcc_pt2 = 0
N_lambda_mrcc_pt3 = 0
lambda_mrcc_pt2_old(0) = 0
lambda_mrcc_pt3_old(0) = 0
if(N_states > 1) stop "old lambda N_states == 1"
nurm = 0d0
do i=1,N_det_ref
nurm += psi_ref_coef(i,1)**2
end do
do i=1,N_det_non_ref
call i_h_psi(psi_non_ref(1,1,i), psi_ref, psi_ref_coef, N_int, N_det_ref, &
size(psi_ref_coef,1), N_states,ihpsi_current)
call i_H_j(psi_non_ref(1,1,i),psi_non_ref(1,1,i),N_int,hii)
do k=1,N_states
if (ihpsi_current(k) == 0.d0) then
ihpsi_current(k) = 1.d-32
endif
lambda_mrcc_old(k,i) = psi_non_ref_coef(i,k)/ihpsi_current(k)
!if ( dabs(psi_non_ref_coef(i,k)*ihpsi_current(k)) < 1.d-5 .or. lambda_mrcc_old(k,i) > 0d0) then
if ( dabs(ihpsi_current(k))*sqrt(psi_non_ref_coef(i,k)**2 / nurm) < 1.d-5 .or. lambda_mrcc_old(k,i) > 0d0) then
i_pert_count += 1
lambda_mrcc_old(k,i) = 0.d0
if (lambda_mrcc_pt2_old(N_lambda_mrcc_pt2) /= i) then
N_lambda_mrcc_pt2 += 1
lambda_mrcc_pt2_old(N_lambda_mrcc_pt2) = i
endif
else
if (lambda_mrcc_pt3_old(N_lambda_mrcc_pt3) /= i) then
N_lambda_mrcc_pt3 += 1
lambda_mrcc_pt3_old(N_lambda_mrcc_pt3) = i
endif
endif
! lambda_pert = 1.d0 / (psi_ref_energy_diagonalized(k)-hii)
! if((ihpsi_current(k) * lambda_pert) < 0.5d0 * psi_non_ref_coef_restart(i,k) ) then
! lambda_mrcc_old(k,i) = 0.d0
! endif
if (lambda_mrcc_old(k,i) > x) then
lambda_mrcc_old(k,i) = x
else if (lambda_mrcc_old(k,i) < -x) then
lambda_mrcc_old(k,i) = -x
endif
enddo
enddo
lambda_mrcc_pt2_old(0) = N_lambda_mrcc_pt2
lambda_mrcc_pt3_old(0) = N_lambda_mrcc_pt3
print*,'N_det_non_ref = ',N_det_non_ref
print*,'Number of ignored determinants = ',i_pert_count
print*,'psi_coef_ref_ratio = ',psi_ref_coef(2,1)/psi_ref_coef(1,1)
print*,'lambda min/max = ',maxval(dabs(lambda_mrcc_old)), minval(dabs(lambda_mrcc_old))
END_PROVIDER
BEGIN_PROVIDER [ double precision, lambda_mrcc, (N_states,psi_det_size) ]
&BEGIN_PROVIDER [ integer, lambda_mrcc_pt2, (0:psi_det_size) ] &BEGIN_PROVIDER [ integer, lambda_mrcc_pt2, (0:psi_det_size) ]
&BEGIN_PROVIDER [ integer, lambda_mrcc_pt3, (0:psi_det_size) ] &BEGIN_PROVIDER [ integer, lambda_mrcc_pt3, (0:psi_det_size) ]
implicit none implicit none
@ -99,49 +17,41 @@ END_PROVIDER
integer :: i_pert_count integer :: i_pert_count
double precision :: hii, lambda_pert double precision :: hii, lambda_pert
integer :: N_lambda_mrcc_pt2, N_lambda_mrcc_pt3 integer :: N_lambda_mrcc_pt2, N_lambda_mrcc_pt3
integer :: histo(200), j
histo = 0
if(old_lambda) then i_pert_count = 0
lambda_mrcc = lambda_mrcc_old lambda_mrcc = 0.d0
lambda_mrcc_pt2 = lambda_mrcc_pt2_old N_lambda_mrcc_pt2 = 0
lambda_mrcc_pt3 = lambda_mrcc_pt3_old N_lambda_mrcc_pt3 = 0
else lambda_mrcc_pt2(0) = 0
i_pert_count = 0 lambda_mrcc_pt3(0) = 0
lambda_mrcc = 0.d0
N_lambda_mrcc_pt2 = 0
N_lambda_mrcc_pt3 = 0
lambda_mrcc_pt2(0) = 0
lambda_mrcc_pt3(0) = 0
do i=1,N_det_non_ref do i=1,N_det_non_ref
call i_h_psi(psi_non_ref(1,1,i), psi_ref, psi_ref_coef, N_int, N_det_ref,& call i_h_psi(psi_non_ref(1,1,i), psi_ref, psi_ref_coef, N_int, N_det_ref,&
size(psi_ref_coef,1), N_states,ihpsi_current) size(psi_ref_coef,1), N_states,ihpsi_current)
call i_H_j(psi_non_ref(1,1,i),psi_non_ref(1,1,i),N_int,hii) call i_H_j(psi_non_ref(1,1,i),psi_non_ref(1,1,i),N_int,hii)
do k=1,N_states do k=1,N_states
if (ihpsi_current(k) == 0.d0) then if (ihpsi_current(k) == 0.d0) then
ihpsi_current(k) = 1.d-32 ihpsi_current(k) = 1.d-32
endif
lambda_mrcc(k,i) = min(-1.d-32,psi_non_ref_coef(i,k)/ihpsi_current(k) )
lambda_pert = 1.d0 / (psi_ref_energy_diagonalized(k)-hii)
if (lambda_pert / lambda_mrcc(k,i) < 0.5d0) then
i_pert_count += 1
lambda_mrcc(k,i) = 0.d0
if (lambda_mrcc_pt2(N_lambda_mrcc_pt2) /= i) then
N_lambda_mrcc_pt2 += 1
lambda_mrcc_pt2(N_lambda_mrcc_pt2) = i
endif endif
lambda_mrcc(k,i) = min(-1.d-32,psi_non_ref_coef(i,k)/ihpsi_current(k) ) else
lambda_pert = 1.d0 / (psi_ref_energy_diagonalized(k)-hii) if (lambda_mrcc_pt3(N_lambda_mrcc_pt3) /= i) then
if (lambda_pert / lambda_mrcc(k,i) < 0.5d0) then N_lambda_mrcc_pt3 += 1
i_pert_count += 1 lambda_mrcc_pt3(N_lambda_mrcc_pt3) = i
lambda_mrcc(k,i) = 0.d0
if (lambda_mrcc_pt2(N_lambda_mrcc_pt2) /= i) then
N_lambda_mrcc_pt2 += 1
lambda_mrcc_pt2(N_lambda_mrcc_pt2) = i
endif
else
if (lambda_mrcc_pt3(N_lambda_mrcc_pt3) /= i) then
N_lambda_mrcc_pt3 += 1
lambda_mrcc_pt3(N_lambda_mrcc_pt3) = i
endif
endif endif
enddo endif
enddo enddo
lambda_mrcc_pt2(0) = N_lambda_mrcc_pt2 enddo
lambda_mrcc_pt3(0) = N_lambda_mrcc_pt3 lambda_mrcc_pt2(0) = N_lambda_mrcc_pt2
end if lambda_mrcc_pt3(0) = N_lambda_mrcc_pt3
print*,'N_det_non_ref = ',N_det_non_ref print*,'N_det_non_ref = ',N_det_non_ref
print*,'psi_coef_ref_ratio = ',psi_ref_coef(2,1)/psi_ref_coef(1,1) print*,'psi_coef_ref_ratio = ',psi_ref_coef(2,1)/psi_ref_coef(1,1)
print*,'lambda max = ',maxval(dabs(lambda_mrcc)) print*,'lambda max = ',maxval(dabs(lambda_mrcc))
@ -149,44 +59,6 @@ END_PROVIDER
END_PROVIDER END_PROVIDER
! BEGIN_PROVIDER [ double precision, lambda_mrcc, (N_states,psi_det_size) ]
! &BEGIN_PROVIDER [ integer, lambda_mrcc_pt2, (0:psi_det_size) ]
! &BEGIN_PROVIDER [ integer, lambda_mrcc_pt3, (0:psi_det_size) ]
! implicit none
! BEGIN_DOC
! ! cm/<Psi_0|H|D_m> or perturbative 1/Delta_E(m)
! END_DOC
! integer :: i,ii,k
! double precision :: ihpsi_current(N_states)
! integer :: i_pert_count
! double precision :: hii, lambda_pert, phase
! integer :: N_lambda_mrcc_pt2, N_lambda_mrcc_pt3, degree
! integer :: exc(N_int, 2)
! histo = 0
!
! i_pert_count = 0
! lambda_mrcc = 0.d0
! N_lambda_mrcc_pt2 = 0
! N_lambda_mrcc_pt3 = 0
! lambda_mrcc_pt2(0) = 0
! lambda_mrcc_pt3(0) = 0
!
! do ii=1, N_det_ref
! do i=1,N_det_non_ref
! call get_excitation(psi_ref(1,1,II), psi_non_ref(1,1,i), exc, degree, phase, N_int)
! if(degree == -1) cycle
! call i_H_j(psi_non_ref(1,1,ii),psi_non_ref(1,1,i),N_int,hii)
!
!
! lambda_mrcc_pt2(0) = N_lambda_mrcc_pt2
! lambda_mrcc_pt3(0) = N_lambda_mrcc_pt3
!
! print*,'N_det_non_ref = ',N_det_non_ref
! print*,'psi_coef_ref_ratio = ',psi_ref_coef(2,1)/psi_ref_coef(1,1)
! print*,'lambda max = ',maxval(dabs(lambda_mrcc))
! print*,'Number of ignored determinants = ',i_pert_count
!
! END_PROVIDER
BEGIN_PROVIDER [ double precision, hij_mrcc, (N_det_non_ref,N_det_ref) ] BEGIN_PROVIDER [ double precision, hij_mrcc, (N_det_non_ref,N_det_ref) ]
@ -362,16 +234,6 @@ logical function is_generable(det1, det2, Nint)
return return
end if end if
if(degree > 2) stop "?22??" if(degree > 2) stop "?22??"
!!!!!
! call dec_exc(exc, h1, h2, p1, p2)
! f = searchExc(toutmoun(1,1), (/h1, h2, p1, p2/), hh_shortcut(hh_shortcut(0)+1)-1)
! !print *, toutmoun(:,1), hh_shortcut(hh_shortcut(0)+1)-1, (/h1, h2, p1, p2/)
! if(f /= -1) then
! is_generable = .true.
! if(.not. excEq(toutmoun(1,f), (/h1, h2, p1, p2/))) stop "????"
! end if
! ! print *, f
! return
call decode_exc_int2(exc,degree,h1,p1,h2,p2,s1,s2) call decode_exc_int2(exc,degree,h1,p1,h2,p2,s1,s2)
@ -680,10 +542,10 @@ END_PROVIDER
END_PROVIDER END_PROVIDER
BEGIN_PROVIDER [ double precision, dIj, (hh_shortcut(hh_shortcut(0)+1)-1) ] BEGIN_PROVIDER [ double precision, dIj_unique, (hh_shortcut(hh_shortcut(0)+1)-1, N_states) ]
implicit none implicit none
logical :: ok logical :: ok
integer :: i, j, k, II, pp, hh, ind, wk, nex, a_col, at_row integer :: i, j, k, s, II, pp, hh, ind, wk, nex, a_col, at_row
integer, external :: searchDet, unsortedSearchDet integer, external :: searchDet, unsortedSearchDet
integer(bit_kind) :: myDet(N_int, 2), myMask(N_int, 2) integer(bit_kind) :: myDet(N_int, 2), myMask(N_int, 2)
integer :: N, INFO, AtA_size, r1, r2 integer :: N, INFO, AtA_size, r1, r2
@ -691,22 +553,36 @@ BEGIN_PROVIDER [ double precision, dIj, (hh_shortcut(hh_shortcut(0)+1)-1) ]
double precision :: t, norm, cx double precision :: t, norm, cx
integer, allocatable :: A_ind(:,:), lref(:), AtA_ind(:), A_ind_mwen(:), col_shortcut(:), N_col(:) integer, allocatable :: A_ind(:,:), lref(:), AtA_ind(:), A_ind_mwen(:), col_shortcut(:), N_col(:)
if(n_states /= 1) stop "n_states /= 1"
nex = hh_shortcut(hh_shortcut(0)+1)-1 nex = hh_shortcut(hh_shortcut(0)+1)-1
print *, "TI", nex, N_det_non_ref print *, "TI", nex, N_det_non_ref
allocate(A_ind(N_det_ref+1, nex), A_val(N_det_ref+1, nex)) allocate(A_ind(N_det_ref+1, nex), A_val(N_det_ref+1, nex))
allocate(AtA_ind(N_det_ref * nex), AtA_val(N_det_ref * nex)) !!!!! MAY BE TOO SMALL !!!!!!!! allocate(AtA_ind(N_det_ref * nex), AtA_val(N_det_ref * nex)) !!!!! MAY BE TOO SMALL ? !!!!!!!!
allocate(x(nex), AtB(nex)) allocate(x(nex), AtB(nex))
allocate(A_val_mwen(nex), A_ind_mwen(nex)) allocate(A_val_mwen(nex), A_ind_mwen(nex))
allocate(N_col(nex), col_shortcut(nex), B(N_det_non_ref)) allocate(N_col(nex), col_shortcut(nex), B(N_det_non_ref))
allocate (x_new(nex))
do s = 1, N_states
A_val = 0d0 A_val = 0d0
A_ind = 0 A_ind = 0
AtA_ind = 0
AtA_val = 0d0
x = 0d0
AtB = 0d0
A_val_mwen = 0d0
A_ind_mwen = 0
N_col = 0
col_shortcut = 0
B = 0d0
x_new = 0d0
!$OMP PARALLEL DO schedule(static,10) default(none) shared(psi_non_ref, hh_exists, pp_exists, N_int, A_val, A_ind) & !$OMP PARALLEL DO schedule(static,10) default(none) shared(psi_non_ref, hh_exists, pp_exists, N_int, A_val, A_ind) &
!$OMP shared(hh_shortcut, psi_ref_coef, N_det_non_ref, psi_non_ref_sorted, psi_non_ref_sorted_idx, psi_ref, N_det_ref) & !$OMP shared(s, hh_shortcut, psi_ref_coef, N_det_non_ref, psi_non_ref_sorted, psi_non_ref_sorted_idx, psi_ref, N_det_ref) &
!$OMP private(lref, pp, II, ok, myMask, myDet, ind, wk) !$OMP private(lref, pp, II, ok, myMask, myDet, ind, wk)
do hh = 1, hh_shortcut(0) do hh = 1, hh_shortcut(0)
!print *, hh, "/", hh_shortcut(0)
do pp = hh_shortcut(hh), hh_shortcut(hh+1)-1 do pp = hh_shortcut(hh), hh_shortcut(hh+1)-1
allocate(lref(N_det_non_ref)) allocate(lref(N_det_non_ref))
lref = 0 lref = 0
@ -715,12 +591,8 @@ BEGIN_PROVIDER [ double precision, dIj, (hh_shortcut(hh_shortcut(0)+1)-1) ]
if(.not. ok) cycle if(.not. ok) cycle
call apply_particle(myMask, pp_exists(1, pp), myDet, ok, N_int) call apply_particle(myMask, pp_exists(1, pp), myDet, ok, N_int)
if(.not. ok) cycle if(.not. ok) cycle
!ind = unsortedSearchDet(psi_non_ref(1,1,1), myDet, N_det_non_ref, N_int)
ind = searchDet(psi_non_ref_sorted(1,1,1), myDet(1,1), N_det_non_ref, N_int) ind = searchDet(psi_non_ref_sorted(1,1,1), myDet(1,1), N_det_non_ref, N_int)
if(ind /= -1) then if(ind /= -1) then
!iwk = wk+1
!A_val(wk, pp) = psi_ref_coef(II, 1)
!A_ind(wk, pp) = psi_non_ref_sorted_idx(ind)
lref(psi_non_ref_sorted_idx(ind)) = II lref(psi_non_ref_sorted_idx(ind)) = II
end if end if
end do end do
@ -728,7 +600,7 @@ BEGIN_PROVIDER [ double precision, dIj, (hh_shortcut(hh_shortcut(0)+1)-1) ]
do i=1, N_det_non_ref do i=1, N_det_non_ref
if(lref(i) /= 0) then if(lref(i) /= 0) then
wk += 1 wk += 1
A_val(wk, pp) = psi_ref_coef(lref(i), 1) A_val(wk, pp) = psi_ref_coef(lref(i), s)
A_ind(wk, pp) = i A_ind(wk, pp) = i
end if end if
end do end do
@ -744,19 +616,19 @@ BEGIN_PROVIDER [ double precision, dIj, (hh_shortcut(hh_shortcut(0)+1)-1) ]
N_col = 0 N_col = 0
!$OMP PARALLEL DO schedule(dynamic, 100) default(none) shared(k, psi_non_ref_coef, A_ind, A_val, x, N_det_ref, nex, N_det_non_ref) & !$OMP PARALLEL DO schedule(dynamic, 100) default(none) shared(k, psi_non_ref_coef, A_ind, A_val, x, N_det_ref, nex, N_det_non_ref) &
!$OMP private(at_row, a_col, t, i, r1, r2, wk, A_ind_mwen, A_val_mwen) & !$OMP private(at_row, a_col, t, i, r1, r2, wk, A_ind_mwen, A_val_mwen) &
!$OMP shared(col_shortcut, N_col, AtB, AtA_size, AtA_val, AtA_ind) !$OMP shared(col_shortcut, N_col, AtB, AtA_size, AtA_val, AtA_ind, s)
do at_row = 1, nex do at_row = 1, nex
wk = 0 wk = 0
if(mod(at_row, 10000) == 0) print *, "AtA", at_row, "/", nex if(mod(at_row, 10000) == 0) print *, "AtA", at_row, "/", nex
do i=1,N_det_ref do i=1,N_det_ref
if(A_ind(i, at_row) == 0) exit if(A_ind(i, at_row) == 0) exit
AtB(at_row) = AtB(at_row) + psi_non_ref_coef(A_ind(i, at_row), 1) * A_val(i, at_row) AtB(at_row) = AtB(at_row) + psi_non_ref_coef(A_ind(i, at_row), s) * A_val(i, at_row)
end do end do
do a_col = 1, nex do a_col = 1, nex
t = 0d0 t = 0d0
r1 = 1 r1 = 1
r2 = 1 r2 = 1
do while(A_ind(r1, at_row) * A_ind(r2, a_col) /= 0) do while ((A_ind(r1, at_row) /= 0).and.(A_ind(r2, a_col) /= 0))
if(A_ind(r1, at_row) < A_ind(r2, a_col)) then if(A_ind(r1, at_row) < A_ind(r2, a_col)) then
r1 += 1 r1 += 1
else if(A_ind(r1, at_row) > A_ind(r2, a_col)) then else if(A_ind(r1, at_row) > A_ind(r2, a_col)) then
@ -769,15 +641,11 @@ BEGIN_PROVIDER [ double precision, dIj, (hh_shortcut(hh_shortcut(0)+1)-1) ]
end do end do
if(a_col == at_row) then if(a_col == at_row) then
t = (t + 1d0)! / 2d0 t = (t + 1d0)
!print *, a_col, t-1d0
end if end if
if(t /= 0d0) then if(t /= 0d0) then
wk += 1 wk += 1
!AtA_ind(1, wk) = at_row
!AtA_ind(2, wk) = a_col
A_ind_mwen(wk) = a_col A_ind_mwen(wk) = a_col
!AtA_val(wk) = t
A_val_mwen(wk) = t A_val_mwen(wk) = t
end if end if
end do end do
@ -796,7 +664,6 @@ BEGIN_PROVIDER [ double precision, dIj, (hh_shortcut(hh_shortcut(0)+1)-1) ]
x = AtB x = AtB
if(AtA_size > size(AtA_val)) stop "SIZA" if(AtA_size > size(AtA_val)) stop "SIZA"
print *, "ATA SIZE", ata_size print *, "ATA SIZE", ata_size
allocate (x_new(nex))
integer :: iproc, omp_get_thread_num integer :: iproc, omp_get_thread_num
iproc = omp_get_thread_num() iproc = omp_get_thread_num()
do i=1,nex do i=1,nex
@ -821,7 +688,7 @@ BEGIN_PROVIDER [ double precision, dIj, (hh_shortcut(hh_shortcut(0)+1)-1) ]
double precision :: norm_cas double precision :: norm_cas
norm_cas = 0d0 norm_cas = 0d0
do i = 1, N_det_ref do i = 1, N_det_ref
norm_cas += psi_ref_coef(i,1)**2 norm_cas += psi_ref_coef(i,s)**2
end do end do
norm = 0d0 norm = 0d0
@ -831,25 +698,8 @@ BEGIN_PROVIDER [ double precision, dIj, (hh_shortcut(hh_shortcut(0)+1)-1) ]
t = t + X_new(j) * X_new(j) t = t + X_new(j) * X_new(j)
end do end do
!t = (1d0 - norm_cas) / t
!x_new = x_new * sqrt(t)
!!!!!!!!!!!!!!
!B = 0d0
!do i=1, nex
! do j=1, N_det_ref
! if(A_ind(j, i) == 0) exit
! B(A_ind(j, i)) += A_val(j, i) * x(i)
! end do
!end do
!t = 0d0
!do i=1, size(B)
! t += B(i)**2
!end do
!print *, "NORMT", sqrt(t + norm_cas)
!x_new = x_new / sqrt(t + norm_cas)
!!!!!!!!!!
t = (1d0 / norm_cas - 1d0) / t t = (1d0 - norm_cas ) / t
x_new = x_new * sqrt(t) x_new = x_new * sqrt(t)
do j=1, size(X) do j=1, size(X)
@ -858,7 +708,7 @@ BEGIN_PROVIDER [ double precision, dIj, (hh_shortcut(hh_shortcut(0)+1)-1) ]
end do end do
if(mod(k, 50) == 0) then if(mod(k, 100) == 0) then
print *, "residu ", k, norm, "norm t", sqrt(t) print *, "residu ", k, norm, "norm t", sqrt(t)
end if end if
@ -866,77 +716,51 @@ BEGIN_PROVIDER [ double precision, dIj, (hh_shortcut(hh_shortcut(0)+1)-1) ]
end do end do
print *, "CONVERGENCE : ", norm print *, "CONVERGENCE : ", norm
dIj_unique(:size(X), s) = X(:)
!do k=0,500 end do
! if(k == 1) print *, X(:10)
! x_new = 0d0
! A_dense = 0d0
! !!$OMP PARALLEL DO schedule(dynamic, 10) default(none) shared(k, psi_non_ref_coef, x_new, A_ind, A_val, x, N_det_ref, nex, N_det_non_ref) &
! !!$OMP private(a_col, t, i, cx) &
! !!$OMP firstprivate(A_dense)
! do at_row = 1, nex
! ! ! d DIR$ IVDEP
! cx = 0d0
! do i=1,N_det_ref
! if(A_ind(i, at_row) == 0) exit
! if(k /= 0) A_dense(A_ind(i, at_row)) = A_val(i, at_row)
! cx = cx + psi_non_ref_coef(A_ind(i, at_row), 1) * A_val(i, at_row)
! !x_new(at_row) = x_new(at_row) + psi_non_ref_coef(A_ind(i, at_row), 1) * A_val(i, at_row)
! end do
! if(k == 0) then
! x_new(at_row) = cx
! cycle
! end if
! do a_col = 1, nex
! t = 0d0
! do i = 1, N_det_ref
! if(A_ind(i, a_col) == 0) exit
! t = t - A_val(i, a_col) * A_dense(A_ind(i, a_col)) ! -= pcq I-A
! end do
! if(a_col == at_row) t = t + 1d0
! cx = cx + t * x(a_col)
! !x_new(at_row) = x_new(at_row) + t * x(a_col)
! end do
! x_new(at_row) = cx
! do i=1,N_det_ref
! if(A_ind(i, at_row) == 0) exit
! A_dense(A_ind(i, at_row)) = 0d0
! end do
! end do
! !!$OMP END PARALLEL DO
! norm = 0d0
! do j=1, size(X)
! norm += (X_new(j) - X(j))**2
! X(j) = X_new(j)
! end do
! print *, "residu ", k, norm
! if(norm < 1d-10) exit
!end do
!
dIj(:size(X)) = X(:)
!print *, X
print *, "done" print *, "done"
END_PROVIDER END_PROVIDER
double precision function get_dij_index(II, i, Nint) BEGIN_PROVIDER [ double precision, dij, (N_det_ref, N_det_non_ref, N_states) ]
integer, intent(in) :: II, i, Nint integer :: s,i,j
double precision, external :: get_dij double precision, external :: get_dij_index
print *, "computing amplitudes..."
do s=1, N_states
do i=1, N_det_non_ref
do j=1, N_det_ref
dij(j, i, s) = get_dij_index(j, i, s, N_int)
end do
end do
end do
print *, "done computing amplitudes"
END_PROVIDER
if(dabs(psi_ref_coef(II, 1)) > 1d-1) then
get_dij_index = psi_non_ref_coef(i, 1) / psi_ref_coef(II, 1)
double precision function get_dij_index(II, i, s, Nint)
integer, intent(in) :: II, i, s, Nint
double precision, external :: get_dij
double precision :: HIi
if(lambda_type == 0) then
get_dij_index = get_dij(psi_ref(1,1,II), psi_non_ref(1,1,i), s, Nint)
else else
get_dij_index = get_dij(psi_ref(1,1,II), psi_non_ref(1,1,i), Nint) call i_h_j(psi_ref(1,1,II), psi_non_ref(1,1,i), Nint, HIi)
get_dij_index = HIi * lambda_mrcc(s, i)
end if end if
end function end function
double precision function get_dij(det1, det2, Nint) double precision function get_dij(det1, det2, s, Nint)
use bitmasks use bitmasks
implicit none implicit none
integer, intent(in) :: Nint integer, intent(in) :: s, Nint
integer(bit_kind) :: det1(Nint, 2), det2(Nint, 2) integer(bit_kind) :: det1(Nint, 2), det2(Nint, 2)
integer :: degree, f, exc(0:2, 2, 2), t integer :: degree, f, exc(0:2, 2, 2), t
integer*2 :: h1, h2, p1, p2, s1, s2 integer*2 :: h1, h2, p1, p2, s1, s2
@ -976,7 +800,7 @@ double precision function get_dij(det1, det2, Nint)
end if end if
if(t /= -1) then if(t /= -1) then
get_dij = dIj(t - 1 + hh_shortcut(f)) get_dij = dIj_unique(t - 1 + hh_shortcut(f), s)
end if end if
end function end function

2
plugins/Molden/NEEDED_CHILDREN_MODULES
View File

@ -1 +1 @@
MO_Basis Utils MO_Basis Utils

196
plugins/Molden/aos.irp.f
View File

@ -1,196 +0,0 @@
BEGIN_PROVIDER [ character*(128), ao_l_char, (ao_num) ]
implicit none
BEGIN_DOC
! ao_l = l value of the AO: a+b+c in x^a y^b z^c
END_DOC
integer :: i
do i=1,ao_num
ao_l_char(i) = l_to_character(ao_l(i))
enddo
END_PROVIDER
BEGIN_PROVIDER [ character*(128), l_to_character, (0:4)]
BEGIN_DOC
! character corresponding to the "L" value of an AO orbital
END_DOC
implicit none
l_to_character(0)='S'
l_to_character(1)='P'
l_to_character(2)='D'
l_to_character(3)='F'
l_to_character(4)='G'
END_PROVIDER
BEGIN_PROVIDER [ integer, Nucl_N_Aos, (nucl_num)]
&BEGIN_PROVIDER [ integer, N_AOs_max ]
implicit none
integer :: i
BEGIN_DOC
! Number of AOs per atom
END_DOC
Nucl_N_Aos = 0
do i = 1, ao_num
Nucl_N_Aos(ao_nucl(i)) +=1
enddo
N_AOs_max = maxval(Nucl_N_Aos)
END_PROVIDER
BEGIN_PROVIDER [ integer, Nucl_Aos, (nucl_num,N_AOs_max)]
implicit none
BEGIN_DOC
! List of AOs attached on each atom
END_DOC
integer :: i
integer, allocatable :: nucl_tmp(:)
allocate(nucl_tmp(nucl_num))
nucl_tmp = 0
Nucl_Aos = 0
do i = 1, ao_num
nucl_tmp(ao_nucl(i))+=1
Nucl_Aos(ao_nucl(i),nucl_tmp(ao_nucl(i))) = i
enddo
deallocate(nucl_tmp)
END_PROVIDER
BEGIN_PROVIDER [ integer, Nucl_list_shell_Aos, (nucl_num,N_AOs_max)]
&BEGIN_PROVIDER [ integer, Nucl_num_shell_Aos, (nucl_num)]
implicit none
integer :: i,j,k
BEGIN_DOC
! Index of the shell type Aos and of the corresponding Aos
! Per convention, for P,D,F and G AOs, we take the index
! of the AO with the the corresponding power in the "X" axis
END_DOC
do i = 1, nucl_num
Nucl_num_shell_Aos(i) = 0
do j = 1, Nucl_N_Aos(i)
if(ao_l(Nucl_Aos(i,j))==0)then
! S type function
Nucl_num_shell_Aos(i)+=1
Nucl_list_shell_Aos(i,Nucl_num_shell_Aos(i))=Nucl_Aos(i,j)
elseif(ao_l(Nucl_Aos(i,j))==1)then
! P type function
if(ao_power(Nucl_Aos(i,j),1)==1)then
Nucl_num_shell_Aos(i)+=1
Nucl_list_shell_Aos(i,Nucl_num_shell_Aos(i))=Nucl_Aos(i,j)
endif
elseif(ao_l(Nucl_Aos(i,j))==2)then
! D type function
if(ao_power(Nucl_Aos(i,j),1)==2)then
Nucl_num_shell_Aos(i)+=1
Nucl_list_shell_Aos(i,Nucl_num_shell_Aos(i))=Nucl_Aos(i,j)
endif
elseif(ao_l(Nucl_Aos(i,j))==3)then
! F type function
if(ao_power(Nucl_Aos(i,j),1)==3)then
Nucl_num_shell_Aos(i)+=1
Nucl_list_shell_Aos(i,Nucl_num_shell_Aos(i))=Nucl_Aos(i,j)
endif
elseif(ao_l(Nucl_Aos(i,j))==4)then
! G type function
if(ao_power(Nucl_Aos(i,j),1)==4)then
Nucl_num_shell_Aos(i)+=1
Nucl_list_shell_Aos(i,Nucl_num_shell_Aos(i))=Nucl_Aos(i,j)
endif
endif
enddo
enddo
END_PROVIDER
BEGIN_PROVIDER [ character*(4), ao_l_char_space, (ao_num) ]
implicit none
integer :: i
character*(4) :: give_ao_character_space
do i=1,ao_num
if(ao_l(i)==0)then
! S type AO
give_ao_character_space = 'S '
elseif(ao_l(i) == 1)then
! P type AO
if(ao_power(i,1)==1)then
give_ao_character_space = 'X '
elseif(ao_power(i,2) == 1)then
give_ao_character_space = 'Y '
else
give_ao_character_space = 'Z '
endif
elseif(ao_l(i) == 2)then
! D type AO
if(ao_power(i,1)==2)then
give_ao_character_space = 'XX '
elseif(ao_power(i,2) == 2)then
give_ao_character_space = 'YY '
elseif(ao_power(i,3) == 2)then
give_ao_character_space = 'ZZ '
elseif(ao_power(i,1) == 1 .and. ao_power(i,2) == 1)then
give_ao_character_space = 'XY '
elseif(ao_power(i,1) == 1 .and. ao_power(i,3) == 1)then
give_ao_character_space = 'XZ '
else
give_ao_character_space = 'YZ '
endif
elseif(ao_l(i) == 3)then
! F type AO
if(ao_power(i,1)==3)then
give_ao_character_space = 'XXX '
elseif(ao_power(i,2) == 3)then
give_ao_character_space = 'YYY '
elseif(ao_power(i,3) == 3)then
give_ao_character_space = 'ZZZ '
elseif(ao_power(i,1) == 2 .and. ao_power(i,2) == 1)then
give_ao_character_space = 'XXY '
elseif(ao_power(i,1) == 2 .and. ao_power(i,3) == 1)then
give_ao_character_space = 'XXZ '
elseif(ao_power(i,2) == 2 .and. ao_power(i,1) == 1)then
give_ao_character_space = 'YYX '
elseif(ao_power(i,2) == 2 .and. ao_power(i,3) == 1)then
give_ao_character_space = 'YYZ '
elseif(ao_power(i,3) == 2 .and. ao_power(i,1) == 1)then
give_ao_character_space = 'ZZX '
elseif(ao_power(i,3) == 2 .and. ao_power(i,2) == 1)then
give_ao_character_space = 'ZZY '
elseif(ao_power(i,3) == 1 .and. ao_power(i,2) == 1 .and. ao_power(i,3) == 1)then
give_ao_character_space = 'XYZ '
endif
elseif(ao_l(i) == 4)then
! G type AO
if(ao_power(i,1)==4)then
give_ao_character_space = 'XXXX'
elseif(ao_power(i,2) == 4)then
give_ao_character_space = 'YYYY'
elseif(ao_power(i,3) == 4)then
give_ao_character_space = 'ZZZZ'
elseif(ao_power(i,1) == 3 .and. ao_power(i,2) == 1)then
give_ao_character_space = 'XXXY'
elseif(ao_power(i,1) == 3 .and. ao_power(i,3) == 1)then
give_ao_character_space = 'XXXZ'
elseif(ao_power(i,2) == 3 .and. ao_power(i,1) == 1)then
give_ao_character_space = 'YYYX'
elseif(ao_power(i,2) == 3 .and. ao_power(i,3) == 1)then
give_ao_character_space = 'YYYZ'
elseif(ao_power(i,3) == 3 .and. ao_power(i,1) == 1)then
give_ao_character_space = 'ZZZX'
elseif(ao_power(i,3) == 3 .and. ao_power(i,2) == 1)then
give_ao_character_space = 'ZZZY'
elseif(ao_power(i,1) == 2 .and. ao_power(i,2) == 2)then
give_ao_character_space = 'XXYY'
elseif(ao_power(i,2) == 2 .and. ao_power(i,3) == 2)then
give_ao_character_space = 'YYZZ'
elseif(ao_power(i,1) == 2 .and. ao_power(i,2) == 1 .and. ao_power(i,3) == 1)then
give_ao_character_space = 'XXYZ'
elseif(ao_power(i,2) == 2 .and. ao_power(i,1) == 1 .and. ao_power(i,3) == 1)then
give_ao_character_space = 'YYXZ'
elseif(ao_power(i,3) == 2 .and. ao_power(i,1) == 1 .and. ao_power(i,2) == 1)then
give_ao_character_space = 'ZZXY'
endif
endif
ao_l_char_space(i) = give_ao_character_space
enddo
END_PROVIDER

6
plugins/Molden/print_mo.irp.f
View File

@ -104,6 +104,8 @@ subroutine write_Ao_basis(i_unit_output)
write(i_unit_output,*)'' write(i_unit_output,*)''
write(i_unit_output,'(A47,2X,I3)')'TOTAL NUMBER OF BASIS SET SHELLS =', i_shell write(i_unit_output,'(A47,2X,I3)')'TOTAL NUMBER OF BASIS SET SHELLS =', i_shell
write(i_unit_output,'(A47,2X,I3)')'NUMBER OF CARTESIAN GAUSSIAN BASIS FUNCTIONS =', ao_num write(i_unit_output,'(A47,2X,I3)')'NUMBER OF CARTESIAN GAUSSIAN BASIS FUNCTIONS =', ao_num
! this is for the new version of molden
write(i_unit_output,'(A12)')'PP =NONE'
write(i_unit_output,*)'' write(i_unit_output,*)''
@ -126,7 +128,9 @@ subroutine write_Mo_basis(i_unit_output)
write(i_unit_output,'(18X,F8.5)')-1.d0 write(i_unit_output,'(18X,F8.5)')-1.d0
write(i_unit_output,*)'' write(i_unit_output,*)''
do i = 1, ao_num do i = 1, ao_num
write(i_unit_output,'(2X,I3, 2X A1, I3, 2X A4 , F9.6)')i,trim(element_name(int(nucl_charge(ao_nucl(i))))),ao_nucl(i),(ao_l_char_space(i)),mo_coef(i,j) ! write(i_unit_output,'(2X,I3, 2X A1, I3, 2X A4 , F9.6)')i,trim(element_name(int(nucl_charge(ao_nucl(i))))),ao_nucl(i),(ao_l_char_space(i)),mo_coef(i,j)
! F12.6 for larger coefficients...
write(i_unit_output,'(2X,I3, 2X A1, I3, 2X A4 , F12.6)')i,trim(element_name(int(nucl_charge(ao_nucl(i))))),ao_nucl(i),(ao_l_char_space(i)),mo_coef(i,j)
! write(i_unit_output,'(I3, X A1, X I3, X A4 X F16.8)')i,trim(element_name(int(nucl_charge(ao_nucl(i))))),ao_nucl(i),(ao_l_char_space(i)) ! write(i_unit_output,'(I3, X A1, X I3, X A4 X F16.8)')i,trim(element_name(int(nucl_charge(ao_nucl(i))))),ao_nucl(i),(ao_l_char_space(i))
enddo enddo
write(i_unit_output,*)'' write(i_unit_output,*)''

2
plugins/Perturbation/pt2_equations.irp.f
View File

@ -125,6 +125,8 @@ subroutine pt2_moller_plesset ($arguments)
delta_e = (Fock_matrix_diag_mo(h1) - Fock_matrix_diag_mo(p1)) + & delta_e = (Fock_matrix_diag_mo(h1) - Fock_matrix_diag_mo(p1)) + &
(Fock_matrix_diag_mo(h2) - Fock_matrix_diag_mo(p2)) (Fock_matrix_diag_mo(h2) - Fock_matrix_diag_mo(p2))
delta_e = 1.d0/delta_e delta_e = 1.d0/delta_e
! print*,'h1,p1',h1,p1
! print*,'h2,p2',h2,p2
else if (degree == 1) then else if (degree == 1) then
call decode_exc(exc,degree,h1,p1,h2,p2,s1,s2) call decode_exc(exc,degree,h1,p1,h2,p2,s1,s2)
delta_e = Fock_matrix_diag_mo(h1) - Fock_matrix_diag_mo(p1) delta_e = Fock_matrix_diag_mo(h1) - Fock_matrix_diag_mo(p1)

13
plugins/Properties/hyperfine_constants.irp.f
View File

@ -133,3 +133,16 @@ END_PROVIDER
enddo enddo
END_PROVIDER END_PROVIDER
subroutine print_hcc
implicit none
double precision :: accu
integer :: i,j
print*,'Z AU GAUSS MHZ cm^-1'
do i = 1, nucl_num
write(*,'(I2,X,F3.1,X,4(F16.6,X))')i,nucl_charge(i),spin_density_at_nucleous(i),iso_hcc_gauss(i),iso_hcc_mhz(i),iso_hcc_cm_1(i)
enddo
end

31
plugins/Properties/mulliken.irp.f
View File

@ -105,3 +105,34 @@ END_PROVIDER
enddo enddo
END_PROVIDER END_PROVIDER
subroutine print_mulliken_sd
implicit none
double precision :: accu
integer :: i
integer :: j
print*,'Mulliken spin densities'
accu= 0.d0
do i = 1, nucl_num
print*,i,nucl_charge(i),mulliken_spin_densities(i)
accu += mulliken_spin_densities(i)
enddo
print*,'Sum of Mulliken SD = ',accu
print*,'AO SPIN POPULATIONS'
accu = 0.d0
do i = 1, ao_num
accu += spin_gross_orbital_product(i)
write(*,'(X,I3,X,A4,X,I2,X,A4,X,F10.7)')i,trim(element_name(int(nucl_charge(ao_nucl(i))))),ao_nucl(i),trim(l_to_charater(ao_l(i))),spin_gross_orbital_product(i)
enddo
print*,'sum = ',accu
accu = 0.d0
print*,'Angular momentum analysis'
do i = 0, ao_l_max
accu += spin_population_angular_momentum(i)
print*,' ',trim(l_to_charater(i)),spin_population_angular_momentum(i)
print*,'sum = ',accu
enddo
end

15
plugins/Properties/print_hcc.irp.f
View File

@ -1,17 +1,6 @@
program print_hcc program print_hcc_main
implicit none implicit none
read_wf = .True. read_wf = .True.
touch read_wf touch read_wf
call test call print_hcc
end end
subroutine test
implicit none
double precision :: accu
integer :: i,j
print*,'Z AU GAUSS MHZ cm^-1'
do i = 1, nucl_num
write(*,'(I2,X,F3.1,X,4(F16.6,X))')i,nucl_charge(i),spin_density_at_nucleous(i),iso_hcc_gauss(i),iso_hcc_mhz(i),iso_hcc_cm_1(i)
enddo
end

31
plugins/Properties/print_mulliken.irp.f
View File

@ -2,34 +2,5 @@ program print_mulliken
implicit none implicit none
read_wf = .True. read_wf = .True.
touch read_wf touch read_wf
print*,'Mulliken spin densities' call print_mulliken_sd
call test
end end
subroutine test
double precision :: accu
integer :: i
integer :: j
accu= 0.d0
do i = 1, nucl_num
print*,i,nucl_charge(i),mulliken_spin_densities(i)
accu += mulliken_spin_densities(i)
enddo
print*,'Sum of Mulliken SD = ',accu
print*,'AO SPIN POPULATIONS'
accu = 0.d0
do i = 1, ao_num
accu += spin_gross_orbital_product(i)
write(*,'(X,I3,X,A4,X,I2,X,A4,X,F10.7)')i,trim(element_name(int(nucl_charge(ao_nucl(i))))),ao_nucl(i),trim(l_to_charater(ao_l(i))),spin_gross_orbital_product(i)
enddo
print*,'sum = ',accu
accu = 0.d0
print*,'Angular momentum analysis'
do i = 0, ao_l_max
accu += spin_population_angular_momentum(i)
print*,' ',trim(l_to_charater(i)),spin_population_angular_momentum(i)
print*,'sum = ',accu
enddo
end

73
plugins/QmcChem/dressed_dmc.irp.f Normal file
View File

@ -0,0 +1,73 @@
program dressed_dmc
implicit none
double precision :: E0, hij
double precision, allocatable :: H_jj(:), energies(:), delta_jj(:), cj(:), hj(:)
integer :: i
double precision, external :: diag_h_mat_elem
if (.not.read_wf) then
stop 'read_wf should be true'
endif
PROVIDE mo_bielec_integrals_in_map
allocate ( H_jj(N_det), delta_jj(N_det), hj(N_det), cj(N_det), energies(N_states) )
! Read <i|\Phi_0>
! -=-=-=-==-=-=-=
character*(32) :: w, w2
integer :: k
do while (.True.)
read(*,*) w
if ( trim(w) == 'Ci_h_psidet' ) then
exit
endif
enddo
do i=1,N_det
read(*,*) k, w, hj(i)
enddo
do while (.True.)
read(*,*) w
if ( trim(w) == 'Ci_overlap_psidet' ) then
exit
endif
enddo
do i=1,N_det
read(*,*) k, w, cj(i)
enddo
read(*,*)
read(*,*) w, w2, E0
print *, 'E0=', E0
print *, 'Ndet = ', N_det
! Compute delta_ii
! -=-=-=-==-=-=-=-
do i=1,N_det
call i_H_psi(psi_det(1,1,i),psi_det,cj,N_int,N_det,size(psi_coef,1),N_states,energies)
if (dabs(cj(i)) < 1.d-6) then
delta_jj(i) = 0.d0
else
delta_jj(i) = (hj(i) - energies(1))/cj(i)
endif
H_jj(i) = diag_h_mat_elem(psi_det(1,1,i),N_int) + delta_jj(i)
print *, 'Delta_jj(',i,') = ', Delta_jj(i), H_jj(i)
enddo
call davidson_diag_hjj(psi_det,psi_coef,H_jj,energies,size(psi_coef,1),N_det,N_states,N_int,6)
call save_wavefunction
call write_spindeterminants
E0 = 0.d0
do i=1,N_det
call i_H_psi(psi_det(1,1,i),psi_det,psi_coef(1,1),N_int,N_det,size(psi_coef,1),N_states,energies)
E0 += psi_coef(i,1) * energies(1)
enddo
print *, 'Trial energy: ', E0 + nuclear_repulsion
deallocate (H_jj, delta_jj, energies, cj)
end

102
plugins/QmcChem/e_curve_qmc.irp.f Normal file
View File

@ -0,0 +1,102 @@
program e_curve
use bitmasks
implicit none
integer :: i,j,k, nab, m, l
double precision :: norm, E, hij, num, ci, cj
integer, allocatable :: iorder(:)
double precision , allocatable :: norm_sort(:)
nab = n_det_alpha_unique+n_det_beta_unique
allocate ( norm_sort(0:nab), iorder(0:nab) )
norm_sort(0) = 0.d0
iorder(0) = 0
do i=1,n_det_alpha_unique
norm_sort(i) = det_alpha_norm(i)
iorder(i) = i
enddo
do i=1,n_det_beta_unique
norm_sort(i+n_det_alpha_unique) = det_beta_norm(i)
iorder(i+n_det_alpha_unique) = -i
enddo
call dsort(norm_sort(1),iorder(1),nab)
if (.not.read_wf) then
stop 'Please set read_wf to true'
endif
PROVIDE psi_bilinear_matrix_values nuclear_repulsion
print *, ''
print *, '=============================='
print *, 'Energies at different cut-offs'
print *, '=============================='
print *, ''
print *, '=========================================================='
print '(A8,2X,A8,2X,A12,2X,A10,2X,A12)', 'Thresh.', 'Ndet', 'Cost', 'Norm', 'E'
print *, '=========================================================='
double precision :: thresh
integer(bit_kind), allocatable :: det_i(:,:), det_j(:,:)
thresh = 1.d-10
do j=0,nab
i = iorder(j)
if (i<0) then
do k=1,n_det
if (psi_bilinear_matrix_columns(k) == -i) then
psi_bilinear_matrix_values(k,1) = 0.d0
endif
enddo
else
do k=1,n_det
if (psi_bilinear_matrix_rows(k) == i) then
psi_bilinear_matrix_values(k,1) = 0.d0
endif
enddo
endif
if (thresh > norm_sort(j)) then
cycle
endif
num = 0.d0
norm = 0.d0
m = 0
!$OMP PARALLEL DEFAULT(SHARED) PRIVATE(k,l,det_i,det_j,ci,cj,hij) REDUCTION(+:norm,m,num)
allocate( det_i(N_int,2), det_j(N_int,2))
!$OMP DO SCHEDULE(guided)
do k=1,n_det
if (psi_bilinear_matrix_values(k,1) == 0.d0) then
cycle
endif
ci = psi_bilinear_matrix_values(k,1)
det_i(:,1) = psi_det_alpha_unique(:,psi_bilinear_matrix_rows(k))
det_i(:,2) = psi_det_beta_unique(:,psi_bilinear_matrix_columns(k))
do l=1,n_det
if (psi_bilinear_matrix_values(l,1) == 0.d0) then
cycle
endif
cj = psi_bilinear_matrix_values(l,1)
det_j(:,1) = psi_det_alpha_unique(:,psi_bilinear_matrix_rows(l))
det_j(:,2) = psi_det_beta_unique(:,psi_bilinear_matrix_columns(l))
call i_h_j(det_i, det_j, N_int, hij)
num = num + ci*cj*hij
enddo
norm = norm + ci*ci
m = m+1
enddo
!$OMP END DO
deallocate (det_i,det_j)
!$OMP END PARALLEL
if (m == 0) then
exit
endif
E = num / norm + nuclear_repulsion
print '(E9.1,2X,I8,2X,F10.2,2X,F10.8,2X,F12.6)', thresh, m, &
dble( elec_alpha_num**3 + elec_alpha_num**2 * (nab-1) ) / &
dble( elec_alpha_num**3 + elec_alpha_num**2 * (j-1)), norm, E
thresh = thresh * 2.d0
enddo
print *, '=========================================================='
deallocate (iorder, norm_sort)
end

51
plugins/QmcChem/save_for_qmcchem.irp.f
View File

@ -1,9 +1,46 @@
program save_for_qmc program save_for_qmc
read_wf = .True.
TOUCH read_wf integer :: iunit
print *, "N_det = ", N_det integer, external :: get_unit_and_open
call write_spindeterminants logical :: exists
if (do_pseudo) then double precision :: e_ref
call write_pseudopotential
endif ! Determinants
read_wf = .True.
TOUCH read_wf
print *, "N_det = ", N_det
call write_spindeterminants
! Reference Energy
if (do_pseudo) then
call write_pseudopotential
endif
call system( &
'mkdir -p '//trim(ezfio_filename)//'/simulation ;' // &
'cp '//trim(ezfio_filename)//'/.version '//trim(ezfio_filename)//'/simulation/.version ; ' // &
'mkdir -p '//trim(ezfio_filename)//'/properties ;' // &
'cp '//trim(ezfio_filename)//'/.version '//trim(ezfio_filename)//'/properties/.version ; ' // &
'echo T > '//trim(ezfio_filename)//'/properties/e_loc' &
)
iunit = 13
open(unit=iunit,file=trim(ezfio_filename)//'/simulation/e_ref',action='write')
call ezfio_has_full_ci_energy_pt2(exists)
if (exists) then
call ezfio_get_full_ci_energy_pt2(e_ref)
else
call ezfio_has_full_ci_energy(exists)
if (exists) then
call ezfio_get_full_ci_energy(e_ref)
else
call ezfio_has_hartree_fock_energy(exists)
if (exists) then
call ezfio_get_hartree_fock_energy(e_ref)
else
e_ref = 0.d0
endif
endif
endif
write(iunit,*) e_ref
close(iunit)
end end

4
plugins/loc_cele/loc.f
View File

@ -17,9 +17,11 @@ C
data small/1.d-6/ data small/1.d-6/
zprt=.true. zprt=.true.
niter=500 niter=1000000
conv=1.d-8 conv=1.d-8
C niter=1000000
C conv=1.d-6
write (6,5) n,m,conv write (6,5) n,m,conv
5 format (//5x,'Unitary transformation of',i3,' vectors'/ 5 format (//5x,'Unitary transformation of',i3,' vectors'/
* 5x,'following the principle of maximum overlap with a set of', * 5x,'following the principle of maximum overlap with a set of',

502
plugins/loc_cele/loc_cele.irp.f
View File

@ -92,13 +92,182 @@
nrot(1) = 6 ! number of orbitals to be localized nrot(1) = 64 ! number of orbitals to be localized
integer :: index_rot(1000,1) integer :: index_rot(1000,1)
cmoref = 0.d0 cmoref = 0.d0
irot = 0
! H2 molecule for the mixed localization
do i=1,64
irot(i,1) = i+2
enddo
do i=1,17
cmoref(i+1,i,1)=1.d0
enddo
cmoref(19,19-1,1)=1.d0
cmoref(20,19-1,1)=-1.d0
cmoref(19,20-1,1)=-1.d0
cmoref(20,20-1,1)=-1.d0
cmoref(21,20-1,1)=2.d0
cmoref(22,21-1,1)=1.d0
cmoref(23,22-1,1)=1.d0
cmoref(24,23-1,1)=1.d0
cmoref(25,24-1,1)=1.d0
cmoref(26,24-1,1)=-1.d0
cmoref(25,25-1,1)=-1.d0
cmoref(26,25-1,1)=-1.d0
cmoref(27,25-1,1)=2.d0
cmoref(28,26-1,1)=1.d0
cmoref(29,27-1,1)=1.d0
cmoref(30,28-1,1)=1.d0
cmoref(31,29-1,1)=1.d0
cmoref(32,29-1,1)=-1.d0
cmoref(31,30-1,1)=-1.d0
cmoref(32,30-1,1)=-1.d0
cmoref(33,30-1,1)=2.d0
cmoref(34,31-1,1)=1.d0
cmoref(35,32-1,1)=1.d0
cmoref(36,33-1,1)=1.d0
do i=33,49
cmoref(i+5,i,1)= 1.d0
enddo
cmoref(55,52-2,1)=1.d0
cmoref(56,52-2,1)=-1.d0
cmoref(55,53-2,1)=-1.d0
cmoref(56,53-2,1)=-1.d0
cmoref(57,53-2,1)=2.d0
cmoref(58,54-2,1)=1.d0
cmoref(59,55-2,1)=1.d0
cmoref(60,56-2,1)=1.d0
cmoref(61,57-2,1)=1.d0
cmoref(62,57-2,1)=-1.d0
cmoref(61,58-2,1)=-1.d0
cmoref(62,58-2,1)=-1.d0
cmoref(63,58-2,1)=2.d0
cmoref(64,59-2,1)=1.d0
cmoref(65,60-2,1)=1.d0
cmoref(66,61-2,1)=1.d0
cmoref(67,62-2,1)=1.d0
cmoref(68,62-2,1)=-1.d0
cmoref(67,63-2,1)=-1.d0
cmoref(68,63-2,1)=-1.d0
cmoref(69,63-2,1)=2.d0
cmoref(70,64-2,1)=1.d0
cmoref(71,65-2,1)=1.d0
cmoref(72,66-2,1)=1.d0
! H2 molecule
! do i=1,66
! irot(i,1) = i
! enddo
!
! do i=1,18
! cmoref(i,i,1)=1.d0
! enddo
! cmoref(19,19,1)=1.d0
! cmoref(20,19,1)=-1.d0
! cmoref(19,20,1)=-1.d0
! cmoref(20,20,1)=-1.d0
! cmoref(21,20,1)=2.d0
! cmoref(22,21,1)=1.d0
! cmoref(23,22,1)=1.d0
! cmoref(24,23,1)=1.d0
!
!
! cmoref(25,24,1)=1.d0
! cmoref(26,24,1)=-1.d0
! cmoref(25,25,1)=-1.d0
! cmoref(26,25,1)=-1.d0
! cmoref(27,25,1)=2.d0
! cmoref(28,26,1)=1.d0
! cmoref(29,27,1)=1.d0
! cmoref(30,28,1)=1.d0
!
! cmoref(31,29,1)=1.d0
! cmoref(32,29,1)=-1.d0
! cmoref(31,30,1)=-1.d0
! cmoref(32,30,1)=-1.d0
! cmoref(33,30,1)=2.d0
! cmoref(34,31,1)=1.d0
! cmoref(35,32,1)=1.d0
! cmoref(36,33,1)=1.d0
!
! do i=34,51
! cmoref(i+3,i,1)= 1.d0
! enddo
!
! cmoref(55,52,1)=1.d0
! cmoref(56,52,1)=-1.d0
! cmoref(55,53,1)=-1.d0
! cmoref(56,53,1)=-1.d0
! cmoref(57,53,1)=2.d0
! cmoref(58,54,1)=1.d0
! cmoref(59,55,1)=1.d0
! cmoref(60,56,1)=1.d0
!
! cmoref(61,57,1)=1.d0
! cmoref(62,57,1)=-1.d0
! cmoref(61,58,1)=-1.d0
! cmoref(62,58,1)=-1.d0
! cmoref(63,58,1)=2.d0
! cmoref(64,59,1)=1.d0
! cmoref(65,60,1)=1.d0
! cmoref(66,61,1)=1.d0
!
! cmoref(67,62,1)=1.d0
! cmoref(68,62,1)=-1.d0
! cmoref(67,63,1)=-1.d0
! cmoref(68,63,1)=-1.d0
! cmoref(69,63,1)=2.d0
! cmoref(70,64,1)=1.d0
! cmoref(71,65,1)=1.d0
! cmoref(72,66,1)=1.d0
! H atom
! do i=1,33
! irot(i,1) = i
! enddo
!
! do i=1,18
! cmoref(i,i,1)=1.d0
! enddo
! cmoref(19,19,1)=1.d0
! cmoref(20,19,1)=-1.d0
! cmoref(19,20,1)=-1.d0
! cmoref(20,20,1)=-1.d0
! cmoref(21,20,1)=2.d0
! cmoref(22,21,1)=1.d0
! cmoref(23,22,1)=1.d0
! cmoref(24,23,1)=1.d0
! cmoref(25,24,1)=1.d0
! cmoref(26,24,1)=-1.d0
! cmoref(25,25,1)=-1.d0
! cmoref(26,25,1)=-1.d0
! cmoref(27,25,1)=2.d0
! cmoref(28,26,1)=1.d0
! cmoref(29,27,1)=1.d0
! cmoref(30,28,1)=1.d0
!
! cmoref(31,29,1)=1.d0
! cmoref(32,29,1)=-1.d0
! cmoref(31,30,1)=-1.d0
! cmoref(32,30,1)=-1.d0
! cmoref(33,30,1)=2.d0
! cmoref(34,31,1)=1.d0
! cmoref(35,32,1)=1.d0
! cmoref(36,33,1)=1.d0
! Definition of the index of the MO to be rotated ! Definition of the index of the MO to be rotated
! irot(2,1) = 21 ! the first mo to be rotated is the 21 th MO ! irot(2,1) = 21 ! the first mo to be rotated is the 21 th MO
@ -106,25 +275,67 @@
! irot(4,1) = 23 ! ! irot(4,1) = 23 !
! irot(5,1) = 24 ! ! irot(5,1) = 24 !
! irot(6,1) = 25 ! ! irot(6,1) = 25 !
! do i = 1,12
! irot(i,1) = i+6 !N2
! enddo ! irot(1,1) = 5
irot(1,1) = 5 ! irot(2,1) = 6
irot(2,1) = 6 ! irot(3,1) = 7
irot(3,1) = 7 ! irot(4,1) = 8
irot(4,1) = 8 ! irot(5,1) = 9
irot(5,1) = 9 ! irot(6,1) = 10
irot(6,1) = 10 !
! cmoref(5,1,1) = 1.d0 !
! cmoref(6,2,1) = 1.d0 !
! cmoref(7,3,1) = 1.d0 !
! cmoref(40,4,1) = 1.d0 !
! cmoref(41,5,1) = 1.d0 !
! cmoref(42,6,1) = 1.d0 !
!END N2
!HEXATRIENE
! irot(1,1) = 20
! irot(2,1) = 21
! irot(3,1) = 22
! irot(4,1) = 23
! irot(5,1) = 24
! irot(6,1) = 25
!
! cmoref(7,1,1) = 1.d0 !
! cmoref(26,1,1) = 1.d0 !
! cmoref(45,2,1) = 1.d0 !
! cmoref(64,2,1) = 1.d0 !
! cmoref(83,3,1) = 1.d0 !
! cmoref(102,3,1) = 1.d0 !
! cmoref(7,4,1) = 1.d0 !
! cmoref(26,4,1) = -1.d0 !
! cmoref(45,5,1) = 1.d0 !
! cmoref(64,5,1) = -1.d0 !
! cmoref(83,6,1) = 1.d0 !
! cmoref(102,6,1) = -1.d0 !
!END HEXATRIENE
!!!!H2 H2 CAS
! irot(1,1) = 1
! irot(2,1) = 2
!
! cmoref(1,1,1) = 1.d0
! cmoref(37,2,1) = 1.d0
!END H2
!!!! LOCALIZATION ON THE BASIS FUNCTIONS
! do i = 1, nrot(1)
! irot(i,1) = i
! cmoref(i,i,1) = 1.d0
! enddo
!END BASISLOC
! do i = 1, nrot(1)
! irot(i,1) = 4+i
! enddo
do i = 1, nrot(1) do i = 1, nrot(1)
print*,'irot(i,1) = ',irot(i,1) print*,'irot(i,1) = ',irot(i,1)
enddo enddo
pause ! pause
cmoref(4,1,1) = 1.d0 ! 2S function
cmoref(5,2,1) = 1.d0 ! 2S function
cmoref(6,3,1) = 1.d0 ! 2S function
cmoref(19,4,1) = 1.d0 ! 2S function
cmoref(20,5,1) = 1.d0 ! 2S function
cmoref(21,6,1) = 1.d0 ! 2S function
! you define the guess vectors that you want ! you define the guess vectors that you want
! the new MO to be close to ! the new MO to be close to
@ -138,233 +349,21 @@
! own guess vectors for the MOs ! own guess vectors for the MOs
! The new MOs are provided in output ! The new MOs are provided in output
! in the same order than the guess MOs ! in the same order than the guess MOs
! do i = 1, nrot(1)
! C-C bonds ! j = 5+(i-1)*15
! 1-2 ! cmoref(j,i,1) = 0.2d0
! i_atom = 1 ! cmoref(j+3,i,1) = 0.12d0
! shift = (i_atom -1) * 15 ! print*,'j = ',j
! cmoref(1+shift,1,1) = -0.012d0 ! 2S function ! enddo
! cmoref(2+shift,1,1) = 0.18d0 ! ! pause
! cmoref(3+shift,1,1) = 0.1d0 !
! cmoref(5+shift,1,1) = -0.1d0 ! 2pX function
! cmoref(6+shift,1,1) = -0.1d0 ! 2pZ function
! i_atom = 2
! shift = (i_atom -1) * 15
! cmoref(1+shift,1,1) = -0.012d0 ! 2S function
! cmoref(2+shift,1,1) = 0.18d0 !
! cmoref(3+shift,1,1) = 0.1d0 !
! cmoref(5+shift,1,1) = 0.1d0 ! 2pX function
! cmoref(6+shift,1,1) = 0.1d0 ! 2pZ function
! ! 1-3
! i_atom = 1
! shift = (i_atom -1) * 15
! cmoref(1+shift,2,1) = -0.012d0 ! 2S function
! cmoref(2+shift,2,1) = 0.18d0 !
! cmoref(3+shift,2,1) = 0.1d0 !
! cmoref(5+shift,2,1) = 0.1d0 ! 2pX function
! cmoref(6+shift,2,1) = -0.1d0 ! 2pZ function
! i_atom = 3
! shift = (i_atom -1) * 15
! cmoref(1+shift,2,1) = -0.012d0 ! 2S function
! cmoref(2+shift,2,1) = 0.18d0 !
! cmoref(3+shift,2,1) = 0.1d0 !
! cmoref(5+shift,2,1) = -0.1d0 ! 2pX function
! cmoref(6+shift,2,1) = 0.1d0 ! 2pZ function
! ! 4-6
! i_atom = 4
! shift = (i_atom -1) * 15
! cmoref(1+shift,3,1) = -0.012d0 ! 2S function
! cmoref(2+shift,3,1) = 0.18d0 !
! cmoref(3+shift,3,1) = 0.1d0 !
! cmoref(5+shift,3,1) = 0.1d0 ! 2pX function
! cmoref(6+shift,3,1) = -0.1d0 ! 2pZ function
! i_atom = 6
! shift = (i_atom -1) * 15
! cmoref(1+shift,3,1) = -0.012d0 ! 2S function
! cmoref(2+shift,3,1) = 0.18d0 !
! cmoref(3+shift,3,1) = 0.1d0 !
! cmoref(5+shift,3,1) = -0.1d0 ! 2pX function
! cmoref(6+shift,3,1) = 0.1d0 ! 2pZ function
! ! 6-5
! i_atom = 6
! shift = (i_atom -1) * 15
! cmoref(1+shift,4,1) = -0.012d0 ! 2S function
! cmoref(2+shift,4,1) = 0.18d0 !
! cmoref(3+shift,4,1) = 0.1d0 !
! cmoref(5+shift,4,1) = 0.1d0 ! 2pX function
! cmoref(6+shift,4,1) = 0.1d0 ! 2pZ function
! i_atom = 5
! shift = (i_atom -1) * 15
! cmoref(1+shift,4,1) = -0.012d0 ! 2S function
! cmoref(2+shift,4,1) = 0.18d0 !
! cmoref(3+shift,4,1) = 0.1d0 !
! cmoref(5+shift,4,1) = -0.1d0 ! 2pX function
! cmoref(6+shift,4,1) = -0.1d0 ! 2pZ function
! ! 2-4
! i_atom = 2
! shift = (i_atom -1) * 15
! cmoref(1+shift,5,1) = -0.012d0 ! 2S function
! cmoref(2+shift,5,1) = 0.18d0 !
! cmoref(3+shift,5,1) = 0.1d0 !
! cmoref(6+shift,5,1) = 0.1d0 ! 2pZ function
! i_atom = 4
! shift = (i_atom -1) * 15
! cmoref(1+shift,5,1) = -0.012d0 ! 2S function
! cmoref(2+shift,5,1) = 0.18d0 !
! cmoref(3+shift,5,1) = 0.1d0 !
! cmoref(6+shift,5,1) = -0.1d0 ! 2pZ function
! ! 3-5
! i_atom = 3
! shift = (i_atom -1) * 15
! cmoref(1+shift,6,1) = -0.012d0 ! 2S function
! cmoref(2+shift,6,1) = 0.18d0 !
! cmoref(3+shift,6,1) = 0.1d0 !
! cmoref(6+shift,6,1) = 0.1d0 ! 2pZ function
! i_atom = 5
! shift = (i_atom -1) * 15
! cmoref(1+shift,6,1) = -0.012d0 ! 2S function
! cmoref(2+shift,6,1) = 0.18d0 !
! cmoref(3+shift,6,1) = 0.1d0 !
! cmoref(6+shift,6,1) = -0.1d0 ! 2pZ function
! ! C-H bonds
! ! 2-7
! i_atom = 2
! shift = (i_atom -1) * 15
! cmoref(1+shift,7,1) = -0.012d0 ! 2S function
! cmoref(2+shift,7,1) = 0.18d0 !
! cmoref(3+shift,7,1) = 0.1d0 !
! cmoref(5+shift,7,1) = -0.1d0 ! 2pX function
! cmoref(6+shift,7,1) = 0.1d0 ! 2pZ function
!
! i_atom = 7
! shift_h = (6-1) * 15 + (i_atom - 6)*5
! cmoref(1+shift_h,7,1) = 0.12d0 ! 1S function
! ! 4-10
! i_atom = 4
! shift = (i_atom -1) * 15
! cmoref(1+shift,8,1) = -0.012d0 ! 2S function
! cmoref(2+shift,8,1) = 0.18d0 !
! cmoref(3+shift,8,1) = 0.1d0 !
! cmoref(5+shift,8,1) = -0.1d0 ! 2pX function
! cmoref(6+shift,8,1) = -0.1d0 ! 2pZ function
!
! i_atom = 10
! shift_h = (6-1) * 15 + (i_atom - 6)*5
! cmoref(1+shift_h,8,1) = 0.12d0 ! 1S function
! ! 5-11
! i_atom = 5
! shift = (i_atom -1) * 15
! cmoref(1+shift,9,1) = -0.012d0 ! 2S function
! cmoref(2+shift,9,1) = 0.18d0 !
! cmoref(3+shift,9,1) = 0.1d0 !
! cmoref(5+shift,9,1) = 0.1d0 ! 2pX function
! cmoref(6+shift,9,1) = -0.1d0 ! 2pZ function
!
! i_atom = 11
! shift_h = (6-1) * 15 + (i_atom - 6)*5
! cmoref(1+shift_h,9,1) = 0.12d0 ! 1S function
! ! 3-8
! i_atom = 3
! shift = (i_atom -1) * 15
! cmoref(1+shift,10,1) = -0.012d0 ! 2S function
! cmoref(2+shift,10,1) = 0.18d0 !
! cmoref(3+shift,10,1) = 0.1d0 !
!
! cmoref(5+shift,10,1) = 0.1d0 ! 2pX function
! cmoref(6+shift,10,1) = 0.1d0 ! 2pZ function
!
! i_atom = 8
! shift_h = (6-1) * 15 + (i_atom - 6)*5
! cmoref(1+shift_h,10,1) = 0.12d0 ! 1S function
! ! 1-9
! i_atom = 1
! shift = (i_atom -1) * 15
! cmoref(1+shift,11,1) = -0.012d0 ! 2S function
! cmoref(2+shift,11,1) = 0.18d0 !
! cmoref(3+shift,11,1) = 0.1d0 !
!
! cmoref(6+shift,11,1) = 0.1d0 ! 2pZ function
! i_atom = 9
! shift_h = (6-1) * 15 + (i_atom - 6)*5
! cmoref(1+shift_h,11,1) = 0.12d0 ! 1S function
!
! ! 6-12
! i_atom = 6
! shift = (i_atom -1) * 15
! cmoref(1+shift,12,1) = -0.012d0 ! 2S function
! cmoref(2+shift,12,1) = 0.18d0 !
! cmoref(3+shift,12,1) = 0.1d0 !
!
! cmoref(6+shift,12,1) = -0.1d0 ! 2pZ function
! i_atom = 12
! shift_h = (6-1) * 15 + (i_atom - 6)*5
! cmoref(1+shift_h,12,1) = 0.12d0 ! 1S function
! cmoref(12,1,1) = 1.d0 !
! cmoref(21,2,1) = 1.d0 !
! cmoref(30,2,1) = 1.d0 !
! cmoref(39,3,1) = 1.d0 !
! cmoref(48,3,1) = 1.d0 !
! cmoref(3,4,1) = 1.d0 !
! cmoref(12,4,1) =-1.d0 !
! cmoref(21,5,1) = 1.d0 !
! cmoref(30,5,1) =-1.d0 !
! cmoref(39,6,1) = 1.d0 !
! cmoref(48,6,1) =-1.d0 !
print*,'passed the definition of the referent vectors ' print*,'passed the definition of the referent vectors '
!Building the S (overlap) matrix in the AO basis.
do i = 1, ao_num do i = 1, ao_num
do j = 1, ao_num do j =1, ao_num
s(i,j,1) = ao_overlap(i,j) s(i,j,1) = ao_overlap(i,j)
enddo enddo
enddo enddo
!Now big loop over symmetry !Now big loop over symmetry
@ -398,20 +397,13 @@
! do i=1,nmo(isym) ! do i=1,nmo(isym)
do i=1,ao_num
do j=1,nrot(isym) do j=1,nrot(isym)
do i=1,ao_num
ddum(i,j)=0.d0 ddum(i,j)=0.d0
do k=1,ao_num
do k=1,ao_num ddum(i,j)=ddum(i,j)+s(i,k,isym)*cmo(k,irot(j,isym),isym)
enddo
ddum(i,j)=ddum(i,j)+s(i,k,isym)*cmo(k,irot(j,isym),isym) enddo
enddo
enddo
enddo enddo
@ -441,7 +433,7 @@
do i=1,nrot(isym) do i=1,nrot(isym)
do j=1,ao_num do j=1,ao_num
write (6,*) 'isym,',isym,nrot(isym),nmo(isym) ! write (6,*) 'isym,',isym,nrot(isym),nmo(isym)
newcmo(j,irot(i,isym),isym)=0.d0 newcmo(j,irot(i,isym),isym)=0.d0
do k=1,nrot(isym) do k=1,nrot(isym)
newcmo(j,irot(i,isym),isym)=newcmo(j,irot(i,isym),isym) + cmo(j,irot(k,isym),isym)*t(k,i) newcmo(j,irot(i,isym),isym)=newcmo(j,irot(i,isym),isym) + cmo(j,irot(k,isym),isym)*t(k,i)
@ -459,7 +451,7 @@
enddo !big loop over symmetry enddo !big loop over symmetry
10 format (4E20.12) 10 format (4E18.12)
! Now we copyt the newcmo into the mo_coef ! Now we copyt the newcmo into the mo_coef
@ -472,9 +464,7 @@
enddo enddo
enddo enddo
enddo enddo
! if(dabs(newcmo(3,19,1) - mo_coef(3,19)) .gt.1.d-10 )then ! pause
print*,'mo_coef(3,19)',mo_coef(3,19)
pause
! we say that it hase been touched, and valid and that everything that ! we say that it hase been touched, and valid and that everything that

5
plugins/mrcepa0/EZFIO.cfg Normal file
View File

@ -0,0 +1,5 @@
[lambda_type]
type: Strictly_positive_int
doc: lambda type ( 0 = none, 1 = last version )
interface: ezfio,provider,ocaml
default: 0

43
plugins/mrcepa0/dressing.irp.f
View File

@ -6,7 +6,7 @@ use bitmasks
&BEGIN_PROVIDER [ double precision, delta_ii_mrcc, (N_states, N_det_ref) ] &BEGIN_PROVIDER [ double precision, delta_ii_mrcc, (N_states, N_det_ref) ]
use bitmasks use bitmasks
implicit none implicit none
integer :: gen, h, p, i_state, n, t, i, h1, h2, p1, p2, s1, s2, iproc integer :: gen, h, p, n, t, i, h1, h2, p1, p2, s1, s2, iproc
integer(bit_kind) :: mask(N_int, 2), omask(N_int, 2) integer(bit_kind) :: mask(N_int, 2), omask(N_int, 2)
integer(bit_kind),allocatable :: buf(:,:,:) integer(bit_kind),allocatable :: buf(:,:,:)
logical :: ok logical :: ok
@ -14,16 +14,16 @@ use bitmasks
delta_ij_mrcc = 0d0 delta_ij_mrcc = 0d0
delta_ii_mrcc = 0d0 delta_ii_mrcc = 0d0
i_state = 1 print *, "Dij", dij(1,1,1)
provide hh_shortcut psi_det_size! lambda_mrcc provide hh_shortcut psi_det_size! lambda_mrcc
!$OMP PARALLEL DO default(none) schedule(dynamic) & !$OMP PARALLEL DO default(none) schedule(dynamic) &
!$OMP shared(psi_det_generators, N_det_generators, hh_exists, pp_exists, N_int, hh_shortcut) & !$OMP shared(psi_det_generators, N_det_generators, hh_exists, pp_exists, N_int, hh_shortcut) &
!$OMP shared(N_states, N_det_non_ref, N_det_ref, delta_ii_mrcc, delta_ij_mrcc) & !$OMP shared(N_det_non_ref, N_det_ref, delta_ii_mrcc, delta_ij_mrcc) &
!$OMP private(h, n, mask, omask, buf, ok, iproc) !$OMP private(h, n, mask, omask, buf, ok, iproc)
do gen= 1, N_det_generators do gen= 1, N_det_generators
allocate(buf(N_int, 2, N_det_non_ref)) allocate(buf(N_int, 2, N_det_non_ref))
iproc = omp_get_thread_num() + 1 iproc = omp_get_thread_num() + 1
print *, gen, "/", N_det_generators if(mod(gen, 10) == 0) print *, "mrcc ", gen, "/", N_det_generators
do h=1, hh_shortcut(0) do h=1, hh_shortcut(0)
call apply_hole(psi_det_generators(1,1,gen), hh_exists(1, h), mask, ok, N_int) call apply_hole(psi_det_generators(1,1,gen), hh_exists(1, h), mask, ok, N_int)
if(.not. ok) cycle if(.not. ok) cycle
@ -36,7 +36,9 @@ use bitmasks
if(n > N_det_non_ref) stop "MRCC..." if(n > N_det_non_ref) stop "MRCC..."
end do end do
n = n - 1 n = n - 1
if(n /= 0) call mrcc_part_dress(delta_ij_mrcc, delta_ii_mrcc,gen,n,buf,N_int,omask) if(n /= 0) call mrcc_part_dress(delta_ij_mrcc, delta_ii_mrcc,gen,n,buf,N_int,omask)
end do end do
deallocate(buf) deallocate(buf)
end do end do
@ -86,7 +88,8 @@ subroutine mrcc_part_dress(delta_ij_, delta_ii_,i_generator,n_selected,det_buffe
integer, allocatable :: idx_microlist(:), N_microlist(:), ptr_microlist(:), idx_microlist_zero(:) integer, allocatable :: idx_microlist(:), N_microlist(:), ptr_microlist(:), idx_microlist_zero(:)
integer :: mobiles(2), smallerlist integer :: mobiles(2), smallerlist
logical, external :: detEq, is_generable logical, external :: detEq, is_generable
double precision, external :: get_dij, get_dij_index !double precision, external :: get_dij, get_dij_index
leng = max(N_det_generators, N_det_non_ref) leng = max(N_det_generators, N_det_non_ref)
allocate(miniList(Nint, 2, leng), tq(Nint,2,n_selected), idx_minilist(leng), hij_cache(N_det_non_ref)) allocate(miniList(Nint, 2, leng), tq(Nint,2,n_selected), idx_minilist(leng), hij_cache(N_det_non_ref))
@ -171,7 +174,6 @@ subroutine mrcc_part_dress(delta_ij_, delta_ii_,i_generator,n_selected,det_buffe
idx_alpha(j) = idx_microlist_zero(idx_alpha(j)) idx_alpha(j) = idx_microlist_zero(idx_alpha(j))
end do end do
else else
call get_excitation_degree_vector(miniList,tq(1,1,i_alpha),degree_alpha,Nint,N_minilist,idx_alpha) call get_excitation_degree_vector(miniList,tq(1,1,i_alpha),degree_alpha,Nint,N_minilist,idx_alpha)
do j=1,idx_alpha(0) do j=1,idx_alpha(0)
@ -184,7 +186,6 @@ subroutine mrcc_part_dress(delta_ij_, delta_ii_,i_generator,n_selected,det_buffe
k_sd = idx_alpha(l_sd) k_sd = idx_alpha(l_sd)
call i_h_j(tq(1,1,i_alpha),psi_non_ref(1,1,idx_alpha(l_sd)),Nint,hij_cache(k_sd)) call i_h_j(tq(1,1,i_alpha),psi_non_ref(1,1,idx_alpha(l_sd)),Nint,hij_cache(k_sd))
enddo enddo
! |I> ! |I>
do i_I=1,N_det_ref do i_I=1,N_det_ref
! Find triples and quadruple grand parents ! Find triples and quadruple grand parents
@ -199,7 +200,6 @@ subroutine mrcc_part_dress(delta_ij_, delta_ii_,i_generator,n_selected,det_buffe
! <I| <> |alpha> ! <I| <> |alpha>
do k_sd=1,idx_alpha(0) do k_sd=1,idx_alpha(0)
! Loop if lambda == 0 ! Loop if lambda == 0
logical :: loop logical :: loop
! loop = .True. ! loop = .True.
@ -220,18 +220,16 @@ subroutine mrcc_part_dress(delta_ij_, delta_ii_,i_generator,n_selected,det_buffe
! <I| /k\ |alpha> ! <I| /k\ |alpha>
! <I|H|k> ! <I|H|k>
hIk = hij_mrcc(idx_alpha(k_sd),i_I) !hIk = hij_mrcc(idx_alpha(k_sd),i_I)
! call i_h_j(psi_ref(1,1,i_I),psi_non_ref(1,1,idx_alpha(k_sd)),Nint,hIk) ! call i_h_j(psi_ref(1,1,i_I),psi_non_ref(1,1,idx_alpha(k_sd)),Nint,hIk)
do i_state=1,N_states do i_state=1,N_states
dIK(i_state) = get_dij_index(i_I, idx_alpha(k_sd), Nint) dIK(i_state) = dij(i_I, idx_alpha(k_sd), i_state)
!dIk(i_state) = get_dij(psi_ref(1,1,i_I), psi_non_ref(1,1,idx_alpha(k_sd)), N_int) !!hIk * lambda_mrcc(i_state,idx_alpha(k_sd)) !dIk(i_state) = get_dij(psi_ref(1,1,i_I), psi_non_ref(1,1,idx_alpha(k_sd)), N_int) !!hIk * lambda_mrcc(i_state,idx_alpha(k_sd))
!dIk(i_state) = psi_non_ref_coef(idx_alpha(k_sd), i_state) / psi_ref_coef(i_I, i_state) !dIk(i_state) = psi_non_ref_coef(idx_alpha(k_sd), i_state) / psi_ref_coef(i_I, i_state)
enddo enddo
! |l> = Exc(k -> alpha) |I> ! |l> = Exc(k -> alpha) |I>
call get_excitation(psi_non_ref(1,1,idx_alpha(k_sd)),tq(1,1,i_alpha),exc,degree,phase,Nint) call get_excitation(psi_non_ref(1,1,idx_alpha(k_sd)),tq(1,1,i_alpha),exc,degree,phase,Nint)
call decode_exc(exc,degree,h1,p1,h2,p2,s1,s2) call decode_exc(exc,degree,h1,p1,h2,p2,s1,s2)
@ -239,7 +237,6 @@ subroutine mrcc_part_dress(delta_ij_, delta_ii_,i_generator,n_selected,det_buffe
tmp_det(k,1) = psi_ref(k,1,i_I) tmp_det(k,1) = psi_ref(k,1,i_I)
tmp_det(k,2) = psi_ref(k,2,i_I) tmp_det(k,2) = psi_ref(k,2,i_I)
enddo enddo
logical :: ok logical :: ok
call apply_excitation(psi_ref(1,1,i_I), exc, tmp_det, ok, Nint) call apply_excitation(psi_ref(1,1,i_I), exc, tmp_det, ok, Nint)
if(.not. ok) cycle if(.not. ok) cycle
@ -249,7 +246,6 @@ subroutine mrcc_part_dress(delta_ij_, delta_ii_,i_generator,n_selected,det_buffe
dka(i_state) = 0.d0 dka(i_state) = 0.d0
enddo enddo
do l_sd=k_sd+1,idx_alpha(0) do l_sd=k_sd+1,idx_alpha(0)
call get_excitation_degree(tmp_det,psi_non_ref(1,1,idx_alpha(l_sd)),degree,Nint) call get_excitation_degree(tmp_det,psi_non_ref(1,1,idx_alpha(l_sd)),degree,Nint)
if (degree == 0) then if (degree == 0) then
@ -266,7 +262,7 @@ subroutine mrcc_part_dress(delta_ij_, delta_ii_,i_generator,n_selected,det_buffe
hIl = hij_mrcc(idx_alpha(l_sd),i_I) hIl = hij_mrcc(idx_alpha(l_sd),i_I)
! call i_h_j(psi_ref(1,1,i_I),psi_non_ref(1,1,idx_alpha(l_sd)),Nint,hIl) ! call i_h_j(psi_ref(1,1,i_I),psi_non_ref(1,1,idx_alpha(l_sd)),Nint,hIl)
do i_state=1,N_states do i_state=1,N_states
dka(i_state) = get_dij_index(i_I, idx_alpha(l_sd), N_int) * phase * phase2 dka(i_state) = dij(i_I, idx_alpha(l_sd), i_state) * phase * phase2
!dka(i_state) = get_dij(psi_ref(1,1,i_I), psi_non_ref(1,1,idx_alpha(l_sd)), N_int) * phase * phase2 !hIl * lambda_mrcc(i_state,idx_alpha(l_sd)) * phase * phase2 !dka(i_state) = get_dij(psi_ref(1,1,i_I), psi_non_ref(1,1,idx_alpha(l_sd)), N_int) * phase * phase2 !hIl * lambda_mrcc(i_state,idx_alpha(l_sd)) * phase * phase2
!dka(i_state) = psi_non_ref_coef(idx_alpha(l_sd), i_state) / psi_ref_coef(i_I, i_state) * phase * phase2 !dka(i_state) = psi_non_ref_coef(idx_alpha(l_sd), i_state) / psi_ref_coef(i_I, i_state) * phase * phase2
enddo enddo
@ -279,7 +275,7 @@ subroutine mrcc_part_dress(delta_ij_, delta_ii_,i_generator,n_selected,det_buffe
dIa(i_state) = dIa(i_state) + dIk(i_state) * dka(i_state) dIa(i_state) = dIa(i_state) + dIk(i_state) * dka(i_state)
enddo enddo
enddo enddo
do i_state=1,N_states do i_state=1,N_states
ci_inv(i_state) = psi_ref_coef_inv(i_I,i_state) ci_inv(i_state) = psi_ref_coef_inv(i_I,i_state)
enddo enddo
@ -292,7 +288,6 @@ subroutine mrcc_part_dress(delta_ij_, delta_ii_,i_generator,n_selected,det_buffe
enddo enddo
enddo enddo
call omp_set_lock( psi_ref_lock(i_I) ) call omp_set_lock( psi_ref_lock(i_I) )
do i_state=1,N_states do i_state=1,N_states
if(dabs(psi_ref_coef(i_I,i_state)).ge.5.d-5)then if(dabs(psi_ref_coef(i_I,i_state)).ge.5.d-5)then
do l_sd=1,idx_alpha(0) do l_sd=1,idx_alpha(0)
@ -546,12 +541,12 @@ END_PROVIDER
implicit none implicit none
integer :: i,j,k integer :: i,j,k
double precision :: Hjk, Hki, Hij double precision :: Hjk, Hki, Hij
double precision, external :: get_dij !double precision, external :: get_dij
integer i_state, degree integer i_state, degree
provide lambda_mrcc dIj provide lambda_mrcc dIj
do i_state = 1, N_states do i_state = 1, N_states
!$OMP PARALLEL DO default(none) schedule(dynamic) private(j,k,Hjk,Hki,degree) shared(no_mono_dressing,lambda_mrcc,i_state, N_det_non_ref,psi_ref, psi_non_ref,N_int,delta_cas,N_det_ref) !$OMP PARALLEL DO default(none) schedule(dynamic) private(j,k,Hjk,Hki,degree) shared(lambda_mrcc,i_state, N_det_non_ref,psi_ref, psi_non_ref,N_int,delta_cas,N_det_ref,dij)
do i=1,N_det_ref do i=1,N_det_ref
do j=1,i do j=1,i
call get_excitation_degree(psi_ref(1,1,i), psi_ref(1,1,j), degree, N_int) call get_excitation_degree(psi_ref(1,1,i), psi_ref(1,1,j), degree, N_int)
@ -561,7 +556,7 @@ END_PROVIDER
call i_h_j(psi_ref(1,1,j), psi_non_ref(1,1,k),N_int,Hjk) call i_h_j(psi_ref(1,1,j), psi_non_ref(1,1,k),N_int,Hjk)
call i_h_j(psi_non_ref(1,1,k),psi_ref(1,1,i), N_int,Hki) call i_h_j(psi_non_ref(1,1,k),psi_ref(1,1,i), N_int,Hki)
delta_cas(i,j,i_state) += Hjk * get_dij(psi_ref(1,1,i), psi_non_ref(1,1,k), N_int) ! * Hki * lambda_mrcc(i_state, k) delta_cas(i,j,i_state) += Hjk * dij(i, k, i_state) ! * Hki * lambda_mrcc(i_state, k)
!print *, Hjk * get_dij(psi_ref(1,1,i), psi_non_ref(1,1,k), N_int), Hki * get_dij(psi_ref(1,1,j), psi_non_ref(1,1,k), N_int) !print *, Hjk * get_dij(psi_ref(1,1,i), psi_non_ref(1,1,k), N_int), Hki * get_dij(psi_ref(1,1,j), psi_non_ref(1,1,k), N_int)
end do end do
delta_cas(j,i,i_state) = delta_cas(i,j,i_state) delta_cas(j,i,i_state) = delta_cas(i,j,i_state)
@ -659,7 +654,7 @@ end function
integer, allocatable :: idx_sorted_bit(:) integer, allocatable :: idx_sorted_bit(:)
integer, external :: get_index_in_psi_det_sorted_bit, searchDet integer, external :: get_index_in_psi_det_sorted_bit, searchDet
logical, external :: is_in_wavefunction, detEq logical, external :: is_in_wavefunction, detEq
double precision, external :: get_dij !double precision, external :: get_dij
integer :: II, blok integer :: II, blok
integer*8, save :: notf = 0 integer*8, save :: notf = 0
@ -675,7 +670,7 @@ end function
enddo enddo
! To provide everything ! To provide everything
contrib = get_dij(psi_ref(1,1,1), psi_non_ref(1,1,1), N_int) contrib = dij(1, 1, 1)
do i_state = 1, N_states do i_state = 1, N_states
delta_mrcepa0_ii(:,:) = 0d0 delta_mrcepa0_ii(:,:) = 0d0
@ -685,7 +680,7 @@ end function
!$OMP private(m,i,II,J,k,degree,myActive,made_hole,made_particle,hjk,contrib) & !$OMP private(m,i,II,J,k,degree,myActive,made_hole,made_particle,hjk,contrib) &
!$OMP shared(active_sorb, psi_non_ref, psi_non_ref_coef, psi_ref, psi_ref_coef, cepa0_shortcut, det_cepa0_active) & !$OMP shared(active_sorb, psi_non_ref, psi_non_ref_coef, psi_ref, psi_ref_coef, cepa0_shortcut, det_cepa0_active) &
!$OMP shared(N_det_ref, N_det_non_ref,N_int,det_cepa0_idx,lambda_mrcc,det_ref_active, delta_cas) & !$OMP shared(N_det_ref, N_det_non_ref,N_int,det_cepa0_idx,lambda_mrcc,det_ref_active, delta_cas) &
!$OMP shared(notf,i_state, sortRef, sortRefIdx) !$OMP shared(notf,i_state, sortRef, sortRefIdx, dij)
do blok=1,cepa0_shortcut(0) do blok=1,cepa0_shortcut(0)
do i=cepa0_shortcut(blok), cepa0_shortcut(blok+1)-1 do i=cepa0_shortcut(blok), cepa0_shortcut(blok+1)-1
do II=1,N_det_ref do II=1,N_det_ref
@ -727,7 +722,7 @@ end function
call i_h_j(psi_non_ref(1,1,det_cepa0_idx(k)),psi_ref(1,1,J),N_int,HJk) call i_h_j(psi_non_ref(1,1,det_cepa0_idx(k)),psi_ref(1,1,J),N_int,HJk)
!contrib = delta_cas(II, J, i_state) * HJk * lambda_mrcc(i_state, det_cepa0_idx(k)) !contrib = delta_cas(II, J, i_state) * HJk * lambda_mrcc(i_state, det_cepa0_idx(k))
contrib = delta_cas(II, J, i_state) * get_dij(psi_ref(1,1,J), psi_non_ref(1,1,det_cepa0_idx(k)), N_int) contrib = delta_cas(II, J, i_state) * dij(J, det_cepa0_idx(k), i_state)
!$OMP ATOMIC !$OMP ATOMIC
delta_mrcepa0_ij(J, det_cepa0_idx(i), i_state) += contrib delta_mrcepa0_ij(J, det_cepa0_idx(i), i_state) += contrib

8
plugins/mrcepa0/dressing_slave.irp.f
View File

@ -55,7 +55,7 @@ subroutine mrsc2_dressing_slave(thread,iproc)
logical, external :: is_in_wavefunction, isInCassd, detEq logical, external :: is_in_wavefunction, isInCassd, detEq
integer,allocatable :: komon(:) integer,allocatable :: komon(:)
logical :: komoned logical :: komoned
double precision, external :: get_dij !double precision, external :: get_dij
zmq_to_qp_run_socket = new_zmq_to_qp_run_socket() zmq_to_qp_run_socket = new_zmq_to_qp_run_socket()
zmq_socket_push = new_zmq_push_socket(thread) zmq_socket_push = new_zmq_push_socket(thread)
@ -144,7 +144,7 @@ subroutine mrsc2_dressing_slave(thread,iproc)
! if(I_i == J) phase_Ii = phase_Ji ! if(I_i == J) phase_Ii = phase_Ji
do i_state = 1,N_states do i_state = 1,N_states
dkI = h_(J,i) * get_dij(psi_ref(1,1,i_I), psi_non_ref(1,1,i), N_int) dkI = h_(J,i) * dij(i_I, i, i_state)!get_dij(psi_ref(1,1,i_I), psi_non_ref(1,1,i), N_int)
!dkI = h_(J,i) * h_(i_I,i) * lambda_mrcc(i_state, i) !dkI = h_(J,i) * h_(i_I,i) * lambda_mrcc(i_state, i)
dleat(i_state, kn, 1) = dkI dleat(i_state, kn, 1) = dkI
dleat(i_state, kn, 2) = dkI dleat(i_state, kn, 2) = dkI
@ -174,7 +174,7 @@ subroutine mrsc2_dressing_slave(thread,iproc)
!contrib = h_(i_I,k) * lambda_mrcc(i_state, k) * dleat(i_state, m, 2)! * phase_al !contrib = h_(i_I,k) * lambda_mrcc(i_state, k) * dleat(i_state, m, 2)! * phase_al
contrib = get_dij(psi_ref(1,1,i_I), psi_non_ref(1,1,k), N_int) * dleat(i_state, m, 2) contrib = dij(i_I, k, i_state) * dleat(i_state, m, 2)
delta(i_state,ll,1) += contrib delta(i_state,ll,1) += contrib
if(dabs(psi_ref_coef(i_I,i_state)).ge.5.d-5) then if(dabs(psi_ref_coef(i_I,i_state)).ge.5.d-5) then
delta(i_state,0,1) -= contrib * ci_inv(i_state) * psi_non_ref_coef(l,i_state) delta(i_state,0,1) -= contrib * ci_inv(i_state) * psi_non_ref_coef(l,i_state)
@ -182,7 +182,7 @@ subroutine mrsc2_dressing_slave(thread,iproc)
if(I_i == J) cycle if(I_i == J) cycle
!contrib = h_(J,l) * lambda_mrcc(i_state, l) * dleat(i_state, m, 1)! * phase_al !contrib = h_(J,l) * lambda_mrcc(i_state, l) * dleat(i_state, m, 1)! * phase_al
contrib = get_dij(psi_ref(1,1,J), psi_non_ref(1,1,l), N_int) * dleat(i_state, m, 1) contrib = dij(J, l, i_state) * dleat(i_state, m, 1)
delta(i_state,kk,2) += contrib delta(i_state,kk,2) += contrib
if(dabs(psi_ref_coef(J,i_state)).ge.5.d-5) then if(dabs(psi_ref_coef(J,i_state)).ge.5.d-5) then
delta(i_state,0,2) -= contrib * cj_inv(i_state) * psi_non_ref_coef(k,i_state) delta(i_state,0,2) -= contrib * cj_inv(i_state) * psi_non_ref_coef(k,i_state)

43
plugins/mrcepa0/mrcepa0_general.irp.f
View File

@ -16,10 +16,11 @@ subroutine run(N_st,energy)
double precision :: thresh_mrcc double precision :: thresh_mrcc
thresh_mrcc = 1d-7 thresh_mrcc = 1d-7
n_it_mrcc_max = 10 n_it_mrcc_max = 10
if(no_mono_dressing) then if(n_it_mrcc_max == 1) then
do j=1,N_states_diag do j=1,N_states_diag
do i=1,N_det do i=1,N_det
psi_coef(i,j) = CI_eigenvectors_dressed(i,j) psi_coef(i,j) = CI_eigenvectors_dressed(i,j)
@ -73,44 +74,8 @@ subroutine run_pt2(N_st,energy)
print*,'Last iteration only to compute the PT2' print*,'Last iteration only to compute the PT2'
threshold_selectors = 1.d0 threshold_selectors = 1.d0
threshold_generators = 0.999d0 threshold_generators = 0.999d0
! N_det_generators = lambda_mrcc_pt2(0)
! do i=1,N_det_generators
! j = lambda_mrcc_pt2(i)
! do k=1,N_int
! psi_det_generators(k,1,i) = psi_non_ref(k,1,j)
! psi_det_generators(k,2,i) = psi_non_ref(k,2,j)
! enddo
! do k=1,N_st
! psi_coef_generators(i,k) = psi_non_ref_coef(j,k)
! enddo
! enddo
! SOFT_TOUCH N_det_generators psi_det_generators psi_coef_generators ci_eigenvectors_dressed ci_eigenvectors_s2_dressed ci_electronic_energy_dressed
!
! N_det_generators = lambda_mrcc_pt2(0) + N_det_cas
! do i=1,N_det_cas
! do k=1,N_int
! psi_det_generators(k,1,i) = psi_ref(k,1,i)
! psi_det_generators(k,2,i) = psi_ref(k,2,i)
! enddo
! do k=1,N_st
! psi_coef_generators(i,k) = psi_ref_coef(i,k)
! enddo
! enddo
! do i=N_det_cas+1,N_det_generators
! j = lambda_mrcc_pt2(i - N_det_cas)
! do k=1,N_int
! psi_det_generators(k,1,i) = psi_non_ref(k,1,j)
! psi_det_generators(k,2,i) = psi_non_ref(k,2,j)
! enddo
! do k=1,N_st
! psi_coef_generators(i,k) = psi_non_ref_coef(j,k)
! enddo
! enddo
! SOFT_TOUCH N_det_generators psi_det_generators psi_coef_generators ci_eigenvectors_dressed ci_eigenvectors_s2_dressed ci_electronic_energy_dressed
N_det_generators = lambda_mrcc_pt3(0) + N_det_ref N_det_generators = lambda_mrcc_pt3(0) + N_det_ref
N_det_selectors = lambda_mrcc_pt3(0) + N_det_ref N_det_selectors = lambda_mrcc_pt3(0) + N_det_ref

27
plugins/qmcpack/qp_convert_qmcpack_to_ezfio.py
View File

@ -183,6 +183,9 @@ def get_nb_permutation(str_):
def order_l_l_sym(l_l_sym): def order_l_l_sym(l_l_sym):
l_order_mo = [i for i,_ in enumerate(l_l_sym)]
n = 1 n = 1
for i in range(len(l_l_sym)): for i in range(len(l_l_sym)):
if n != 1: if n != 1:
@ -192,11 +195,11 @@ def order_l_l_sym(l_l_sym):
l = l_l_sym[i] l = l_l_sym[i]
n = get_nb_permutation(l[2]) n = get_nb_permutation(l[2])
l_l_sym[i:i + n] = sorted(l_l_sym[i:i + n], l_l_sym[i:i + n], l_order_mo[i:i+n] = zip(*sorted(zip(l_l_sym[i:i + n],l_order_mo[i:i+n]),
key=lambda x: x[2], key=lambda x: x[0][2],
cmp=compare_gamess_style) cmp=compare_gamess_style))
return l_l_sym return l_l_sym, l_order_mo
#========================== #==========================
@ -205,8 +208,13 @@ def order_l_l_sym(l_l_sym):
l_sym_without_header = sym_raw.split("\n")[3:-2] l_sym_without_header = sym_raw.split("\n")[3:-2]
l_l_sym_raw = [i.split() for i in l_sym_without_header] l_l_sym_raw = [i.split() for i in l_sym_without_header]
print len(l_l_sym_raw)
l_l_sym_expend_sym = expend_sym_l(l_l_sym_raw) l_l_sym_expend_sym = expend_sym_l(l_l_sym_raw)
l_l_sym_ordered = order_l_l_sym(l_l_sym_expend_sym) print len(l_l_sym_expend_sym)
l_l_sym_ordered, l_order_mo = order_l_l_sym(l_l_sym_expend_sym)
#======== #========
#MO COEF #MO COEF
@ -256,7 +264,7 @@ def print_mo_coef(mo_coef_block, l_l_sym):
i_a = int(l[1]) - 1 i_a = int(l[1]) - 1
sym = l[2] sym = l[2]
print l_label[i_a], sym, " ".join('{: 3.8f}'.format(i) print l_label[i_a], sym, " ".join('{0: 3.8f}'.format(i)
for i in a[i]) for i in a[i])
if i_block != nb_block - 1: if i_block != nb_block - 1:
@ -348,6 +356,7 @@ d_rep={"+":"1","-":"0"}
det_without_header = det_raw[pos+2::] det_without_header = det_raw[pos+2::]
for line_raw in det_without_header.split("\n"): for line_raw in det_without_header.split("\n"):
line = line_raw line = line_raw
@ -355,8 +364,14 @@ for line_raw in det_without_header.split("\n"):
try: try:
float(line) float(line)
except ValueError: except ValueError:
print line_raw.strip(), len(line_raw.strip())
print l_order_mo, len(l_order_mo)
line_order = [line_raw[i] for i in l_order_mo]
line= "".join([d_rep[x] if x in d_rep else x for x in line_raw]) line= "".join([d_rep[x] if x in d_rep else x for x in line_raw])
print line.strip() print line.strip()
print "END_DET" print "END_DET"

7
scripts/compilation/qp_create_ninja.py
View File

@ -37,7 +37,7 @@ from qp_path import QP_ROOT, QP_SRC, QP_EZFIO
LIB = "" # join(QP_ROOT, "lib", "rdtsc.o") LIB = "" # join(QP_ROOT, "lib", "rdtsc.o")
EZFIO_LIB = join(QP_ROOT, "lib", "libezfio_irp.a") EZFIO_LIB = join(QP_ROOT, "lib", "libezfio_irp.a")
ZMQ_LIB = join(QP_ROOT, "lib", "libf77zmq.a") + " " + join(QP_ROOT, "lib", "libzmq.a") + " -lstdc++ -lrt" ZMQ_LIB = join(QP_ROOT, "lib", "libf77zmq.a") + " " + join(QP_ROOT, "lib", "libzmq.a") + " -lstdc++ -lrt"
ROOT_BUILD_NINJA = join(QP_ROOT, "config", "build.ninja") ROOT_BUILD_NINJA = join(QP_ROOT, "config", "build.ninja")
header = r"""# header = r"""#
@ -96,7 +96,8 @@ def ninja_create_env_variable(pwd_config_file):
l_string.append(str_) l_string.append(str_)
lib_lapack = get_compilation_option(pwd_config_file, "LAPACK_LIB") lib_lapack = get_compilation_option(pwd_config_file, "LAPACK_LIB")
l_string.append("LIB = {0} {1} {2} {3}".format(LIB, lib_lapack, EZFIO_LIB, ZMQ_LIB)) str_lib = " ".join([LIB, lib_lapack, EZFIO_LIB, ZMQ_LIB])
l_string.append("LIB = {0} ".format(str_lib))
l_string.append("") l_string.append("")
@ -387,6 +388,8 @@ def get_l_file_for_module(path_module):
l_src.append(f) l_src.append(f)
obj = '{0}.o'.format(os.path.splitext(f)[0]) obj = '{0}.o'.format(os.path.splitext(f)[0])
l_obj.append(obj) l_obj.append(obj)
elif f.lower().endswith(".o"):
l_obj.append(join(path_module.abs, f))
elif f == "EZFIO.cfg": elif f == "EZFIO.cfg":
l_depend.append(join(path_module.abs, "ezfio_interface.irp.f")) l_depend.append(join(path_module.abs, "ezfio_interface.irp.f"))

2
scripts/ezfio_interface/ei_handler.py
View File

@ -345,7 +345,7 @@ def save_ezfio_provider(path_head, dict_code_provider):
path = "{0}/ezfio_interface.irp.f".format(path_head) path = "{0}/ezfio_interface.irp.f".format(path_head)
l_output = ["! DO NOT MODIFY BY HAND", l_output = ["! DO NOT MODIFY BY HAND",
"! Created by $QP_ROOT/scripts/ezfio_interface.py", "! Created by $QP_ROOT/scripts/ezfio_interface/ei_handler.py",
"! from file {0}/EZFIO.cfg".format(path_head), "! from file {0}/EZFIO.cfg".format(path_head),
"\n"] "\n"]

33
scripts/ezfio_interface/ezfio_generate_provider.py
View File

@ -22,6 +22,7 @@ BEGIN_PROVIDER [ %(type)s, %(name)s %(size)s ]
logical :: has logical :: has
PROVIDE ezfio_filename PROVIDE ezfio_filename
%(test_null_size)s
call ezfio_has_%(ezfio_dir)s_%(ezfio_name)s(has) call ezfio_has_%(ezfio_dir)s_%(ezfio_name)s(has)
if (has) then if (has) then
call ezfio_get_%(ezfio_dir)s_%(ezfio_name)s(%(name)s) call ezfio_get_%(ezfio_dir)s_%(ezfio_name)s(%(name)s)
@ -44,6 +45,7 @@ END_PROVIDER
def __repr__(self): def __repr__(self):
self.set_write() self.set_write()
self.set_test_null_size()
for v in self.values: for v in self.values:
if not v: if not v:
msg = "Error : %s is not set in EZFIO.cfg" % (v) msg = "Error : %s is not set in EZFIO.cfg" % (v)
@ -54,20 +56,31 @@ END_PROVIDER
return self.data % self.__dict__ return self.data % self.__dict__
def set_test_null_size(self):
if "size" not in self.__dict__:
self.__dict__["size"] = ""
if self.size != "":
self.test_null_size = "if (size(%s) == 0) return\n" % ( self.name )
else:
self.test_null_size = ""
def set_write(self): def set_write(self):
self.write = "" self.write = ""
if self.type in self.write_correspondance: if "size" in self.__dict__:
write = self.write_correspondance[self.type] return
output = self.output else:
name = self.name if self.type in self.write_correspondance:
write = self.write_correspondance[self.type]
output = self.output
name = self.name
l_write = ["", l_write = ["",
" call write_time(%(output)s)", " call write_time(%(output)s)",
" call %(write)s(%(output)s, %(name)s, &", " call %(write)s(%(output)s, %(name)s, &",
" '%(name)s')", " '%(name)s')",
""] ""]
self.write = "\n".join(l_write) % locals() self.write = "\n".join(l_write) % locals()
def set_type(self, t): def set_type(self, t):
self.type = t.lower() self.type = t.lower()

10
scripts/ezfio_interface/qp_edit_template
View File

@ -6,7 +6,7 @@ open Core.Std;;
WARNING WARNING
This file is autogenerad by This file is autogenerad by
`${{QP_ROOT}}/script/ezfio_interface/ei_handler.py` `${{QP_ROOT}}/scripts/ezfio_interface/ei_handler.py`
*) *)
@ -120,7 +120,7 @@ let set str s =
| Nuclei -> write Nuclei.(of_rst, write) s | Nuclei -> write Nuclei.(of_rst, write) s
| Ao_basis -> () (* TODO *) | Ao_basis -> () (* TODO *)
| Mo_basis -> () (* TODO *) | Mo_basis -> () (* TODO *)
end end
;; ;;
@ -169,7 +169,9 @@ let run check_only ezfio_filename =
in in
(* Create the temp file *) (* Create the temp file *)
let temp_filename = create_temp_file ezfio_filename tasks in let temp_filename =
create_temp_file ezfio_filename tasks
in
(* Open the temp file with external editor *) (* Open the temp file with external editor *)
let editor = let editor =
@ -193,7 +195,7 @@ let run check_only ezfio_filename =
List.iter ~f:(fun x -> set temp_string x) tasks; List.iter ~f:(fun x -> set temp_string x) tasks;
(* Remove temp_file *) (* Remove temp_file *)
Sys.remove temp_filename; Sys.remove temp_filename
;; ;;

65
scripts/generate_h_apply.py
View File

@ -8,11 +8,22 @@ copy_buffer
declarations declarations
decls_main decls_main
deinit_thread deinit_thread
do_double_excitations skip
init_main
filter_integrals
filter2p
filter2h2p_double
filter2h2p_single
filter1h filter1h
filter1p filter1p
filter2h2p only_2p_single
filter2p only_2p_double
filter_only_1h1p_single
filter_only_1h1p_double
filter_only_1h2p_single
filter_only_1h2p_double
filter_only_2h2p_single
filter_only_2h2p_double
filterhole filterhole
filter_integrals filter_integrals
filter_only_1h1p_double filter_only_1h1p_double
@ -182,7 +193,7 @@ class H_apply(object):
if (is_a_2p(hole)) cycle if (is_a_2p(hole)) cycle
""" """
def filter_1p(self): def filter_1p(self):
self["filter0p"] = """ self["filter1p"] = """
! ! DIR$ FORCEINLINE ! ! DIR$ FORCEINLINE
if (is_a_1p(hole)) cycle if (is_a_1p(hole)) cycle
""" """
@ -208,6 +219,27 @@ class H_apply(object):
if (is_a_1h1p(key).eqv..False.) cycle if (is_a_1h1p(key).eqv..False.) cycle
""" """
def filter_only_2h2p(self):
self["filter_only_2h2p_single"] = """
! ! DIR$ FORCEINLINE
if (is_a_two_holes_two_particles(hole).eqv..False.) cycle
"""
self["filter_only_1h1p_double"] = """
! ! DIR$ FORCEINLINE
if (is_a_two_holes_two_particles(key).eqv..False.) cycle
"""
def filter_only_1h2p(self):
self["filter_only_1h2p_single"] = """
! ! DIR$ FORCEINLINE
if (is_a_1h2p(hole).eqv..False.) cycle
"""
self["filter_only_1h2p_double"] = """
! ! DIR$ FORCEINLINE
if (is_a_1h2p(key).eqv..False.) cycle
"""
def unset_skip(self): def unset_skip(self):
self["skip"] = """ self["skip"] = """
@ -215,9 +247,12 @@ class H_apply(object):
def set_filter_2h_2p(self): def set_filter_2h_2p(self):
self["filter2h2p"] = """ self["filter2h2p_double"] = """
if (is_a_two_holes_two_particles(key)) cycle if (is_a_two_holes_two_particles(key)) cycle
""" """
self["filter2h2p_single"] = """
if (is_a_two_holes_two_particles(hole)) cycle
"""
def set_perturbation(self,pert): def set_perturbation(self,pert):
@ -248,13 +283,13 @@ class H_apply(object):
""" """
self.data["deinit_thread"] = """ self.data["deinit_thread"] = """
!$ call omp_set_lock(lck) ! OMP CRITICAL
do k=1,N_st do k=1,N_st
sum_e_2_pert_in(k) = sum_e_2_pert_in(k) + sum_e_2_pert(k) sum_e_2_pert_in(k) = sum_e_2_pert_in(k) + sum_e_2_pert(k)
sum_norm_pert_in(k) = sum_norm_pert_in(k) + sum_norm_pert(k) sum_norm_pert_in(k) = sum_norm_pert_in(k) + sum_norm_pert(k)
sum_H_pert_diag_in(k) = sum_H_pert_diag_in(k) + sum_H_pert_diag(k) sum_H_pert_diag_in(k) = sum_H_pert_diag_in(k) + sum_H_pert_diag(k)
enddo enddo
!$ call omp_unset_lock(lck) ! OMP END CRITICAL
deallocate (e_2_pert_buffer, coef_pert_buffer) deallocate (e_2_pert_buffer, coef_pert_buffer)
""" """
self.data["size_max"] = "8192" self.data["size_max"] = "8192"
@ -356,12 +391,12 @@ class H_apply(object):
self.data["skip"] = """ self.data["skip"] = """
if (i_generator < size_select_max) then if (i_generator < size_select_max) then
if (select_max(i_generator) < selection_criterion_min*selection_criterion_factor) then if (select_max(i_generator) < selection_criterion_min*selection_criterion_factor) then
!$ call omp_set_lock(lck) ! OMP CRITICAL
do k=1,N_st do k=1,N_st
norm_psi(k) = norm_psi(k) + psi_coef_generators(i_generator,k)*psi_coef_generators(i_generator,k) norm_psi(k) = norm_psi(k) + psi_coef_generators(i_generator,k)*psi_coef_generators(i_generator,k)
pt2_old(k) = 0.d0 pt2_old(k) = 0.d0
enddo enddo
!$ call omp_unset_lock(lck) ! OMP END CRITICAL
cycle cycle
endif endif
select_max(i_generator) = 0.d0 select_max(i_generator) = 0.d0
@ -401,7 +436,16 @@ class H_apply_zmq(H_apply):
H_pert_diag(k) = 0.d0 H_pert_diag(k) = 0.d0
norm_psi(k) = 0.d0 norm_psi(k) = 0.d0
enddo enddo
""" """
self.data["copy_buffer"] = """
do i=1,N_det_generators
do k=1,N_st
pt2(k) = pt2(k) + pt2_generators(k,i)
norm_pert(k) = norm_pert(k) + norm_pert_generators(k,i)
H_pert_diag(k) = H_pert_diag(k) + H_pert_diag_generators(k,i)
enddo
enddo
"""
def set_selection_pt2(self,pert): def set_selection_pt2(self,pert):
H_apply.set_selection_pt2(self,pert) H_apply.set_selection_pt2(self,pert)
@ -416,3 +460,4 @@ class H_apply_zmq(H_apply):
select_max(i_generator) = 0.d0 select_max(i_generator) = 0.d0
endif endif
""" """

211
src/AO_Basis/aos.irp.f
View File

@ -25,7 +25,7 @@ END_PROVIDER
BEGIN_DOC BEGIN_DOC
! Coefficients including the AO normalization ! Coefficients including the AO normalization
END_DOC END_DOC
double precision :: norm, norm2,overlap_x,overlap_y,overlap_z,C_A(3), c double precision :: norm,overlap_x,overlap_y,overlap_z,C_A(3), c
integer :: l, powA(3), nz integer :: l, powA(3), nz
integer :: i,j,k integer :: i,j,k
nz=100 nz=100
@ -34,9 +34,11 @@ END_PROVIDER
C_A(3) = 0.d0 C_A(3) = 0.d0
ao_coef_normalized = 0.d0 ao_coef_normalized = 0.d0
do i=1,ao_num do i=1,ao_num
powA(1) = ao_power(i,1) powA(1) = ao_power(i,1)
powA(2) = ao_power(i,2) powA(2) = ao_power(i,2)
powA(3) = ao_power(i,3) powA(3) = ao_power(i,3)
do j=1,ao_prim_num(i) do j=1,ao_prim_num(i)
call overlap_gaussian_xyz(C_A,C_A,ao_expo(i,j),ao_expo(i,j),powA,powA,overlap_x,overlap_y,overlap_z,norm,nz) call overlap_gaussian_xyz(C_A,C_A,ao_expo(i,j),ao_expo(i,j),powA,powA,overlap_x,overlap_y,overlap_z,norm,nz)
ao_coef_normalized(i,j) = ao_coef(i,j)/sqrt(norm) ao_coef_normalized(i,j) = ao_coef(i,j)/sqrt(norm)
@ -51,8 +53,42 @@ END_PROVIDER
enddo enddo
ao_coef_normalization_factor(i) = 1.d0/sqrt(norm) ao_coef_normalization_factor(i) = 1.d0/sqrt(norm)
enddo enddo
END_PROVIDER END_PROVIDER
BEGIN_PROVIDER [ double precision, ao_coef_normalization_libint_factor, (ao_num) ]
implicit none
BEGIN_DOC
! Coefficients including the AO normalization
END_DOC
double precision :: norm,overlap_x,overlap_y,overlap_z,C_A(3), c
integer :: l, powA(3), nz
integer :: i,j,k
nz=100
C_A(1) = 0.d0
C_A(2) = 0.d0
C_A(3) = 0.d0
do i=1,ao_num
powA(1) = ao_l(i)
powA(2) = 0
powA(3) = 0
! Normalization of the contracted basis functions
norm = 0.d0
do j=1,ao_prim_num(i)
do k=1,ao_prim_num(i)
call overlap_gaussian_xyz(C_A,C_A,ao_expo(i,j),ao_expo(i,k),powA,powA,overlap_x,overlap_y,overlap_z,c,nz)
norm = norm+c*ao_coef_normalized(i,j)*ao_coef_normalized(i,k)
enddo
enddo
ao_coef_normalization_libint_factor(i) = ao_coef_normalization_factor(i) * sqrt(norm)
enddo
END_PROVIDER
BEGIN_PROVIDER [ double precision, ao_coef_normalized_ordered, (ao_num_align,ao_prim_num_max) ] BEGIN_PROVIDER [ double precision, ao_coef_normalized_ordered, (ao_num_align,ao_prim_num_max) ]
&BEGIN_PROVIDER [ double precision, ao_expo_ordered, (ao_num_align,ao_prim_num_max) ] &BEGIN_PROVIDER [ double precision, ao_expo_ordered, (ao_num_align,ao_prim_num_max) ]
implicit none implicit none
@ -170,3 +206,176 @@ BEGIN_PROVIDER [ character*(128), l_to_charater, (0:4)]
l_to_charater(4)='G' l_to_charater(4)='G'
END_PROVIDER END_PROVIDER
BEGIN_PROVIDER [ integer, Nucl_N_Aos, (nucl_num)]
&BEGIN_PROVIDER [ integer, N_AOs_max ]
implicit none
integer :: i
BEGIN_DOC
! Number of AOs per atom
END_DOC
Nucl_N_Aos = 0
do i = 1, ao_num
Nucl_N_Aos(ao_nucl(i)) +=1
enddo
N_AOs_max = maxval(Nucl_N_Aos)
END_PROVIDER
BEGIN_PROVIDER [ integer, Nucl_Aos, (nucl_num,N_AOs_max)]
implicit none
BEGIN_DOC
! List of AOs attached on each atom
END_DOC
integer :: i
integer, allocatable :: nucl_tmp(:)
allocate(nucl_tmp(nucl_num))
nucl_tmp = 0
Nucl_Aos = 0
do i = 1, ao_num
nucl_tmp(ao_nucl(i))+=1
Nucl_Aos(ao_nucl(i),nucl_tmp(ao_nucl(i))) = i
enddo
deallocate(nucl_tmp)
END_PROVIDER
BEGIN_PROVIDER [ integer, Nucl_list_shell_Aos, (nucl_num,N_AOs_max)]
&BEGIN_PROVIDER [ integer, Nucl_num_shell_Aos, (nucl_num)]
implicit none
integer :: i,j,k
BEGIN_DOC
! Index of the shell type Aos and of the corresponding Aos
! Per convention, for P,D,F and G AOs, we take the index
! of the AO with the the corresponding power in the "X" axis
END_DOC
do i = 1, nucl_num
Nucl_num_shell_Aos(i) = 0
do j = 1, Nucl_N_Aos(i)
if(ao_l(Nucl_Aos(i,j))==0)then
! S type function
Nucl_num_shell_Aos(i)+=1
Nucl_list_shell_Aos(i,Nucl_num_shell_Aos(i))=Nucl_Aos(i,j)
elseif(ao_l(Nucl_Aos(i,j))==1)then
! P type function
if(ao_power(Nucl_Aos(i,j),1)==1)then
Nucl_num_shell_Aos(i)+=1
Nucl_list_shell_Aos(i,Nucl_num_shell_Aos(i))=Nucl_Aos(i,j)
endif
elseif(ao_l(Nucl_Aos(i,j))==2)then
! D type function
if(ao_power(Nucl_Aos(i,j),1)==2)then
Nucl_num_shell_Aos(i)+=1
Nucl_list_shell_Aos(i,Nucl_num_shell_Aos(i))=Nucl_Aos(i,j)
endif
elseif(ao_l(Nucl_Aos(i,j))==3)then
! F type function
if(ao_power(Nucl_Aos(i,j),1)==3)then
Nucl_num_shell_Aos(i)+=1
Nucl_list_shell_Aos(i,Nucl_num_shell_Aos(i))=Nucl_Aos(i,j)
endif
elseif(ao_l(Nucl_Aos(i,j))==4)then
! G type function
if(ao_power(Nucl_Aos(i,j),1)==4)then
Nucl_num_shell_Aos(i)+=1
Nucl_list_shell_Aos(i,Nucl_num_shell_Aos(i))=Nucl_Aos(i,j)
endif
endif
enddo
enddo
END_PROVIDER
BEGIN_PROVIDER [ character*(4), ao_l_char_space, (ao_num) ]
implicit none
integer :: i
character*(4) :: give_ao_character_space
do i=1,ao_num
if(ao_l(i)==0)then
! S type AO
give_ao_character_space = 'S '
elseif(ao_l(i) == 1)then
! P type AO
if(ao_power(i,1)==1)then
give_ao_character_space = 'X '
elseif(ao_power(i,2) == 1)then
give_ao_character_space = 'Y '
else
give_ao_character_space = 'Z '
endif
elseif(ao_l(i) == 2)then
! D type AO
if(ao_power(i,1)==2)then
give_ao_character_space = 'XX '
elseif(ao_power(i,2) == 2)then
give_ao_character_space = 'YY '
elseif(ao_power(i,3) == 2)then
give_ao_character_space = 'ZZ '
elseif(ao_power(i,1) == 1 .and. ao_power(i,2) == 1)then
give_ao_character_space = 'XY '
elseif(ao_power(i,1) == 1 .and. ao_power(i,3) == 1)then
give_ao_character_space = 'XZ '
else
give_ao_character_space = 'YZ '
endif
elseif(ao_l(i) == 3)then
! F type AO
if(ao_power(i,1)==3)then
give_ao_character_space = 'XXX '
elseif(ao_power(i,2) == 3)then
give_ao_character_space = 'YYY '
elseif(ao_power(i,3) == 3)then
give_ao_character_space = 'ZZZ '
elseif(ao_power(i,1) == 2 .and. ao_power(i,2) == 1)then
give_ao_character_space = 'XXY '
elseif(ao_power(i,1) == 2 .and. ao_power(i,3) == 1)then
give_ao_character_space = 'XXZ '
elseif(ao_power(i,2) == 2 .and. ao_power(i,1) == 1)then
give_ao_character_space = 'YYX '
elseif(ao_power(i,2) == 2 .and. ao_power(i,3) == 1)then
give_ao_character_space = 'YYZ '
elseif(ao_power(i,3) == 2 .and. ao_power(i,1) == 1)then
give_ao_character_space = 'ZZX '
elseif(ao_power(i,3) == 2 .and. ao_power(i,2) == 1)then
give_ao_character_space = 'ZZY '
elseif(ao_power(i,3) == 1 .and. ao_power(i,2) == 1 .and. ao_power(i,3) == 1)then
give_ao_character_space = 'XYZ '
endif
elseif(ao_l(i) == 4)then
! G type AO
if(ao_power(i,1)==4)then
give_ao_character_space = 'XXXX'
elseif(ao_power(i,2) == 4)then
give_ao_character_space = 'YYYY'
elseif(ao_power(i,3) == 4)then
give_ao_character_space = 'ZZZZ'
elseif(ao_power(i,1) == 3 .and. ao_power(i,2) == 1)then
give_ao_character_space = 'XXXY'
elseif(ao_power(i,1) == 3 .and. ao_power(i,3) == 1)then
give_ao_character_space = 'XXXZ'
elseif(ao_power(i,2) == 3 .and. ao_power(i,1) == 1)then
give_ao_character_space = 'YYYX'
elseif(ao_power(i,2) == 3 .and. ao_power(i,3) == 1)then
give_ao_character_space = 'YYYZ'
elseif(ao_power(i,3) == 3 .and. ao_power(i,1) == 1)then
give_ao_character_space = 'ZZZX'
elseif(ao_power(i,3) == 3 .and. ao_power(i,2) == 1)then
give_ao_character_space = 'ZZZY'
elseif(ao_power(i,1) == 2 .and. ao_power(i,2) == 2)then
give_ao_character_space = 'XXYY'
elseif(ao_power(i,2) == 2 .and. ao_power(i,3) == 2)then
give_ao_character_space = 'YYZZ'
elseif(ao_power(i,1) == 2 .and. ao_power(i,2) == 1 .and. ao_power(i,3) == 1)then
give_ao_character_space = 'XXYZ'
elseif(ao_power(i,2) == 2 .and. ao_power(i,1) == 1 .and. ao_power(i,3) == 1)then
give_ao_character_space = 'YYXZ'
elseif(ao_power(i,3) == 2 .and. ao_power(i,1) == 1 .and. ao_power(i,2) == 1)then
give_ao_character_space = 'ZZXY'
endif
endif
ao_l_char_space(i) = give_ao_character_space
enddo
END_PROVIDER

17
src/Bitmask/bitmask_cas_routines.irp.f
View File

@ -212,6 +212,12 @@ logical function is_a_two_holes_two_particles(key_in)
implicit none implicit none
integer(bit_kind), intent(in) :: key_in(N_int,2) integer(bit_kind), intent(in) :: key_in(N_int,2)
integer :: i,i_diff integer :: i,i_diff
integer :: number_of_holes, number_of_particles
is_a_two_holes_two_particles = .False.
if(number_of_holes(key_in) == 2 .and. number_of_particles(key_in) == 2)then
is_a_two_holes_two_particles = .True.
return
endif
i_diff = 0 i_diff = 0
if(N_int == 1)then if(N_int == 1)then
i_diff = i_diff & i_diff = i_diff &
@ -456,6 +462,17 @@ logical function is_a_1h1p(key_in)
end end
logical function is_a_1h2p(key_in)
implicit none
integer(bit_kind), intent(in) :: key_in(N_int,2)
integer :: number_of_particles, number_of_holes
is_a_1h2p = .False.
if(number_of_holes(key_in).eq.1 .and. number_of_particles(key_in).eq.2)then
is_a_1h2p = .True.
endif
end
logical function is_a_1h(key_in) logical function is_a_1h(key_in)
implicit none implicit none
integer(bit_kind), intent(in) :: key_in(N_int,2) integer(bit_kind), intent(in) :: key_in(N_int,2)

43
src/Bitmask/bitmasks.irp.f
View File

@ -95,9 +95,40 @@ BEGIN_PROVIDER [ integer, N_generators_bitmask ]
END_PROVIDER END_PROVIDER
BEGIN_PROVIDER [ integer, N_generators_bitmask_restart ]
implicit none
BEGIN_DOC
! Number of bitmasks for generators
END_DOC
logical :: exists
PROVIDE ezfio_filename
call ezfio_has_bitmasks_N_mask_gen(exists)
if (exists) then
call ezfio_get_bitmasks_N_mask_gen(N_generators_bitmask_restart)
integer :: N_int_check
integer :: bit_kind_check
call ezfio_get_bitmasks_bit_kind(bit_kind_check)
if (bit_kind_check /= bit_kind) then
print *, bit_kind_check, bit_kind
print *, 'Error: bit_kind is not correct in EZFIO file'
endif
call ezfio_get_bitmasks_N_int(N_int_check)
if (N_int_check /= N_int) then
print *, N_int_check, N_int
print *, 'Error: N_int is not correct in EZFIO file'
endif
else
N_generators_bitmask_restart = 1
endif
ASSERT (N_generators_bitmask_restart > 0)
END_PROVIDER
BEGIN_PROVIDER [ integer(bit_kind), generators_bitmask_restart, (N_int,2,6,N_generators_bitmask) ]
BEGIN_PROVIDER [ integer(bit_kind), generators_bitmask_restart, (N_int,2,6,N_generators_bitmask_restart) ]
implicit none implicit none
BEGIN_DOC BEGIN_DOC
! Bitmasks for generator determinants. ! Bitmasks for generator determinants.
@ -306,7 +337,7 @@ END_PROVIDER
n_inact_orb = 0 n_inact_orb = 0
n_virt_orb = 0 n_virt_orb = 0
if(N_generators_bitmask == 1)then if(N_generators_bitmask_restart == 1)then
do j = 1, N_int do j = 1, N_int
inact_bitmask(j,1) = xor(generators_bitmask_restart(j,1,1,1),cas_bitmask(j,1,1)) inact_bitmask(j,1) = xor(generators_bitmask_restart(j,1,1,1),cas_bitmask(j,1,1))
inact_bitmask(j,2) = xor(generators_bitmask_restart(j,2,1,1),cas_bitmask(j,2,1)) inact_bitmask(j,2) = xor(generators_bitmask_restart(j,2,1,1),cas_bitmask(j,2,1))
@ -319,15 +350,15 @@ END_PROVIDER
i_hole = 1 i_hole = 1
i_gen = 1 i_gen = 1
do i = 1, N_int do i = 1, N_int
inact_bitmask(i,1) = generators_bitmask(i,1,i_hole,i_gen) inact_bitmask(i,1) = generators_bitmask_restart(i,1,i_hole,i_gen)
inact_bitmask(i,2) = generators_bitmask(i,2,i_hole,i_gen) inact_bitmask(i,2) = generators_bitmask_restart(i,2,i_hole,i_gen)
n_inact_orb += popcnt(inact_bitmask(i,1)) n_inact_orb += popcnt(inact_bitmask(i,1))
enddo enddo
i_part = 2 i_part = 2
i_gen = 3 i_gen = 3
do i = 1, N_int do i = 1, N_int
virt_bitmask(i,1) = generators_bitmask(i,1,i_part,i_gen) virt_bitmask(i,1) = generators_bitmask_restart(i,1,i_part,i_gen)
virt_bitmask(i,2) = generators_bitmask(i,2,i_part,i_gen) virt_bitmask(i,2) = generators_bitmask_restart(i,2,i_part,i_gen)
n_virt_orb += popcnt(virt_bitmask(i,1)) n_virt_orb += popcnt(virt_bitmask(i,1))
enddo enddo
endif endif

41
src/Determinants/H_apply.irp.f
View File

@ -214,8 +214,13 @@ subroutine remove_duplicates_in_psi_det(found_duplicates)
duplicate(i) = .False. duplicate(i) = .False.
enddo enddo
do i=1,N_det-1 found_duplicates = .False.
i=0
j=0
do while (i<N_det-1)
i = max(i+1,j)
if (duplicate(i)) then if (duplicate(i)) then
found_duplicates = .True.
cycle cycle
endif endif
j = i+1 j = i+1
@ -239,14 +244,6 @@ subroutine remove_duplicates_in_psi_det(found_duplicates)
enddo enddo
enddo enddo
found_duplicates = .False.
do i=1,N_det
if (duplicate(i)) then
found_duplicates = .True.
exit
endif
enddo
if (found_duplicates) then if (found_duplicates) then
call write_bool(output_determinants,found_duplicates,'Found duplicate determinants') call write_bool(output_determinants,found_duplicates,'Found duplicate determinants')
k=0 k=0
@ -307,14 +304,14 @@ subroutine fill_H_apply_buffer_no_selection(n_selected,det_buffer,Nint,iproc)
end end
subroutine push_pt2(zmq_socket_push,pt2,norm_pert,H_pert_diag,N_st,task_id) subroutine push_pt2(zmq_socket_push,pt2,norm_pert,H_pert_diag,i_generator,N_st,task_id)
use f77_zmq use f77_zmq
implicit none implicit none
BEGIN_DOC BEGIN_DOC
! Push PT2 calculation to the collector ! Push PT2 calculation to the collector
END_DOC END_DOC
integer(ZMQ_PTR), intent(in) :: zmq_socket_push integer(ZMQ_PTR), intent(in) :: zmq_socket_push
integer, intent(in) :: N_st integer, intent(in) :: N_st, i_generator
double precision, intent(in) :: pt2(N_st), norm_pert(N_st), H_pert_diag(N_st) double precision, intent(in) :: pt2(N_st), norm_pert(N_st), H_pert_diag(N_st)
integer, intent(in) :: task_id integer, intent(in) :: task_id
integer :: rc integer :: rc
@ -343,6 +340,12 @@ subroutine push_pt2(zmq_socket_push,pt2,norm_pert,H_pert_diag,N_st,task_id)
stop 'error' stop 'error'
endif endif
rc = f77_zmq_send( zmq_socket_push, i_generator, 4, ZMQ_SNDMORE)
if (rc /= 4) then
print *, irp_here, 'f77_zmq_send( zmq_socket_push, i_generator, 4, 0)'
stop 'error'
endif
rc = f77_zmq_send( zmq_socket_push, task_id, 4, 0) rc = f77_zmq_send( zmq_socket_push, task_id, 4, 0)
if (rc /= 4) then if (rc /= 4) then
print *, irp_here, 'f77_zmq_send( zmq_socket_push, task_id, 4, 0)' print *, irp_here, 'f77_zmq_send( zmq_socket_push, task_id, 4, 0)'
@ -358,7 +361,7 @@ subroutine push_pt2(zmq_socket_push,pt2,norm_pert,H_pert_diag,N_st,task_id)
! endif ! endif
end end
subroutine pull_pt2(zmq_socket_pull,pt2,norm_pert,H_pert_diag,N_st,n,task_id) subroutine pull_pt2(zmq_socket_pull,pt2,norm_pert,H_pert_diag,i_generator,N_st,n,task_id)
use f77_zmq use f77_zmq
implicit none implicit none
BEGIN_DOC BEGIN_DOC
@ -368,7 +371,7 @@ subroutine pull_pt2(zmq_socket_pull,pt2,norm_pert,H_pert_diag,N_st,n,task_id)
integer, intent(in) :: N_st integer, intent(in) :: N_st
double precision, intent(out) :: pt2(N_st), norm_pert(N_st), H_pert_diag(N_st) double precision, intent(out) :: pt2(N_st), norm_pert(N_st), H_pert_diag(N_st)
integer, intent(out) :: task_id integer, intent(out) :: task_id
integer, intent(out) :: n integer, intent(out) :: n, i_generator
integer :: rc integer :: rc
n=0 n=0
@ -386,7 +389,11 @@ subroutine pull_pt2(zmq_socket_pull,pt2,norm_pert,H_pert_diag,N_st,n,task_id)
rc = f77_zmq_recv( zmq_socket_pull, pt2(1), 8*N_st, 0) rc = f77_zmq_recv( zmq_socket_pull, pt2(1), 8*N_st, 0)
if (rc /= 8*N_st) then if (rc /= 8*N_st) then
print *, irp_here, 'f77_zmq_recv( zmq_socket_pull, pt2(1,1) , 8*N_st, 0)' print *, ''
print *, ''
print *, ''
print *, irp_here, 'f77_zmq_recv( zmq_socket_pull, pt2(1) , 8*N_st, 0)'
print *, rc
stop 'error' stop 'error'
endif endif
@ -402,6 +409,12 @@ subroutine pull_pt2(zmq_socket_pull,pt2,norm_pert,H_pert_diag,N_st,n,task_id)
stop 'error' stop 'error'
endif endif
rc = f77_zmq_recv( zmq_socket_pull, i_generator, 4, 0)
if (rc /= 4) then
print *, irp_here, 'f77_zmq_recv( zmq_socket_pull, i_generator, 4, 0)'
stop 'error'
endif
rc = f77_zmq_recv( zmq_socket_pull, task_id, 4, 0) rc = f77_zmq_recv( zmq_socket_pull, task_id, 4, 0)
if (rc /= 4) then if (rc /= 4) then
print *, irp_here, 'f77_zmq_recv( zmq_socket_pull, task_id, 4, 0)' print *, irp_here, 'f77_zmq_recv( zmq_socket_pull, task_id, 4, 0)'

26
src/Determinants/H_apply.template.f
View File

@ -174,14 +174,10 @@ subroutine $subroutine_diexcOrg(key_in,key_mask,hole_1,particl_1,hole_2, particl
double precision :: diag_H_mat_elem double precision :: diag_H_mat_elem
integer :: iproc integer :: iproc
integer :: jtest_vvvv integer :: jtest_vvvv
integer(omp_lock_kind), save :: lck, ifirst=0
if (ifirst == 0) then
!$ call omp_init_lock(lck)
ifirst=1
endif
logical :: check_double_excitation logical :: check_double_excitation
logical :: is_a_1h1p logical :: is_a_1h1p
logical :: is_a_1h2p
logical :: is_a_1h logical :: is_a_1h
logical :: is_a_1p logical :: is_a_1p
logical :: is_a_2p logical :: is_a_2p
@ -311,8 +307,10 @@ subroutine $subroutine_diexcOrg(key_in,key_mask,hole_1,particl_1,hole_2, particl
k = ishft(j_b-1,-bit_kind_shift)+1 k = ishft(j_b-1,-bit_kind_shift)+1
l = j_b-ishft(k-1,bit_kind_shift)-1 l = j_b-ishft(k-1,bit_kind_shift)-1
key(k,other_spin) = ibset(key(k,other_spin),l) key(k,other_spin) = ibset(key(k,other_spin),l)
$filter2h2p $filter2h2p_double
$filter_only_1h1p_double $filter_only_1h1p_double
$filter_only_1h2p_double
$filter_only_2h2p_double
$only_2p_double $only_2p_double
key_idx += 1 key_idx += 1
do k=1,N_int do k=1,N_int
@ -360,8 +358,10 @@ subroutine $subroutine_diexcOrg(key_in,key_mask,hole_1,particl_1,hole_2, particl
k = ishft(j_b-1,-bit_kind_shift)+1 k = ishft(j_b-1,-bit_kind_shift)+1
l = j_b-ishft(k-1,bit_kind_shift)-1 l = j_b-ishft(k-1,bit_kind_shift)-1
key(k,ispin) = ibset(key(k,ispin),l) key(k,ispin) = ibset(key(k,ispin),l)
$filter2h2p $filter2h2p_double
$filter_only_1h1p_double $filter_only_1h1p_double
$filter_only_1h2p_double
$filter_only_2h2p_double
$only_2p_double $only_2p_double
key_idx += 1 key_idx += 1
do k=1,N_int do k=1,N_int
@ -424,13 +424,13 @@ subroutine $subroutine_monoexc(key_in, hole_1,particl_1,fock_diag_tmp,i_generato
integer, allocatable :: ia_ja_pairs(:,:,:) integer, allocatable :: ia_ja_pairs(:,:,:)
logical, allocatable :: array_pairs(:,:) logical, allocatable :: array_pairs(:,:)
double precision :: diag_H_mat_elem double precision :: diag_H_mat_elem
integer(omp_lock_kind), save :: lck, ifirst=0
integer :: iproc integer :: iproc
integer(bit_kind) :: key_mask(N_int, 2) integer(bit_kind) :: key_mask(N_int, 2)
logical :: check_double_excitation logical :: check_double_excitation
logical :: is_a_1h1p logical :: is_a_1h1p
logical :: is_a_1h2p
logical :: is_a_1h logical :: is_a_1h
logical :: is_a_1p logical :: is_a_1p
logical :: is_a_2p logical :: is_a_2p
@ -446,11 +446,6 @@ subroutine $subroutine_monoexc(key_in, hole_1,particl_1,fock_diag_tmp,i_generato
$check_double_excitation $check_double_excitation
if (ifirst == 0) then
ifirst=1
!$ call omp_init_lock(lck)
endif
$initialization $initialization
$omp_parallel $omp_parallel
@ -512,8 +507,10 @@ subroutine $subroutine_monoexc(key_in, hole_1,particl_1,fock_diag_tmp,i_generato
$filter1h $filter1h
$filter1p $filter1p
$filter2p $filter2p
$filter2h2p $filter2h2p_single
$filter_only_1h1p_single $filter_only_1h1p_single
$filter_only_1h2p_single
$filter_only_2h2p_single
key_idx += 1 key_idx += 1
do k=1,N_int do k=1,N_int
keys_out(k,1,key_idx) = hole(k,1) keys_out(k,1,key_idx) = hole(k,1)
@ -539,4 +536,3 @@ subroutine $subroutine_monoexc(key_in, hole_1,particl_1,fock_diag_tmp,i_generato
end end

8
src/Determinants/H_apply_nozmq.template.f
View File

@ -11,7 +11,6 @@ subroutine $subroutine($params_main)
integer :: i_generator, nmax integer :: i_generator, nmax
double precision :: wall_0, wall_1 double precision :: wall_0, wall_1
integer(omp_lock_kind) :: lck
integer(bit_kind), allocatable :: mask(:,:,:) integer(bit_kind), allocatable :: mask(:,:,:)
integer :: ispin, k integer :: ispin, k
integer :: iproc integer :: iproc
@ -23,8 +22,6 @@ subroutine $subroutine($params_main)
nmax = mod( N_det_generators,nproc ) nmax = mod( N_det_generators,nproc )
!$ call omp_init_lock(lck)
call wall_time(wall_0) call wall_time(wall_0)
iproc = 0 iproc = 0
@ -129,19 +126,18 @@ subroutine $subroutine($params_main)
mask(1,1,s_hole ), mask(1,1,s_part ), & mask(1,1,s_hole ), mask(1,1,s_part ), &
fock_diag_tmp, i_generator, iproc $params_post) fock_diag_tmp, i_generator, iproc $params_post)
endif endif
!$ call omp_set_lock(lck) !$OMP CRITICAL
call wall_time(wall_1) call wall_time(wall_1)
$printout_always $printout_always
if (wall_1 - wall_0 > 2.d0) then if (wall_1 - wall_0 > 2.d0) then
$printout_now $printout_now
wall_0 = wall_1 wall_0 = wall_1
endif endif
!$ call omp_unset_lock(lck) !$OMP END CRITICAL
enddo enddo
!$OMP END DO !$OMP END DO
deallocate( mask, fock_diag_tmp ) deallocate( mask, fock_diag_tmp )
!$OMP END PARALLEL !$OMP END PARALLEL
!$ call omp_destroy_lock(lck)
$copy_buffer $copy_buffer
$generate_psi_guess $generate_psi_guess

70
src/Determinants/H_apply_zmq.template.f
View File

@ -10,9 +10,9 @@ subroutine $subroutine($params_main)
$decls_main $decls_main
integer :: i
integer :: i_generator integer :: i_generator
double precision :: wall_0, wall_1 double precision :: wall_0, wall_1
integer(omp_lock_kind) :: lck
integer(bit_kind), allocatable :: mask(:,:,:) integer(bit_kind), allocatable :: mask(:,:,:)
integer :: ispin, k integer :: ispin, k
integer :: rc integer :: rc
@ -26,6 +26,9 @@ subroutine $subroutine($params_main)
integer(ZMQ_PTR) :: zmq_socket_pair integer(ZMQ_PTR) :: zmq_socket_pair
integer(ZMQ_PTR) :: zmq_to_qp_run_socket integer(ZMQ_PTR) :: zmq_to_qp_run_socket
double precision, allocatable :: pt2_generators(:,:), norm_pert_generators(:,:)
double precision, allocatable :: H_pert_diag_generators(:,:)
call new_parallel_job(zmq_to_qp_run_socket,'$subroutine') call new_parallel_job(zmq_to_qp_run_socket,'$subroutine')
zmq_socket_pair = new_zmq_pair_socket(.True.) zmq_socket_pair = new_zmq_pair_socket(.True.)
@ -37,24 +40,26 @@ subroutine $subroutine($params_main)
call add_task_to_taskserver(zmq_to_qp_run_socket,task) call add_task_to_taskserver(zmq_to_qp_run_socket,task)
enddo enddo
integer(ZMQ_PTR) :: collector_thread allocate ( pt2_generators(N_states,N_det_generators), &
external :: $subroutine_collector norm_pert_generators(N_states,N_det_generators), &
rc = pthread_create(collector_thread, $subroutine_collector) H_pert_diag_generators(N_states,N_det_generators) )
!$OMP PARALLEL DEFAULT(private) PROVIDE nproc N_states
!$OMP TASK PRIVATE(rc) !$OMP PARALLEL DEFAULT(NONE) &
rc = omp_get_thread_num() !$OMP PRIVATE(i) &
call $subroutine_slave_inproc(rc) !$OMP SHARED(zmq_socket_pair,N_states, pt2_generators, norm_pert_generators, H_pert_diag_generators, n, task_id, i_generator) &
!$OMP END TASK !$OMP num_threads(nproc+1)
!$OMP TASKWAIT i = omp_get_thread_num()
if (i == 0) then
call $subroutine_collector()
integer :: n, task_id
call pull_pt2(zmq_socket_pair, pt2_generators, norm_pert_generators, H_pert_diag_generators, i_generator, size(pt2_generators), n, task_id)
else
call $subroutine_slave_inproc(i)
endif
!$OMP END PARALLEL !$OMP END PARALLEL
integer :: n, task_id
call pull_pt2(zmq_socket_pair, pt2, norm_pert, H_pert_diag, N_st, n, task_id)
rc = pthread_join(collector_thread)
call end_zmq_pair_socket(zmq_socket_pair) call end_zmq_pair_socket(zmq_socket_pair)
call end_parallel_job(zmq_to_qp_run_socket,'$subroutine') call end_parallel_job(zmq_to_qp_run_socket,'$subroutine')
@ -62,6 +67,7 @@ subroutine $subroutine($params_main)
$copy_buffer $copy_buffer
$generate_psi_guess $generate_psi_guess
deallocate ( pt2_generators, norm_pert_generators, H_pert_diag_generators)
end end
subroutine $subroutine_slave_tcp(iproc) subroutine $subroutine_slave_tcp(iproc)
@ -168,8 +174,8 @@ subroutine $subroutine_slave(thread, iproc)
fock_diag_tmp, i_generator, iproc $params_post) fock_diag_tmp, i_generator, iproc $params_post)
endif endif
call task_done_to_taskserver(zmq_to_qp_run_socket,worker_id,task_id,1) call task_done_to_taskserver(zmq_to_qp_run_socket, worker_id, task_id)
call push_pt2(zmq_socket_push,pt2,norm_pert,H_pert_diag,N_st,task_id) call push_pt2(zmq_socket_push,pt2,norm_pert,H_pert_diag,i_generator,N_st,task_id)
enddo enddo
@ -186,7 +192,7 @@ subroutine $subroutine_collector
use f77_zmq use f77_zmq
implicit none implicit none
BEGIN_DOC BEGIN_DOC
! Collects results from the selection ! Collects results from the selection in an array of generators
END_DOC END_DOC
integer :: k, rc integer :: k, rc
@ -194,7 +200,7 @@ subroutine $subroutine_collector
integer(ZMQ_PTR), external :: new_zmq_pull_socket integer(ZMQ_PTR), external :: new_zmq_pull_socket
integer(ZMQ_PTR) :: zmq_socket_pull integer(ZMQ_PTR) :: zmq_socket_pull
integer*8 :: control, accu integer*8 :: control, accu
integer :: n, more, task_id integer :: n, more, task_id, i_generator
integer(ZMQ_PTR),external :: new_zmq_to_qp_run_socket integer(ZMQ_PTR),external :: new_zmq_to_qp_run_socket
integer(ZMQ_PTR) :: zmq_to_qp_run_socket integer(ZMQ_PTR) :: zmq_to_qp_run_socket
@ -202,22 +208,25 @@ subroutine $subroutine_collector
zmq_to_qp_run_socket = new_zmq_to_qp_run_socket() zmq_to_qp_run_socket = new_zmq_to_qp_run_socket()
zmq_socket_pull = new_zmq_pull_socket() zmq_socket_pull = new_zmq_pull_socket()
double precision, allocatable :: pt2(:,:), norm_pert(:,:), H_pert_diag(:,:) double precision, allocatable :: pt2(:), norm_pert(:), H_pert_diag(:)
allocate ( pt2(N_states,2), norm_pert(N_states,2), H_pert_diag(N_states,2)) double precision, allocatable :: pt2_result(:,:), norm_pert_result(:,:), H_pert_diag_result(:,:)
allocate (pt2(N_states), norm_pert(N_states), H_pert_diag(N_states))
allocate (pt2_result(N_states,N_det_generators), norm_pert_result(N_states,N_det_generators), &
H_pert_diag_result(N_states,N_det_generators))
pt2 = 0.d0 pt2_result = 0.d0
norm_pert = 0.d0 norm_pert_result = 0.d0
H_pert_diag = 0.d0 H_pert_diag_result = 0.d0
accu = 0_8 accu = 0_8
more = 1 more = 1
do while (more == 1) do while (more == 1)
call pull_pt2(zmq_socket_pull, pt2, norm_pert, H_pert_diag, N_states, n, task_id) call pull_pt2(zmq_socket_pull, pt2, norm_pert, H_pert_diag, i_generator, N_states, n, task_id)
if (n > 0) then if (n > 0) then
do k=1,N_states do k=1,N_states
pt2(k,2) = pt2(k,1) + pt2(k,2) pt2_result(k,i_generator) = pt2(k)
norm_pert(k,2) = norm_pert(k,1) + norm_pert(k,2) norm_pert_result(k,i_generator) = norm_pert(k)
H_pert_diag(k,2) = H_pert_diag(k,1) + H_pert_diag(k,2) H_pert_diag_result(k,i_generator) = H_pert_diag(k)
enddo enddo
accu = accu + 1_8 accu = accu + 1_8
call zmq_delete_task(zmq_to_qp_run_socket,zmq_socket_pull,task_id,more) call zmq_delete_task(zmq_to_qp_run_socket,zmq_socket_pull,task_id,more)
@ -234,9 +243,10 @@ subroutine $subroutine_collector
socket_result = new_zmq_pair_socket(.False.) socket_result = new_zmq_pair_socket(.False.)
call push_pt2(socket_result, pt2(1,2), norm_pert(1,2), H_pert_diag(1,2), N_states,0) call push_pt2(socket_result, pt2_result, norm_pert_result, H_pert_diag_result, i_generator, &
N_states*N_det_generators,0)
deallocate ( pt2, norm_pert, H_pert_diag) deallocate (pt2, norm_pert, H_pert_diag, pt2_result, norm_pert_result, H_pert_diag_result)
call end_zmq_pair_socket(socket_result) call end_zmq_pair_socket(socket_result)

6
src/Determinants/SC2.irp.f
View File

@ -1,4 +1,4 @@
subroutine CISD_SC2(dets_in,u_in,energies,dim_in,sze,N_st,Nint,convergence) subroutine CISD_SC2(dets_in,u_in,energies,diag_H_elements,dim_in,sze,N_st,Nint,convergence)
use bitmasks use bitmasks
implicit none implicit none
BEGIN_DOC BEGIN_DOC
@ -21,6 +21,7 @@ subroutine CISD_SC2(dets_in,u_in,energies,dim_in,sze,N_st,Nint,convergence)
integer(bit_kind), intent(in) :: dets_in(Nint,2,sze) integer(bit_kind), intent(in) :: dets_in(Nint,2,sze)
double precision, intent(inout) :: u_in(dim_in,N_st) double precision, intent(inout) :: u_in(dim_in,N_st)
double precision, intent(out) :: energies(N_st) double precision, intent(out) :: energies(N_st)
double precision, intent(out) :: diag_H_elements(dim_in)
double precision, intent(in) :: convergence double precision, intent(in) :: convergence
ASSERT (N_st > 0) ASSERT (N_st > 0)
ASSERT (sze > 0) ASSERT (sze > 0)
@ -197,6 +198,9 @@ subroutine CISD_SC2(dets_in,u_in,energies,dim_in,sze,N_st,Nint,convergence)
converged = dabs(e_corr_double - e_corr_double_before) < convergence converged = dabs(e_corr_double - e_corr_double_before) < convergence
converged = converged converged = converged
if (converged) then if (converged) then
do i = 1, dim_in
diag_H_elements(i) = H_jj_dressed(i) - H_jj_ref(i)
enddo
exit exit
endif endif
e_corr_double_before = e_corr_double e_corr_double_before = e_corr_double

101
src/Determinants/davidson.irp.f
View File

@ -386,39 +386,52 @@ subroutine davidson_diag_hjj(dets_in,u_in,H_jj,energies,dim_in,sze,N_st,Nint,iun
! ============== ! ==============
k_pairs=0 if (N_st > 1) then
do l=1,N_st
do k=1,l
k_pairs+=1
kl_pairs(1,k_pairs) = k
kl_pairs(2,k_pairs) = l
enddo
enddo
!$OMP PARALLEL DEFAULT(NONE) &
!$OMP SHARED(U,sze,N_st,overlap,kl_pairs,k_pairs, &
!$OMP Nint,dets_in,u_in) &
!$OMP PRIVATE(k,l,kl,i)
! Orthonormalize initial guess
! ============================
!$OMP DO
do kl=1,k_pairs
k = kl_pairs(1,kl)
l = kl_pairs(2,kl)
if (k/=l) then
overlap(k,l) = u_dot_v(U_in(1,k),U_in(1,l),sze)
overlap(l,k) = overlap(k,l)
else
overlap(k,k) = u_dot_u(U_in(1,k),sze)
endif
enddo
!$OMP END DO
!$OMP END PARALLEL
call ortho_lowdin(overlap,size(overlap,1),N_st,U_in,size(U_in,1),sze) k_pairs=0
do l=1,N_st
do k=1,l
k_pairs+=1
kl_pairs(1,k_pairs) = k
kl_pairs(2,k_pairs) = l
enddo
enddo
!$OMP PARALLEL DEFAULT(NONE) &
!$OMP SHARED(U,sze,N_st,overlap,kl_pairs,k_pairs, &
!$OMP Nint,dets_in,u_in) &
!$OMP PRIVATE(k,l,kl)
! Orthonormalize initial guess
! ============================
!$OMP DO
do kl=1,k_pairs
k = kl_pairs(1,kl)
l = kl_pairs(2,kl)
if (k/=l) then
overlap(k,l) = u_dot_v(U_in(1,k),U_in(1,l),sze)
overlap(l,k) = overlap(k,l)
else
overlap(k,k) = u_dot_u(U_in(1,k),sze)
endif
enddo
!$OMP END DO
!$OMP END PARALLEL
call ortho_lowdin(overlap,size(overlap,1),N_st,U_in,size(U_in,1),sze)
else
overlap(1,1) = u_dot_u(U_in(1,1),sze)
double precision :: f
f = 1.d0 / dsqrt(overlap(1,1))
do i=1,sze
U_in(i,1) = U_in(i,1) * f
enddo
endif
! Davidson iterations ! Davidson iterations
! =================== ! ===================
@ -479,34 +492,42 @@ subroutine davidson_diag_hjj(dets_in,u_in,H_jj,energies,dim_in,sze,N_st,Nint,iun
! -------------------------------------------------- ! --------------------------------------------------
!$OMP PARALLEL DEFAULT(NONE) & !$OMP PARALLEL DEFAULT(NONE) &
!$OMP PRIVATE(k,i,l,iter2) SHARED(U,W,R,y,iter,lambda,N_st,sze) !$OMP PRIVATE(k,i,l,iter2) &
!$OMP SHARED(U,W,R,y,iter,lambda,N_st,sze,to_print, &
!$OMP residual_norm,nuclear_repulsion)
do k=1,N_st do k=1,N_st
!$OMP DO !$OMP DO
do i=1,sze do i=1,sze
U(i,k,iter+1) = 0.d0 U(i,k,iter+1) = 0.d0
W(i,k,iter+1) = 0.d0 W(i,k,iter+1) = 0.d0
enddo
!$OMP END DO
do iter2=1,iter
do l=1,N_st do l=1,N_st
do iter2=1,iter !$OMP DO
do i=1,sze
U(i,k,iter+1) = U(i,k,iter+1) + U(i,l,iter2)*y(l,iter2,k,1) U(i,k,iter+1) = U(i,k,iter+1) + U(i,l,iter2)*y(l,iter2,k,1)
W(i,k,iter+1) = W(i,k,iter+1) + W(i,l,iter2)*y(l,iter2,k,1) W(i,k,iter+1) = W(i,k,iter+1) + W(i,l,iter2)*y(l,iter2,k,1)
enddo enddo
!$OMP END DO NOWAIT
enddo enddo
enddo enddo
!$OMP END DO
enddo
!$OMP END PARALLEL
! Compute residual vector ! Compute residual vector
! ----------------------- ! -----------------------
do k=1,N_st !$OMP DO
do i=1,sze do i=1,sze
R(i,k) = lambda(k) * U(i,k,iter+1) - W(i,k,iter+1) R(i,k) = lambda(k) * U(i,k,iter+1) - W(i,k,iter+1)
enddo enddo
!$OMP END DO
!$OMP SINGLE
residual_norm(k) = u_dot_u(R(1,k),sze) residual_norm(k) = u_dot_u(R(1,k),sze)
to_print(1,k) = lambda(k) + nuclear_repulsion to_print(1,k) = lambda(k) + nuclear_repulsion
to_print(2,k) = residual_norm(k) to_print(2,k) = residual_norm(k)
!$OMP END SINGLE
enddo enddo
!$OMP END PARALLEL
write(iunit,'(X,I3,X,100(X,F16.10,X,E16.6))') iter, to_print(:,1:N_st) write(iunit,'(X,I3,X,100(X,F16.10,X,E16.6))') iter, to_print(:,1:N_st)
call davidson_converged(lambda,residual_norm,wall,iter,cpu,N_st,converged) call davidson_converged(lambda,residual_norm,wall,iter,cpu,N_st,converged)

2
src/Determinants/determinants.irp.f
View File

@ -58,7 +58,7 @@ BEGIN_PROVIDER [ integer, psi_det_size ]
else else
psi_det_size = 1 psi_det_size = 1
endif endif
psi_det_size = max(psi_det_size,10000) psi_det_size = max(psi_det_size,100000)
call write_int(output_determinants,psi_det_size,'Dimension of the psi arrays') call write_int(output_determinants,psi_det_size,'Dimension of the psi arrays')
END_PROVIDER END_PROVIDER

418
src/Determinants/diagonalize_CI.irp.f
View File

@ -36,225 +36,223 @@ END_PROVIDER
BEGIN_PROVIDER [ double precision, CI_electronic_energy, (N_states_diag) ] BEGIN_PROVIDER [ double precision, CI_electronic_energy, (N_states_diag) ]
&BEGIN_PROVIDER [ double precision, CI_eigenvectors, (N_det,N_states_diag) ] &BEGIN_PROVIDER [ double precision, CI_eigenvectors, (N_det,N_states_diag) ]
&BEGIN_PROVIDER [ double precision, CI_eigenvectors_s2, (N_states_diag) ] &BEGIN_PROVIDER [ double precision, CI_eigenvectors_s2, (N_states_diag) ]
BEGIN_DOC BEGIN_DOC
! Eigenvectors/values of the CI matrix ! Eigenvectors/values of the CI matrix
END_DOC END_DOC
implicit none implicit none
double precision :: ovrlp,u_dot_v double precision :: ovrlp,u_dot_v
integer :: i_good_state integer :: i_good_state
integer, allocatable :: index_good_state_array(:) integer, allocatable :: index_good_state_array(:)
logical, allocatable :: good_state_array(:) logical, allocatable :: good_state_array(:)
double precision, allocatable :: s2_values_tmp(:) double precision, allocatable :: s2_values_tmp(:)
integer :: i_other_state integer :: i_other_state
double precision, allocatable :: eigenvectors(:,:), eigenvalues(:) double precision, allocatable :: eigenvectors(:,:), eigenvalues(:)
integer :: i_state integer :: i_state
double precision :: s2,e_0 double precision :: s2,e_0
integer :: i,j,k integer :: i,j,k
double precision, allocatable :: s2_eigvalues(:) double precision, allocatable :: s2_eigvalues(:)
double precision, allocatable :: e_array(:) double precision, allocatable :: e_array(:)
integer, allocatable :: iorder(:) integer, allocatable :: iorder(:)
! Guess values for the "N_states_diag" states of the CI_eigenvectors ! Guess values for the "N_states_diag" states of the CI_eigenvectors
do j=1,min(N_states_diag,N_det) do j=1,min(N_states_diag,N_det)
do i=1,N_det do i=1,N_det
CI_eigenvectors(i,j) = psi_coef(i,j) CI_eigenvectors(i,j) = psi_coef(i,j)
enddo enddo
enddo enddo
do j=N_det+1,N_states_diag do j=N_det+1,N_states_diag
do i=1,N_det do i=1,N_det
CI_eigenvectors(i,j) = 0.d0 CI_eigenvectors(i,j) = 0.d0
enddo enddo
enddo enddo
if (diag_algorithm == "Davidson") then if (diag_algorithm == "Davidson") then
call davidson_diag(psi_det,CI_eigenvectors,CI_electronic_energy, & call davidson_diag(psi_det,CI_eigenvectors,CI_electronic_energy,&
size(CI_eigenvectors,1),N_det,N_states_diag,N_int,output_determinants) size(CI_eigenvectors,1),N_det,N_states_diag,N_int,output_determinants)
do j=1,N_states_diag do j=1,N_states_diag
call get_s2_u0(psi_det,CI_eigenvectors(1,j),N_det,size(CI_eigenvectors,1),CI_eigenvectors_s2(j)) call get_s2_u0(psi_det,CI_eigenvectors(1,j),N_det,size(CI_eigenvectors,1),CI_eigenvectors_s2(j))
enddo enddo
else if (diag_algorithm == "Lapack") then else if (diag_algorithm == "Lapack") then
allocate (eigenvectors(size(H_matrix_all_dets,1),N_det)) allocate (eigenvectors(size(H_matrix_all_dets,1),N_det))
allocate (eigenvalues(N_det)) allocate (eigenvalues(N_det))
call lapack_diag(eigenvalues,eigenvectors, & call lapack_diag(eigenvalues,eigenvectors, &
H_matrix_all_dets,size(H_matrix_all_dets,1),N_det) H_matrix_all_dets,size(H_matrix_all_dets,1),N_det)
CI_electronic_energy(:) = 0.d0 CI_electronic_energy(:) = 0.d0
if (s2_eig) then if (s2_eig) then
i_state = 0 i_state = 0
allocate (s2_eigvalues(N_det)) allocate (s2_eigvalues(N_det))
allocate(index_good_state_array(N_det),good_state_array(N_det)) allocate(index_good_state_array(N_det),good_state_array(N_det))
good_state_array = .False. good_state_array = .False.
do j=1,N_det do j=1,N_det
call get_s2_u0(psi_det,eigenvectors(1,j),N_det,size(eigenvectors,1),s2) call get_s2_u0(psi_det,eigenvectors(1,j),N_det,size(eigenvectors,1),s2)
s2_eigvalues(j) = s2 s2_eigvalues(j) = s2
! Select at least n_states states with S^2 values closed to "expected_s2" ! Select at least n_states states with S^2 values closed to "expected_s2"
if(dabs(s2-expected_s2).le.0.3d0)then if(dabs(s2-expected_s2).le.0.3d0)then
i_state +=1 i_state +=1
index_good_state_array(i_state) = j index_good_state_array(i_state) = j
good_state_array(j) = .True. good_state_array(j) = .True.
endif endif
if(i_state.eq.N_states) then if(i_state.eq.N_states) then
exit exit
endif endif
enddo
if(i_state .ne.0)then
! Fill the first "i_state" states that have a correct S^2 value
do j = 1, i_state
do i=1,N_det
CI_eigenvectors(i,j) = eigenvectors(i,index_good_state_array(j))
enddo
CI_electronic_energy(j) = eigenvalues(index_good_state_array(j))
CI_eigenvectors_s2(j) = s2_eigvalues(index_good_state_array(j))
enddo enddo
i_other_state = 0 if(i_state .ne.0)then
do j = 1, N_det ! Fill the first "i_state" states that have a correct S^2 value
if(good_state_array(j))cycle do j = 1, i_state
i_other_state +=1 do i=1,N_det
if(i_state+i_other_state.gt.n_states_diag)then CI_eigenvectors(i,j) = eigenvectors(i,index_good_state_array(j))
exit enddo
endif CI_electronic_energy(j) = eigenvalues(index_good_state_array(j))
call get_s2_u0(psi_det,eigenvectors(1,j),N_det,size(eigenvectors,1),s2) CI_eigenvectors_s2(j) = s2_eigvalues(index_good_state_array(j))
do i=1,N_det enddo
CI_eigenvectors(i,i_state+i_other_state) = eigenvectors(i,j) i_other_state = 0
enddo do j = 1, N_det
CI_electronic_energy(i_state+i_other_state) = eigenvalues(j) if(good_state_array(j))cycle
CI_eigenvectors_s2(i_state+i_other_state) = s2 i_other_state +=1
enddo if(i_state+i_other_state.gt.n_states_diag)then
exit
endif
call get_s2_u0(psi_det,eigenvectors(1,j),N_det,size(eigenvectors,1),s2)
do i=1,N_det
CI_eigenvectors(i,i_state+i_other_state) = eigenvectors(i,j)
enddo
CI_electronic_energy(i_state+i_other_state) = eigenvalues(j)
CI_eigenvectors_s2(i_state+i_other_state) = s2
enddo
else
print*,''
print*,'!!!!!!!! WARNING !!!!!!!!!'
print*,' Within the ',N_det,'determinants selected'
print*,' and the ',N_states_diag,'states requested'
print*,' We did not find any state with S^2 values close to ',expected_s2
print*,' We will then set the first N_states eigenvectors of the H matrix'
print*,' as the CI_eigenvectors'
print*,' You should consider more states and maybe ask for diagonalize_s2 to be .True. or just enlarge the CI space'
print*,''
do j=1,min(N_states_diag,N_det)
do i=1,N_det
CI_eigenvectors(i,j) = eigenvectors(i,j)
enddo
CI_electronic_energy(j) = eigenvalues(j)
CI_eigenvectors_s2(j) = s2_eigvalues(j)
enddo
endif
deallocate(index_good_state_array,good_state_array) deallocate(index_good_state_array,good_state_array)
deallocate(s2_eigvalues)
else else
print*,'' ! Select the "N_states_diag" states of lowest energy
print*,'!!!!!!!! WARNING !!!!!!!!!' do j=1,min(N_det,N_states_diag)
print*,' Within the ',N_det,'determinants selected' call get_s2_u0(psi_det,eigenvectors(1,j),N_det,N_det,s2)
print*,' and the ',N_states_diag,'states requested'
print*,' We did not find any state with S^2 values close to ',expected_s2
print*,' We will then set the first N_states eigenvectors of the H matrix'
print*,' as the CI_eigenvectors'
print*,' You should consider more states and maybe ask for diagonalize_s2 to be .True. or just enlarge the CI space'
print*,''
do j=1,min(N_states_diag,N_det)
do i=1,N_det do i=1,N_det
CI_eigenvectors(i,j) = eigenvectors(i,j) CI_eigenvectors(i,j) = eigenvectors(i,j)
enddo enddo
CI_electronic_energy(j) = eigenvalues(j) CI_electronic_energy(j) = eigenvalues(j)
CI_eigenvectors_s2(j) = s2_eigvalues(j) CI_eigenvectors_s2(j) = s2
enddo enddo
endif
deallocate(s2_eigvalues)
else
! Select the "N_states_diag" states of lowest energy
do j=1,min(N_det,N_states_diag)
call get_s2_u0(psi_det,eigenvectors(1,j),N_det,N_det,s2)
do i=1,N_det
CI_eigenvectors(i,j) = eigenvectors(i,j)
enddo
CI_electronic_energy(j) = eigenvalues(j)
CI_eigenvectors_s2(j) = s2
enddo
endif
deallocate(eigenvectors,eigenvalues)
endif
if(diagonalize_s2.and.n_states_diag > 1.and. n_det >= n_states_diag)then
! Diagonalizing S^2 within the "n_states_diag" states found
allocate(s2_eigvalues(N_states_diag))
call diagonalize_s2_betweenstates(psi_det,CI_eigenvectors,n_det,size(psi_det,3),size(CI_eigenvectors,1),min(n_states_diag,n_det),s2_eigvalues)
do j = 1, N_states_diag
do i = 1, N_det
psi_coef(i,j) = CI_eigenvectors(i,j)
enddo
enddo
if(s2_eig)then
! Browsing the "n_states_diag" states and getting the lowest in energy "n_states" ones that have the S^2 value
! closer to the "expected_s2" set as input
allocate(index_good_state_array(N_det),good_state_array(N_det))
good_state_array = .False.
i_state = 0
do j = 1, N_states_diag
if(dabs(s2_eigvalues(j)-expected_s2).le.0.3d0)then
good_state_array(j) = .True.
i_state +=1
index_good_state_array(i_state) = j
endif endif
enddo deallocate(eigenvectors,eigenvalues)
! Sorting the i_state good states by energy
allocate(e_array(i_state),iorder(i_state))
do j = 1, i_state
do i = 1, N_det
CI_eigenvectors(i,j) = psi_coef(i,index_good_state_array(j))
enddo
CI_eigenvectors_s2(j) = s2_eigvalues(index_good_state_array(j))
call u0_H_u_0(e_0,CI_eigenvectors(1,j),n_det,psi_det,N_int)
CI_electronic_energy(j) = e_0
e_array(j) = e_0
iorder(j) = j
enddo
call dsort(e_array,iorder,i_state)
do j = 1, i_state
CI_electronic_energy(j) = e_array(j)
CI_eigenvectors_s2(j) = s2_eigvalues(index_good_state_array(iorder(j)))
do i = 1, N_det
CI_eigenvectors(i,j) = psi_coef(i,index_good_state_array(iorder(j)))
enddo
! call u0_H_u_0(e_0,CI_eigenvectors(1,j),n_det,psi_det,N_int)
! print*,'e = ',CI_electronic_energy(j)
! print*,'<e> = ',e_0
! call get_s2_u0(psi_det,CI_eigenvectors(1,j),N_det,size(CI_eigenvectors,1),s2)
! print*,'s^2 = ',CI_eigenvectors_s2(j)
! print*,'<s^2>= ',s2
enddo
deallocate(e_array,iorder)
! Then setting the other states without any specific energy order
i_other_state = 0
do j = 1, N_states_diag
if(good_state_array(j))cycle
i_other_state +=1
do i = 1, N_det
CI_eigenvectors(i,i_state + i_other_state) = psi_coef(i,j)
enddo
CI_eigenvectors_s2(i_state + i_other_state) = s2_eigvalues(j)
call u0_H_u_0(e_0,CI_eigenvectors(1,i_state + i_other_state),n_det,psi_det,N_int)
CI_electronic_energy(i_state + i_other_state) = e_0
enddo
deallocate(index_good_state_array,good_state_array)
else
! Sorting the N_states_diag by energy, whatever the S^2 value is
allocate(e_array(n_states_diag),iorder(n_states_diag))
do j = 1, N_states_diag
call u0_H_u_0(e_0,CI_eigenvectors(1,j),n_det,psi_det,N_int)
e_array(j) = e_0
iorder(j) = j
enddo
call dsort(e_array,iorder,n_states_diag)
do j = 1, N_states_diag
CI_electronic_energy(j) = e_array(j)
do i = 1, N_det
CI_eigenvectors(i,j) = psi_coef(i,iorder(j))
enddo
CI_eigenvectors_s2(j) = s2_eigvalues(iorder(j))
enddo
deallocate(e_array,iorder)
endif endif
deallocate(s2_eigvalues)
endif if(diagonalize_s2.and.n_states_diag > 1.and. n_det >= n_states_diag)then
! Diagonalizing S^2 within the "n_states_diag" states found
allocate(s2_eigvalues(N_states_diag))
call diagonalize_s2_betweenstates(psi_det,CI_eigenvectors,n_det,size(psi_det,3),size(CI_eigenvectors,1),min(n_states_diag,n_det),s2_eigvalues)
do j = 1, N_states_diag
do i = 1, N_det
psi_coef(i,j) = CI_eigenvectors(i,j)
enddo
enddo
if(s2_eig)then
! Browsing the "n_states_diag" states and getting the lowest in energy "n_states" ones that have the S^2 value
! closer to the "expected_s2" set as input
allocate(index_good_state_array(N_det),good_state_array(N_det))
good_state_array = .False.
i_state = 0
do j = 1, N_states_diag
if(dabs(s2_eigvalues(j)-expected_s2).le.0.3d0)then
good_state_array(j) = .True.
i_state +=1
index_good_state_array(i_state) = j
endif
enddo
! Sorting the i_state good states by energy
allocate(e_array(i_state),iorder(i_state))
do j = 1, i_state
do i = 1, N_det
CI_eigenvectors(i,j) = psi_coef(i,index_good_state_array(j))
enddo
CI_eigenvectors_s2(j) = s2_eigvalues(index_good_state_array(j))
call u0_H_u_0(e_0,CI_eigenvectors(1,j),n_det,psi_det,N_int)
CI_electronic_energy(j) = e_0
e_array(j) = e_0
iorder(j) = j
enddo
call dsort(e_array,iorder,i_state)
do j = 1, i_state
CI_electronic_energy(j) = e_array(j)
CI_eigenvectors_s2(j) = s2_eigvalues(index_good_state_array(iorder(j)))
do i = 1, N_det
CI_eigenvectors(i,j) = psi_coef(i,index_good_state_array(iorder(j)))
enddo
! call u0_H_u_0(e_0,CI_eigenvectors(1,j),n_det,psi_det,N_int)
! print*,'e = ',CI_electronic_energy(j)
! print*,'<e> = ',e_0
! call get_s2_u0(psi_det,CI_eigenvectors(1,j),N_det,size(CI_eigenvectors,1),s2)
! print*,'s^2 = ',CI_eigenvectors_s2(j)
! print*,'<s^2>= ',s2
enddo
deallocate(e_array,iorder)
! Then setting the other states without any specific energy order
i_other_state = 0
do j = 1, N_states_diag
if(good_state_array(j))cycle
i_other_state +=1
do i = 1, N_det
CI_eigenvectors(i,i_state + i_other_state) = psi_coef(i,j)
enddo
CI_eigenvectors_s2(i_state + i_other_state) = s2_eigvalues(j)
call u0_H_u_0(e_0,CI_eigenvectors(1,i_state + i_other_state),n_det,psi_det,N_int)
CI_electronic_energy(i_state + i_other_state) = e_0
enddo
deallocate(index_good_state_array,good_state_array)
else
! Sorting the N_states_diag by energy, whatever the S^2 value is
allocate(e_array(n_states_diag),iorder(n_states_diag))
do j = 1, N_states_diag
call u0_H_u_0(e_0,CI_eigenvectors(1,j),n_det,psi_det,N_int)
e_array(j) = e_0
iorder(j) = j
enddo
call dsort(e_array,iorder,n_states_diag)
do j = 1, N_states_diag
CI_electronic_energy(j) = e_array(j)
do i = 1, N_det
CI_eigenvectors(i,j) = psi_coef(i,iorder(j))
enddo
CI_eigenvectors_s2(j) = s2_eigvalues(iorder(j))
enddo
deallocate(e_array,iorder)
endif
deallocate(s2_eigvalues)
endif
END_PROVIDER END_PROVIDER
subroutine diagonalize_CI subroutine diagonalize_CI
implicit none implicit none
BEGIN_DOC BEGIN_DOC

8
src/Determinants/diagonalize_CI_SC2.irp.f
View File

@ -23,8 +23,10 @@ END_PROVIDER
threshold_convergence_SC2 = 1.d-10 threshold_convergence_SC2 = 1.d-10
END_PROVIDER END_PROVIDER
BEGIN_PROVIDER [ double precision, CI_SC2_electronic_energy, (N_states_diag) ] BEGIN_PROVIDER [ double precision, CI_SC2_electronic_energy, (N_states_diag) ]
&BEGIN_PROVIDER [ double precision, CI_SC2_eigenvectors, (N_det,N_states_diag) ] &BEGIN_PROVIDER [ double precision, CI_SC2_eigenvectors, (N_det,N_states_diag) ]
&BEGIN_PROVIDER [ double precision, Diag_H_elements_SC2, (N_det) ]
implicit none implicit none
BEGIN_DOC BEGIN_DOC
! Eigenvectors/values of the CI matrix ! Eigenvectors/values of the CI matrix
@ -39,7 +41,8 @@ END_PROVIDER
enddo enddo
call CISD_SC2(psi_det,CI_SC2_eigenvectors,CI_SC2_electronic_energy, & call CISD_SC2(psi_det,CI_SC2_eigenvectors,CI_SC2_electronic_energy, &
size(CI_SC2_eigenvectors,1),N_det,N_states_diag,N_int,threshold_convergence_SC2) ! size(CI_SC2_eigenvectors,1),N_det,N_states_diag,N_int,threshold_convergence_SC2)
diag_H_elements_SC2,size(CI_SC2_eigenvectors,1),N_det,N_states_diag,N_int,threshold_convergence_SC2)
END_PROVIDER END_PROVIDER
subroutine diagonalize_CI_SC2 subroutine diagonalize_CI_SC2
@ -54,5 +57,6 @@ subroutine diagonalize_CI_SC2
psi_coef(i,j) = CI_SC2_eigenvectors(i,j) psi_coef(i,j) = CI_SC2_eigenvectors(i,j)
enddo enddo
enddo enddo
SOFT_TOUCH psi_coef CI_SC2_electronic_energy CI_SC2_energy CI_SC2_eigenvectors SOFT_TOUCH psi_coef CI_SC2_electronic_energy CI_SC2_energy CI_SC2_eigenvectors diag_h_elements_sc2
! SOFT_TOUCH psi_coef CI_SC2_electronic_energy CI_SC2_energy CI_SC2_eigenvectors
end end

1
src/Determinants/filter_connected.irp.f
View File

@ -207,6 +207,7 @@ subroutine create_microlist(minilist, N_minilist, key_mask, microlist, idx_micro
do j=1,n_element(1) do j=1,n_element(1)
nt = list(j,1) nt = list(j,1)
idx_microlist(cur_microlist(nt)) = i idx_microlist(cur_microlist(nt)) = i
! TODO : Page faults
do k=1,Nint do k=1,Nint
microlist(k,1,cur_microlist(nt)) = minilist(k,1,i) microlist(k,1,cur_microlist(nt)) = minilist(k,1,i)
microlist(k,2,cur_microlist(nt)) = minilist(k,2,i) microlist(k,2,cur_microlist(nt)) = minilist(k,2,i)

44
src/Determinants/s2.irp.f
View File

@ -301,13 +301,21 @@ subroutine diagonalize_s2_betweenstates(keys_tmp,psi_coefs_inout,n,nmax_keys,nma
print*,'' print*,''
print*,'nstates = ',nstates print*,'nstates = ',nstates
allocate(s2(nstates,nstates),overlap(nstates,nstates)) allocate(s2(nstates,nstates),overlap(nstates,nstates))
do i = 1, nstates !$OMP PARALLEL DO COLLAPSE(2) DEFAULT(NONE) SCHEDULE(dynamic) &
overlap(i,i) = u_dot_u(psi_coefs_inout(1,i),n) !$OMP PRIVATE(i,j) SHARED(overlap,psi_coefs_inout,nstates,n)
do j = i+1, nstates do i = 1, nstates
overlap(i,j) = u_dot_v(psi_coefs_inout(1,j),psi_coefs_inout(1,i),n) do j = 1, nstates
overlap(j,i) = overlap(i,j) if (i < j) then
enddo cycle
enddo else if (i == j) then
overlap(i,i) = u_dot_u(psi_coefs_inout(1,i),n)
else
overlap(i,j) = u_dot_v(psi_coefs_inout(1,j),psi_coefs_inout(1,i),n)
overlap(j,i) = overlap(i,j)
endif
enddo
enddo
!$OMP END PARALLEL DO
print*,'Overlap matrix in the basis of the states considered' print*,'Overlap matrix in the basis of the states considered'
do i = 1, nstates do i = 1, nstates
write(*,'(10(F16.10,X))')overlap(i,:) write(*,'(10(F16.10,X))')overlap(i,:)
@ -315,13 +323,21 @@ subroutine diagonalize_s2_betweenstates(keys_tmp,psi_coefs_inout,n,nmax_keys,nma
call ortho_lowdin(overlap,size(overlap,1),nstates,psi_coefs_inout,size(psi_coefs_inout,1),n) call ortho_lowdin(overlap,size(overlap,1),nstates,psi_coefs_inout,size(psi_coefs_inout,1),n)
print*,'passed ortho' print*,'passed ortho'
do i = 1, nstates !$OMP PARALLEL DO COLLAPSE(2) DEFAULT(NONE) SCHEDULE(dynamic) &
overlap(i,i) = u_dot_u(psi_coefs_inout(1,i),n) !$OMP PRIVATE(i,j) SHARED(overlap,psi_coefs_inout,nstates,n)
do j = i+1, nstates do i = 1, nstates
overlap(i,j) = u_dot_v(psi_coefs_inout(1,j),psi_coefs_inout(1,i),n) do j = 1, nstates
overlap(j,i) = overlap(i,j) if (i < j) then
enddo cycle
enddo else if (i == j) then
overlap(i,i) = u_dot_u(psi_coefs_inout(1,i),n)
else
overlap(i,j) = u_dot_v(psi_coefs_inout(1,j),psi_coefs_inout(1,i),n)
overlap(j,i) = overlap(i,j)
endif
enddo
enddo
!$OMP END PARALLEL DO
print*,'Overlap matrix in the basis of the Lowdin orthonormalized states ' print*,'Overlap matrix in the basis of the Lowdin orthonormalized states '
do i = 1, nstates do i = 1, nstates
write(*,'(10(F16.10,X))')overlap(i,:) write(*,'(10(F16.10,X))')overlap(i,:)

1
src/Determinants/save_natorb.irp.f
View File

@ -2,5 +2,6 @@ program save_natorb
read_wf = .True. read_wf = .True.
touch read_wf touch read_wf
call save_natural_mos call save_natural_mos
call save_ref_determinant
end end

6
src/Determinants/slater_rules.irp.f
View File

@ -970,12 +970,13 @@ subroutine create_minilist_find_previous(key_mask, fullList, miniList, N_fullLis
integer, intent(in) :: Nint integer, intent(in) :: Nint
integer(bit_kind), intent(in) :: fullList(Nint, 2, N_fullList) integer(bit_kind), intent(in) :: fullList(Nint, 2, N_fullList)
integer(bit_kind),intent(out) :: miniList(Nint, 2, N_fullList) integer(bit_kind),intent(out) :: miniList(Nint, 2, N_fullList)
integer(bit_kind) :: subList(Nint, 2, N_fullList) integer(bit_kind), allocatable :: subList(:,:,:)
logical,intent(out) :: fullMatch logical,intent(out) :: fullMatch
integer,intent(out) :: N_miniList integer,intent(out) :: N_miniList
integer(bit_kind) :: key_mask(Nint, 2) integer(bit_kind) :: key_mask(Nint, 2)
integer :: ni, i, k, l, N_subList integer :: ni, i, k, l, N_subList
allocate (subList(Nint, 2, N_fullList))
fullMatch = .false. fullMatch = .false.
N_miniList = 0 N_miniList = 0
@ -1032,6 +1033,8 @@ subroutine create_minilist_find_previous(key_mask, fullList, miniList, N_fullLis
enddo enddo
N_minilist = N_minilist + N_subList N_minilist = N_minilist + N_subList
end if end if
deallocate(sublist)
end subroutine end subroutine
@ -1127,6 +1130,7 @@ subroutine i_H_psi_minilist(key,keys,idx_key,N_minilist,coef,Nint,Ndet,Ndet_max,
i_in_coef = idx_key(idx(ii)) i_in_coef = idx_key(idx(ii))
!DIR$ FORCEINLINE !DIR$ FORCEINLINE
call i_H_j(keys(1,1,i_in_key),key,Nint,hij) call i_H_j(keys(1,1,i_in_key),key,Nint,hij)
! TODO : Cache misses
i_H_psi_array(1) = i_H_psi_array(1) + coef(i_in_coef,1)*hij i_H_psi_array(1) = i_H_psi_array(1) + coef(i_in_coef,1)*hij
enddo enddo

29
src/Integrals_Bielec/ao_bi_integrals.irp.f
View File

@ -4,6 +4,7 @@ double precision function ao_bielec_integral(i,j,k,l)
! integral of the AO basis <ik|jl> or (ij|kl) ! integral of the AO basis <ik|jl> or (ij|kl)
! i(r1) j(r1) 1/r12 k(r2) l(r2) ! i(r1) j(r1) 1/r12 k(r2) l(r2)
END_DOC END_DOC
integer,intent(in) :: i,j,k,l integer,intent(in) :: i,j,k,l
integer :: p,q,r,s integer :: p,q,r,s
double precision :: I_center(3),J_center(3),K_center(3),L_center(3) double precision :: I_center(3),J_center(3),K_center(3),L_center(3)
@ -350,13 +351,11 @@ BEGIN_PROVIDER [ logical, ao_bielec_integrals_in_map ]
real :: map_mb real :: map_mb
if (read_ao_integrals) then if (read_ao_integrals) then
integer :: load_ao_integrals
print*,'Reading the AO integrals' print*,'Reading the AO integrals'
if (load_ao_integrals(trim(ezfio_filename)//'/work/ao_integrals.bin') == 0) then call map_load_from_disk(trim(ezfio_filename)//'/work/ao_ints',ao_integrals_map)
print*, 'AO integrals provided' print*, 'AO integrals provided'
ao_bielec_integrals_in_map = .True. ao_bielec_integrals_in_map = .True.
return return
endif
endif endif
print*, 'Providing the AO integrals' print*, 'Providing the AO integrals'
@ -370,24 +369,20 @@ BEGIN_PROVIDER [ logical, ao_bielec_integrals_in_map ]
call new_parallel_job(zmq_to_qp_run_socket,'ao_integrals') call new_parallel_job(zmq_to_qp_run_socket,'ao_integrals')
do l=1,ao_num do l=1,ao_num
write(task,*) l write(task,*) "triangle ", l
call add_task_to_taskserver(zmq_to_qp_run_socket,task) call add_task_to_taskserver(zmq_to_qp_run_socket,task)
enddo enddo
integer(ZMQ_PTR) :: collector_thread PROVIDE nproc
external :: ao_bielec_integrals_in_map_collector !$OMP PARALLEL DEFAULT(private) num_threads(nproc+1)
rc = pthread_create(collector_thread, ao_bielec_integrals_in_map_collector)
!$OMP PARALLEL DEFAULT(private)
!$OMP TASK PRIVATE(i)
i = omp_get_thread_num() i = omp_get_thread_num()
call ao_bielec_integrals_in_map_slave_inproc(i) if (i==0) then
!$OMP END TASK call ao_bielec_integrals_in_map_collector(i)
!$OMP TASKWAIT else
call ao_bielec_integrals_in_map_slave_inproc(i)
endif
!$OMP END PARALLEL !$OMP END PARALLEL
rc = pthread_join(collector_thread)
call end_parallel_job(zmq_to_qp_run_socket, 'ao_integrals') call end_parallel_job(zmq_to_qp_run_socket, 'ao_integrals')
@ -405,8 +400,10 @@ BEGIN_PROVIDER [ logical, ao_bielec_integrals_in_map ]
print*, ' wall time :',wall_2 - wall_1, 's ( x ', (cpu_2-cpu_1)/(wall_2-wall_1+tiny(1.d0)), ' )' print*, ' wall time :',wall_2 - wall_1, 's ( x ', (cpu_2-cpu_1)/(wall_2-wall_1+tiny(1.d0)), ' )'
ao_bielec_integrals_in_map = .True. ao_bielec_integrals_in_map = .True.
if (write_ao_integrals) then if (write_ao_integrals) then
call dump_ao_integrals(trim(ezfio_filename)//'/work/ao_integrals.bin') call ezfio_set_work_empty(.False.)
call map_save_to_disk(trim(ezfio_filename)//'/work/ao_ints',ao_integrals_map)
call ezfio_set_integrals_bielec_disk_access_ao_integrals("Read") call ezfio_set_integrals_bielec_disk_access_ao_integrals("Read")
endif endif

132
src/Integrals_Bielec/ao_bielec_integrals_in_map_slave.irp.f
View File

@ -34,25 +34,25 @@ subroutine push_integrals(zmq_socket_push, n_integrals, buffer_i, buffer_value,
rc = f77_zmq_send( zmq_socket_push, n_integrals, 4, ZMQ_SNDMORE) rc = f77_zmq_send( zmq_socket_push, n_integrals, 4, ZMQ_SNDMORE)
if (rc /= 4) then if (rc /= 4) then
print *, irp_here, 'f77_zmq_send( zmq_socket_push, n_integrals, 4, ZMQ_SNDMORE)' print *, irp_here, ': f77_zmq_send( zmq_socket_push, n_integrals, 4, ZMQ_SNDMORE)'
stop 'error' stop 'error'
endif endif
rc = f77_zmq_send( zmq_socket_push, buffer_i, key_kind*n_integrals, ZMQ_SNDMORE) rc = f77_zmq_send( zmq_socket_push, buffer_i, key_kind*n_integrals, ZMQ_SNDMORE)
if (rc /= key_kind*n_integrals) then if (rc /= key_kind*n_integrals) then
print *, irp_here, 'f77_zmq_send( zmq_socket_push, buffer_i, key_kind*n_integrals, ZMQ_SNDMORE)' print *, irp_here, ': f77_zmq_send( zmq_socket_push, buffer_i, key_kind*n_integrals, ZMQ_SNDMORE)'
stop 'error' stop 'error'
endif endif
rc = f77_zmq_send( zmq_socket_push, buffer_value, integral_kind*n_integrals, ZMQ_SNDMORE) rc = f77_zmq_send( zmq_socket_push, buffer_value, integral_kind*n_integrals, ZMQ_SNDMORE)
if (rc /= integral_kind*n_integrals) then if (rc /= integral_kind*n_integrals) then
print *, irp_here, 'f77_zmq_send( zmq_socket_push, buffer_value, integral_kind*n_integrals, 0)' print *, irp_here, ': f77_zmq_send( zmq_socket_push, buffer_value, integral_kind*n_integrals, 0)'
stop 'error' stop 'error'
endif endif
rc = f77_zmq_send( zmq_socket_push, task_id, 4, 0) rc = f77_zmq_send( zmq_socket_push, task_id, 4, 0)
if (rc /= 4) then if (rc /= 4) then
print *, irp_here, 'f77_zmq_send( zmq_socket_push, task_id, 4, 0)' print *, irp_here, ': f77_zmq_send( zmq_socket_push, task_id, 4, 0)'
stop 'error' stop 'error'
endif endif
@ -60,7 +60,7 @@ subroutine push_integrals(zmq_socket_push, n_integrals, buffer_i, buffer_value,
! integer :: idummy ! integer :: idummy
! rc = f77_zmq_recv( zmq_socket_push, idummy, 4, 0) ! rc = f77_zmq_recv( zmq_socket_push, idummy, 4, 0)
! if (rc /= 4) then ! if (rc /= 4) then
! print *, irp_here, 'f77_zmq_send( zmq_socket_push, idummy, 4, 0)' ! print *, irp_here, ': f77_zmq_send( zmq_socket_push, idummy, 4, 0)'
! stop 'error' ! stop 'error'
! endif ! endif
end end
@ -93,6 +93,8 @@ subroutine ao_bielec_integrals_in_map_slave(thread,iproc)
integer(ZMQ_PTR), external :: new_zmq_push_socket integer(ZMQ_PTR), external :: new_zmq_push_socket
integer(ZMQ_PTR) :: zmq_socket_push integer(ZMQ_PTR) :: zmq_socket_push
character*(64) :: state
zmq_to_qp_run_socket = new_zmq_to_qp_run_socket() zmq_to_qp_run_socket = new_zmq_to_qp_run_socket()
zmq_socket_push = new_zmq_push_socket(thread) zmq_socket_push = new_zmq_push_socket(thread)
@ -103,81 +105,21 @@ subroutine ao_bielec_integrals_in_map_slave(thread,iproc)
do do
call get_task_from_taskserver(zmq_to_qp_run_socket,worker_id, task_id, task) call get_task_from_taskserver(zmq_to_qp_run_socket,worker_id, task_id, task)
if (task_id == 0) exit if (task_id == 0) exit
read(task,*) l read(task,*) j, l
do j=1,l-1 call compute_ao_integrals_jl(j,l,n_integrals,buffer_i,buffer_value)
call compute_ao_integrals_jl(j,l,n_integrals,buffer_i,buffer_value)
call push_integrals(zmq_socket_push, n_integrals, buffer_i, buffer_value, 0)
enddo
call compute_ao_integrals_jl(l,l,n_integrals,buffer_i,buffer_value)
call task_done_to_taskserver(zmq_to_qp_run_socket,worker_id,task_id) call task_done_to_taskserver(zmq_to_qp_run_socket,worker_id,task_id)
call push_integrals(zmq_socket_push, n_integrals, buffer_i, buffer_value, task_id) call push_integrals(zmq_socket_push, n_integrals, buffer_i, buffer_value, task_id)
enddo enddo
deallocate( buffer_i, buffer_value )
call disconnect_from_taskserver(zmq_to_qp_run_socket,zmq_socket_push,worker_id) call disconnect_from_taskserver(zmq_to_qp_run_socket,zmq_socket_push,worker_id)
deallocate( buffer_i, buffer_value )
call end_zmq_to_qp_run_socket(zmq_to_qp_run_socket) call end_zmq_to_qp_run_socket(zmq_to_qp_run_socket)
call end_zmq_push_socket(zmq_socket_push,thread) call end_zmq_push_socket(zmq_socket_push,thread)
end end
subroutine pull_integrals(zmq_socket_pull, n_integrals, buffer_i, buffer_value, task_id)
use f77_zmq
use map_module
implicit none
BEGIN_DOC
! How the collector pulls the computed integrals
END_DOC
integer(ZMQ_PTR), intent(in) :: zmq_socket_pull
integer, intent(out) :: n_integrals
integer(key_kind), intent(out) :: buffer_i(*)
real(integral_kind), intent(out) :: buffer_value(*)
integer, intent(out) :: task_id
integer :: rc
rc = f77_zmq_recv( zmq_socket_pull, n_integrals, 4, 0)
if (rc == -1) then
n_integrals = 0
return
endif
if (rc /= 4) then
print *, irp_here, 'f77_zmq_recv( zmq_socket_pull, n_integrals, 4, 0)'
stop 'error'
endif
if (n_integrals >= 0) then
rc = f77_zmq_recv( zmq_socket_pull, buffer_i, key_kind*n_integrals, 0)
if (rc /= key_kind*n_integrals) then
print *, irp_here, 'f77_zmq_recv( zmq_socket_pull, buffer_i, key_kind*n_integrals, 0)'
stop 'error'
endif
rc = f77_zmq_recv( zmq_socket_pull, buffer_value, integral_kind*n_integrals, 0)
if (rc /= integral_kind*n_integrals) then
print *, irp_here, 'f77_zmq_recv( zmq_socket_pull, buffer_value, integral_kind*n_integrals, 0)'
stop 'error'
endif
rc = f77_zmq_recv( zmq_socket_pull, task_id, 4, 0)
if (rc /= 4) then
print *, irp_here, 'f77_zmq_recv( zmq_socket_pull, task_id, 4, 0)'
stop 'error'
endif
endif
! Activate if zmq_socket_pull is a REP
! rc = f77_zmq_send( zmq_socket_pull, 0, 4, 0)
! if (rc /= 4) then
! print *, irp_here, ' f77_zmq_send (zmq_socket_pull,...'
! stop 'error'
! endif
end
subroutine ao_bielec_integrals_in_map_collector subroutine ao_bielec_integrals_in_map_collector
use map_module use map_module
use f77_zmq use f77_zmq
@ -199,19 +141,59 @@ subroutine ao_bielec_integrals_in_map_collector
integer(ZMQ_PTR) :: zmq_socket_pull integer(ZMQ_PTR) :: zmq_socket_pull
integer*8 :: control, accu integer*8 :: control, accu
integer :: task_id, more integer :: task_id, more, sze
zmq_to_qp_run_socket = new_zmq_to_qp_run_socket() zmq_to_qp_run_socket = new_zmq_to_qp_run_socket()
zmq_socket_pull = new_zmq_pull_socket() zmq_socket_pull = new_zmq_pull_socket()
allocate ( buffer_i(ao_num*ao_num), buffer_value(ao_num*ao_num) ) sze = ao_num*ao_num
allocate ( buffer_i(sze), buffer_value(sze) )
accu = 0_8 accu = 0_8
more = 1 more = 1
do while (more == 1) do while (more == 1)
call pull_integrals(zmq_socket_pull, n_integrals, buffer_i, buffer_value, task_id) rc = f77_zmq_recv( zmq_socket_pull, n_integrals, 4, 0)
if (rc == -1) then
n_integrals = 0
return
endif
if (rc /= 4) then
print *, irp_here, ': f77_zmq_recv( zmq_socket_pull, n_integrals, 4, 0)'
stop 'error'
endif
if (n_integrals >= 0) then if (n_integrals >= 0) then
if (n_integrals > sze) then
deallocate (buffer_value, buffer_i)
sze = n_integrals
allocate (buffer_value(sze), buffer_i(sze))
endif
rc = f77_zmq_recv( zmq_socket_pull, buffer_i, key_kind*n_integrals, 0)
if (rc /= key_kind*n_integrals) then
print *, rc, key_kind, n_integrals
print *, irp_here, ': f77_zmq_recv( zmq_socket_pull, buffer_i, key_kind*n_integrals, 0)'
stop 'error'
endif
rc = f77_zmq_recv( zmq_socket_pull, buffer_value, integral_kind*n_integrals, 0)
if (rc /= integral_kind*n_integrals) then
print *, irp_here, ': f77_zmq_recv( zmq_socket_pull, buffer_value, integral_kind*n_integrals, 0)'
stop 'error'
endif
rc = f77_zmq_recv( zmq_socket_pull, task_id, 4, 0)
! Activate if zmq_socket_pull is a REP
! rc = f77_zmq_send( zmq_socket_pull, 0, 4, 0)
! if (rc /= 4) then
! print *, irp_here, ' : f77_zmq_send (zmq_socket_pull,...'
! stop 'error'
! endif
call insert_into_ao_integrals_map(n_integrals,buffer_i,buffer_value) call insert_into_ao_integrals_map(n_integrals,buffer_i,buffer_value)
accu += n_integrals accu += n_integrals
if (task_id /= 0) then if (task_id /= 0) then
@ -227,9 +209,11 @@ subroutine ao_bielec_integrals_in_map_collector
control = get_ao_map_size(ao_integrals_map) control = get_ao_map_size(ao_integrals_map)
if (control /= accu) then if (control /= accu) then
print *, irp_here, 'Control : ', control print *, ''
print *, 'Accu : ', accu print *, irp_here
print *, 'Some integrals were lost during the parallel computation. (2)' print *, 'Control : ', control
print *, 'Accu : ', accu
print *, 'Some integrals were lost during the parallel computation.'
print *, 'Try to reduce the number of threads.' print *, 'Try to reduce the number of threads.'
stop stop
endif endif

3
src/Integrals_Bielec/map_integrals.irp.f
View File

@ -13,7 +13,7 @@ BEGIN_PROVIDER [ type(map_type), ao_integrals_map ]
call bielec_integrals_index(ao_num,ao_num,ao_num,ao_num,key_max) call bielec_integrals_index(ao_num,ao_num,ao_num,ao_num,key_max)
sze = key_max sze = key_max
call map_init(ao_integrals_map,sze) call map_init(ao_integrals_map,sze)
print*, 'AO map initialized' print*, 'AO map initialized : ', sze
END_PROVIDER END_PROVIDER
subroutine bielec_integrals_index(i,j,k,l,i1) subroutine bielec_integrals_index(i,j,k,l,i1)
@ -230,7 +230,6 @@ subroutine clear_ao_map
end end
!! MO Map !! MO Map
!! ====== !! ======

24
src/Integrals_Bielec/mo_bi_integrals.irp.f
View File

@ -28,12 +28,10 @@ BEGIN_PROVIDER [ logical, mo_bielec_integrals_in_map ]
mo_bielec_integrals_in_map = .True. mo_bielec_integrals_in_map = .True.
if (read_mo_integrals) then if (read_mo_integrals) then
integer :: load_mo_integrals
print*,'Reading the MO integrals' print*,'Reading the MO integrals'
if (load_mo_integrals(trim(ezfio_filename)//'/work/mo_integrals.bin') == 0) then call map_load_from_disk(trim(ezfio_filename)//'/work/mo_ints',mo_integrals_map)
print*, 'MO integrals provided' print*, 'MO integrals provided'
return return
endif
endif endif
call add_integrals_to_map(full_ijkl_bitmask_4) call add_integrals_to_map(full_ijkl_bitmask_4)
@ -72,7 +70,7 @@ subroutine add_integrals_to_map(mask_ijkl)
integer :: i2,i3,i4 integer :: i2,i3,i4
double precision,parameter :: thr_coef = 1.d-10 double precision,parameter :: thr_coef = 1.d-10
PROVIDE ao_bielec_integrals_in_map PROVIDE ao_bielec_integrals_in_map mo_coef
!Get list of MOs for i,j,k and l !Get list of MOs for i,j,k and l
!------------------------------- !-------------------------------
@ -299,7 +297,8 @@ subroutine add_integrals_to_map(mask_ijkl)
print*,' wall time :',wall_2 - wall_1, 's ( x ', (cpu_2-cpu_1)/(wall_2-wall_1), ')' print*,' wall time :',wall_2 - wall_1, 's ( x ', (cpu_2-cpu_1)/(wall_2-wall_1), ')'
if (write_mo_integrals) then if (write_mo_integrals) then
call dump_mo_integrals(trim(ezfio_filename)//'/work/mo_integrals.bin') call ezfio_set_work_empty(.False.)
call map_save_to_disk(trim(ezfio_filename)//'/work/mo_ints',mo_integrals_map)
call ezfio_set_integrals_bielec_disk_access_mo_integrals("Read") call ezfio_set_integrals_bielec_disk_access_mo_integrals("Read")
endif endif
@ -329,7 +328,7 @@ end
double precision, allocatable :: iqrs(:,:), iqsr(:,:), iqis(:), iqri(:) double precision, allocatable :: iqrs(:,:), iqsr(:,:), iqis(:), iqri(:)
if (.not.do_direct_integrals) then if (.not.do_direct_integrals) then
PROVIDE ao_bielec_integrals_in_map PROVIDE ao_bielec_integrals_in_map mo_coef
endif endif
mo_bielec_integral_jj_from_ao = 0.d0 mo_bielec_integral_jj_from_ao = 0.d0
@ -495,4 +494,13 @@ subroutine clear_mo_map
call map_deinit(mo_integrals_map) call map_deinit(mo_integrals_map)
FREE mo_integrals_map mo_bielec_integral_schwartz mo_bielec_integral_jj mo_bielec_integral_jj_anti FREE mo_integrals_map mo_bielec_integral_schwartz mo_bielec_integral_jj mo_bielec_integral_jj_anti
FREE mo_bielec_integral_jj_exchange mo_bielec_integrals_in_map FREE mo_bielec_integral_jj_exchange mo_bielec_integrals_in_map
end
subroutine provide_all_mo_integrals
implicit none
provide mo_integrals_map mo_bielec_integral_schwartz mo_bielec_integral_jj mo_bielec_integral_jj_anti
provide mo_bielec_integral_jj_exchange mo_bielec_integrals_in_map
end end

13
src/Integrals_Bielec/qp_ao_ints.irp.f
View File

@ -17,10 +17,15 @@ program qp_ao_ints
double precision :: integral, ao_bielec_integral double precision :: integral, ao_bielec_integral
integral = ao_bielec_integral(1,1,1,1) integral = ao_bielec_integral(1,1,1,1)
!$OMP PARALLEL DEFAULT(PRIVATE) PRIVATE(i) character*(64) :: state
i = omp_get_thread_num() call wait_for_state(zmq_state,state)
call ao_bielec_integrals_in_map_slave_tcp(i) do while (state /= 'Stopped')
!$OMP END PARALLEL !$OMP PARALLEL DEFAULT(PRIVATE) PRIVATE(i)
i = omp_get_thread_num()
call ao_bielec_integrals_in_map_slave_tcp(i)
!$OMP END PARALLEL
call wait_for_state(zmq_state,state)
enddo
print *, 'Done' print *, 'Done'
end end

Some files were not shown because too many files have changed in this diff Show More