diff --git a/README.md b/README.md index e313f444..5372b7ac 100644 --- a/README.md +++ b/README.md @@ -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) - [![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. (under GNU GENERAL PUBLIC LICENSE v2) diff --git a/config/ifort.cfg b/config/ifort.cfg index 47a654c3..5002ae89 100644 --- a/config/ifort.cfg +++ b/config/ifort.cfg @@ -6,7 +6,7 @@ # --align=32 : Align all provided arrays on a 32-byte boundary # [COMMON] -FC : ifort -g +FC : ifort LAPACK_LIB : -mkl=parallel IRPF90 : irpf90 IRPF90_FLAGS : --ninja --align=32 @@ -31,13 +31,14 @@ OPENMP : 1 ; Append OpenMP flags # -ftz : Flushes denormal results to zero # [OPT] -FCFLAGS : -xSSE4.2 -O2 -ip -ftz -g +FC : -traceback +FCFLAGS : -xHost -O2 -ip -ftz -g # Profiling flags ################# # [PROFILE] -FC : -p -g +FC : -p -g -traceback FCFLAGS : -xSSE4.2 -O2 -ip -ftz # Debugging flags @@ -51,13 +52,13 @@ FCFLAGS : -xSSE4.2 -O2 -ip -ftz # [DEBUG] FC : -g -traceback -FCFLAGS : -xAVX -C -fpe0 +FCFLAGS : -xSSE2 -C -fpe0 IRPF90_FLAGS : --openmp # OpenMP flags ################# # [OPENMP] -FC : -openmp +FC : -qopenmp IRPF90_FLAGS : --openmp diff --git a/data/pseudo/tm b/data/pseudo/tm new file mode 100644 index 00000000..531445f8 --- /dev/null +++ b/data/pseudo/tm @@ -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 + diff --git a/data/pseudo/tn_df b/data/pseudo/tn_df new file mode 100644 index 00000000..79ebf8f5 --- /dev/null +++ b/data/pseudo/tn_df @@ -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 + + diff --git a/data/pseudo/tn_df_sc b/data/pseudo/tn_df_sc new file mode 100644 index 00000000..aa3234af --- /dev/null +++ b/data/pseudo/tn_df_sc @@ -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 + + + diff --git a/data/pseudo/tn_hf b/data/pseudo/tn_hf new file mode 100644 index 00000000..a036558a --- /dev/null +++ b/data/pseudo/tn_hf @@ -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 + + + + diff --git a/data/qp.png b/data/qp.png new file mode 100644 index 00000000..777e5ac0 Binary files /dev/null and b/data/qp.png differ diff --git a/install/scripts/install_ocaml.sh b/install/scripts/install_ocaml.sh index 86e4e8b7..a7462b2e 100755 --- a/install/scripts/install_ocaml.sh +++ b/install/scripts/install_ocaml.sh @@ -6,6 +6,7 @@ cd - # Normal installation PACKAGES="core cryptokit ocamlfind sexplib ZMQ" +#ppx_sexp_conv # Needed for ZeroMQ export C_INCLUDE_PATH="${QP_ROOT}"/lib:"${C_INCLUDE_PATH}" diff --git a/ocaml/Atom.ml b/ocaml/Atom.ml index 832cfa5b..72932b1f 100644 --- a/ocaml/Atom.ml +++ b/ocaml/Atom.ml @@ -1,4 +1,4 @@ -open Core.Std;; +open Core.Std exception AtomError of string @@ -27,12 +27,18 @@ let of_string ~units s = coord = Point3d.of_string ~units (String.concat [x; y; z] ~sep:" ") } | _ -> raise (AtomError s) -;; + let to_string ~units a = [ Element.to_string a.element ; Charge.to_string a.charge ; Point3d.to_string ~units a.coord ] |> String.concat ~sep:" " -;; + + +let to_xyz a = + Printf.sprintf "%-3s %s" + (Element.to_string a.element) + (Point3d.to_string ~units:Units.Angstrom a.coord) + diff --git a/ocaml/Atom.mli b/ocaml/Atom.mli index 28915993..4b1963d5 100644 --- a/ocaml/Atom.mli +++ b/ocaml/Atom.mli @@ -7,3 +7,4 @@ val sexp_of_t : t -> Sexplib.Sexp.t val of_string : units:Units.units -> string -> t val to_string : units:Units.units -> t -> string +val to_xyz : t -> string diff --git a/ocaml/Basis.ml b/ocaml/Basis.ml index 237e5547..869fb132 100644 --- a/ocaml/Basis.ml +++ b/ocaml/Basis.ml @@ -35,11 +35,11 @@ let read_element in_channel at_number element = read in_channel at_number -let to_string b = + +let to_string_general ~fmt ~atom_sep b = let new_nucleus n = Printf.sprintf "Atom %d" n in - let rec do_work accu current_nucleus = function | [] -> List.rev accu | (g,n)::tail -> @@ -47,15 +47,27 @@ let to_string b = in let accu = if (n <> current_nucleus) then - (new_nucleus n)::""::accu + (new_nucleus n)::atom_sep::accu else accu in - do_work ((Gto.to_string g)::accu) n tail + do_work ((Gto.to_string ~fmt g)::accu) n tail in do_work [new_nucleus 1] 1 b |> 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 let to_md5 = to_md5 sexp_of_t diff --git a/ocaml/Basis.mli b/ocaml/Basis.mli index 4da99266..249c14f9 100644 --- a/ocaml/Basis.mli +++ b/ocaml/Basis.mli @@ -14,7 +14,7 @@ val read_element : in_channel -> Nucl_number.t -> Element.t -> (Gto.t * Nucl_number.t) list (** 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 *) val to_md5 : (Gto.t * Nucl_number.t) list -> MD5.t diff --git a/ocaml/Element.ml b/ocaml/Element.ml index 6bc2de4e..df85663f 100644 --- a/ocaml/Element.ml +++ b/ocaml/Element.ml @@ -9,6 +9,7 @@ type t = |Li|Be |B |C |N |O |F |Ne |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 +|Rb|Sr|Y |Zr|Nb|Mo|Tc|Ru|Rh|Pd|Ag|Cd|In|Sn|Sb|Te|I |Xe with sexp let of_string x = @@ -50,6 +51,24 @@ let of_string x = | "Se" | "Selenium" -> Se | "Br" | "Bromine" -> Br | "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")) @@ -91,6 +110,24 @@ let to_string = function | Se -> "Se" | Br -> "Br" | 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 @@ -131,6 +168,24 @@ let to_long_string = function | Se -> "Selenium" | Br -> "Bromine" | 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 = @@ -172,47 +227,83 @@ let to_charge c = | Se -> 34 | Br -> 35 | 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 let of_charge c = match (Charge.to_int c) with -| 0 -> X -| 1 -> H -| 2 -> He -| 3 -> Li -| 4 -> Be -| 5 -> B -| 6 -> C -| 7 -> N -| 8 -> O -| 9 -> F -| 10 -> Ne -| 11 -> Na -| 12 -> Mg -| 13 -> Al -| 14 -> Si -| 15 -> P -| 16 -> S -| 17 -> Cl -| 18 -> Ar -| 19 -> K -| 20 -> Ca -| 21 -> Sc -| 22 -> Ti -| 23 -> V -| 24 -> Cr -| 25 -> Mn -| 26 -> Fe -| 27 -> Co -| 28 -> Ni -| 29 -> Cu -| 30 -> Zn -| 31 -> Ga -| 32 -> Ge -| 33 -> As -| 34 -> Se -| 35 -> Br -| 36 -> Kr +| 0 -> X +| 1 -> H +| 2 -> He +| 3 -> Li +| 4 -> Be +| 5 -> B +| 6 -> C +| 7 -> N +| 8 -> O +| 9 -> F +| 10 -> Ne +| 11 -> Na +| 12 -> Mg +| 13 -> Al +| 14 -> Si +| 15 -> P +| 16 -> S +| 17 -> Cl +| 18 -> Ar +| 19 -> K +| 20 -> Ca +| 21 -> Sc +| 22 -> Ti +| 23 -> V +| 24 -> Cr +| 25 -> Mn +| 26 -> Fe +| 27 -> Co +| 28 -> Ni +| 29 -> Cu +| 30 -> Zn +| 31 -> Ga +| 32 -> Ge +| 33 -> As +| 34 -> Se +| 35 -> Br +| 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")) @@ -255,6 +346,24 @@ let covalent_radius x = | Se -> 0.70 | Br -> 1.24 | 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 Units.angstrom_to_bohr *. (result x) |> Positive_float.of_float @@ -298,6 +407,24 @@ let vdw_radius x = | Se -> 1.70 | Br -> 2.10 | 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 Units.angstrom_to_bohr *. (result x) |> Positive_float.of_float @@ -341,6 +468,24 @@ let mass x = | Se -> 78.96 | Br -> 79.904 | 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 result x |> Positive_float.of_float diff --git a/ocaml/Element.mli b/ocaml/Element.mli index 8d9862c9..5edfdf31 100644 --- a/ocaml/Element.mli +++ b/ocaml/Element.mli @@ -6,6 +6,7 @@ type t = |Li|Be |B |C |N |O |F |Ne |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 +|Rb|Sr|Y |Zr|Nb|Mo|Tc|Ru|Rh|Pd|Ag|Cd|In|Sn|Sb|Te|I |Xe with sexp (** String conversion functions *) diff --git a/ocaml/Gto.ml b/ocaml/Gto.ml index 69aeba37..fb576ee7 100644 --- a/ocaml/Gto.ml +++ b/ocaml/Gto.ml @@ -4,6 +4,10 @@ open Qptypes exception GTO_Read_Failure of string exception End_Of_Basis +type fmt = +| Gamess +| Gaussian + type t = { sym : Symmetry.t ; lc : ((Primitive.t * AO_coef.t) list) @@ -68,8 +72,8 @@ let read_one in_channel = -(** Transform the gto to a string *) -let to_string { sym = sym ; lc = lc } = +(** Write the GTO in Gamess format *) +let to_string_gamess { sym = sym ; lc = lc } = let result = Printf.sprintf "%s %3d" (Symmetry.to_string sym) (List.length lc) in @@ -88,3 +92,30 @@ let to_string { sym = sym ; lc = lc } = |> 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 + + diff --git a/ocaml/Gto.mli b/ocaml/Gto.mli index fad133a3..753cd81a 100644 --- a/ocaml/Gto.mli +++ b/ocaml/Gto.mli @@ -1,5 +1,9 @@ exception GTO_Read_Failure of string exception End_Of_Basis +type fmt = +| Gamess +| Gaussian + type t = { sym : Symmetry.t ; lc : (Primitive.t * Qptypes.AO_coef.t) list; @@ -13,4 +17,4 @@ val of_prim_coef_list : val read_one : in_channel -> t (** Convert to string for printing *) -val to_string : t -> string +val to_string : ?fmt:fmt -> t -> string diff --git a/ocaml/Input_ao_basis.ml b/ocaml/Input_ao_basis.ml index 82bc4964..88e277ee 100644 --- a/ocaml/Input_ao_basis.ml +++ b/ocaml/Input_ao_basis.ml @@ -17,6 +17,7 @@ module Ao_basis : sig ;; val read : unit -> t option val to_string : t -> string + val to_basis : t -> Basis.t val write : t -> unit val to_md5 : t -> MD5.t val to_rst : t -> Rst_string.t diff --git a/ocaml/Input_nuclei.ml b/ocaml/Input_nuclei.ml index d050ded9..ca81629e 100644 --- a/ocaml/Input_nuclei.ml +++ b/ocaml/Input_nuclei.ml @@ -13,6 +13,7 @@ module Nuclei : sig val read : unit -> t option val write : t -> unit val to_string : t -> string + val to_atom_list : t -> Atom.t list val to_rst : t -> Rst_string.t val of_rst : Rst_string.t -> t option 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 = Printf.sprintf " nucl_num = %s diff --git a/ocaml/Molecule.ml b/ocaml/Molecule.ml index f0800f7f..a9d73432 100644 --- a/ocaml/Molecule.ml +++ b/ocaml/Molecule.ml @@ -85,7 +85,7 @@ let name m = String.concat (result) -let to_string m = +let to_string_general ~f m = let { nuclei ; elec_alpha ; elec_beta } = m in let n = @@ -94,10 +94,15 @@ let to_string m = let title = name m in - [ Int.to_string n ; title ] @ - (List.map ~f:(fun x -> Atom.to_string Units.Angstrom x) nuclei) + [ Int.to_string n ; title ] @ (List.map ~f nuclei) |> 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 ?(charge=(Charge.of_int 0)) ?(multiplicity=(Multiplicity.of_int 1)) diff --git a/ocaml/Molecule.mli b/ocaml/Molecule.mli index 1a3d9715..f81f28a3 100644 --- a/ocaml/Molecule.mli +++ b/ocaml/Molecule.mli @@ -20,6 +20,7 @@ val name : t -> string (** Conversion for printing *) val to_string : t -> string +val to_xyz : t -> string (** Creates a molecule from an xyz file *) diff --git a/ocaml/TaskServer.ml b/ocaml/TaskServer.ml index 67d5bb07..d6d6bc51 100644 --- a/ocaml/TaskServer.ml +++ b/ocaml/TaskServer.ml @@ -2,6 +2,23 @@ open Core.Std 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 = { queue : Queuing_system.t ; @@ -120,7 +137,7 @@ let stop ~port = 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 = msg.Message.Newjob_msg.state @@ -143,10 +160,12 @@ let new_job msg program_state rep_socket = } in reply_ok rep_socket; + string_of_pub_state (Running (Message.State.to_string state)) + |> ZMQ.Socket.send pair_socket ; result -let end_job msg program_state rep_socket = +let end_job msg program_state rep_socket pair_socket = let failure () = reply_wrong_state rep_socket; @@ -165,7 +184,11 @@ let end_job msg program_state rep_socket = | Some state -> begin 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 failure () 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 = msg.Message.GetTask_msg.state, @@ -371,6 +394,12 @@ let get_task msg program_state rep_socket = let new_queue, task_id, task = Queuing_system.pop_task ~client_id program_state.queue 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 = { program_state with @@ -512,18 +541,76 @@ let error msg program_state rep_socket = |> ZMQ.Socket.send rep_socket ; 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 = + (** 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 *) let rep_socket = ZMQ.Socket.create zmq_context ZMQ.Socket.rep and address = - Printf.sprintf "tcp://%s:%d" (Lazy.force ip_address) port + Printf.sprintf "tcp://*:%d" port in - bind_socket "REP" rep_socket address; ZMQ.Socket.set_linger_period rep_socket 1_000_000; + bind_socket "REP" rep_socket address; let initial_program_state = { queue = Queuing_system.create () ; @@ -542,6 +629,9 @@ let run ~port = [| (rep_socket, ZMQ.Poll.In) |] in + let address = + Printf.sprintf "tcp://%s:%d" (Lazy.force ip_address) port + in Printf.printf "Task server running : %s\n%!" address; @@ -591,15 +681,15 @@ let run ~port = | _ , Message.Terminate _ -> terminate 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 - | 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 - | 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 | Some _, Message.Connect x -> connect 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.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 | _ , _ -> error ("Invalid message : "^(Message.to_string message)) program_state rep_socket @@ -614,6 +704,10 @@ let run ~port = end in main_loop initial_program_state true; + ZMQ.Socket.send pair_socket @@ string_of_pub_state Stopped; + Thread.join pub_thread; + + diff --git a/ocaml/TaskServer.mli b/ocaml/TaskServer.mli new file mode 100644 index 00000000..f923a18a --- /dev/null +++ b/ocaml/TaskServer.mli @@ -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 + diff --git a/ocaml/_tags b/ocaml/_tags index fd4c4804..3f5cd9b6 100644 --- a/ocaml/_tags +++ b/ocaml/_tags @@ -1,3 +1,3 @@ -true: package(core,sexplib.syntax,cryptokit,ZMQ) +true: package(core,cryptokit,ZMQ,sexplib.syntax) true: thread false: profile diff --git a/plugins/All_singles/H_apply.irp.f b/plugins/All_singles/H_apply.irp.f index d0a41f90..f34f003c 100644 --- a/plugins/All_singles/H_apply.irp.f +++ b/plugins/All_singles/H_apply.irp.f @@ -8,10 +8,9 @@ s.unset_skip() s.filter_only_1h1p() print s -s = H_apply("just_mono") +s = H_apply("just_mono",do_double_exc=False) s.set_selection_pt2("epstein_nesbet_2x2") s.unset_skip() -s.unset_double_excitations() print s END_SHELL diff --git a/plugins/All_singles/all_singles.irp.f b/plugins/All_singles/all_singles.irp.f index 3b5c5cce..ad8648c7 100644 --- a/plugins/All_singles/all_singles.irp.f +++ b/plugins/All_singles/all_singles.irp.f @@ -15,7 +15,7 @@ subroutine routine integer :: N_st, degree double precision,allocatable :: E_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)) i = 0 print*,'N_det = ',N_det diff --git a/plugins/CAS_SD/H_apply.irp.f b/plugins/CAS_SD/H_apply.irp.f index aa393bc7..35c45fb6 100644 --- a/plugins/CAS_SD/H_apply.irp.f +++ b/plugins/CAS_SD/H_apply.irp.f @@ -20,22 +20,18 @@ print s s = H_apply("CAS_S",do_double_exc=False) -s.unset_double_excitations() print s s = H_apply("CAS_S_selected_no_skip",do_double_exc=False) -s.unset_double_excitations() s.set_selection_pt2("epstein_nesbet_2x2") s.unset_skip() print s s = H_apply("CAS_S_selected",do_double_exc=False) -s.unset_double_excitations() s.set_selection_pt2("epstein_nesbet_2x2") print s s = H_apply("CAS_S_PT2",do_double_exc=False) -s.unset_double_excitations() s.set_perturbation("epstein_nesbet_2x2") print s diff --git a/plugins/DDCI_selected/ddci.irp.f b/plugins/DDCI_selected/ddci.irp.f index 248671b1..0bfb324f 100644 --- a/plugins/DDCI_selected/ddci.irp.f +++ b/plugins/DDCI_selected/ddci.irp.f @@ -3,10 +3,10 @@ program ddci 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 - N_st = N_states - allocate (pt2(N_st), norm_pert(N_st),H_pert_diag(N_st)) + N_st = N_states_diag + allocate (pt2(N_st), norm_pert(N_st),H_pert_diag(N_st),E_before(N_st)) character*(64) :: perturbation pt2 = 1.d0 @@ -27,6 +27,8 @@ program ddci print *, 'E+PT2 = ', CI_energy+pt2 print *, '-----' 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) 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 *, 'PT2 = ', pt2 print *, 'E = ', CI_energy - print *, 'E+PT2 = ', CI_energy+pt2 + print *, 'E+PT2 = ', E_before+pt2 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) enddo if(do_pt2_end)then diff --git a/plugins/FOBOCI/EZFIO.cfg b/plugins/FOBOCI/EZFIO.cfg index d4a10add..88189608 100644 --- a/plugins/FOBOCI/EZFIO.cfg +++ b/plugins/FOBOCI/EZFIO.cfg @@ -1,6 +1,13 @@ -[threshold_singles] +[threshold_lmct] 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 default: 0.01 @@ -16,6 +23,20 @@ doc: if true, you do the FOBOCI calculation perturbatively interface: ezfio,provider,ocaml 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] type: logical doc: if true, you do the FOBOCI calculation using second order intermediate Hamiltonian diff --git a/plugins/FOBOCI/H_apply.irp.f b/plugins/FOBOCI/H_apply.irp.f index 0a488753..d8ab02f1 100644 --- a/plugins/FOBOCI/H_apply.irp.f +++ b/plugins/FOBOCI/H_apply.irp.f @@ -18,8 +18,22 @@ print s -s = H_apply("standard") +s = H_apply("only_1h2p") 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() print s diff --git a/plugins/FOBOCI/NEEDED_CHILDREN_MODULES b/plugins/FOBOCI/NEEDED_CHILDREN_MODULES index adeefe99..f6c0c1c4 100644 --- a/plugins/FOBOCI/NEEDED_CHILDREN_MODULES +++ b/plugins/FOBOCI/NEEDED_CHILDREN_MODULES @@ -1 +1 @@ -Perturbation Generators_restart Selectors_no_sorted +Perturbation Selectors_no_sorted Hartree_Fock diff --git a/plugins/FOBOCI/all_singles.irp.f b/plugins/FOBOCI/all_singles.irp.f index e2c4c01e..0594e56e 100644 --- a/plugins/FOBOCI/all_singles.irp.f +++ b/plugins/FOBOCI/all_singles.irp.f @@ -6,9 +6,9 @@ subroutine all_single 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 = 1.d-8 + selection_criterion = 0.d0 soft_touch selection_criterion - threshold_davidson = 1.d-5 + threshold_davidson = 1.d-9 soft_touch threshold_davidson davidson_criterion i = 0 print*,'Doing all the mono excitations !' @@ -52,10 +52,173 @@ subroutine all_single enddo endif E_before = CI_energy + !!!!!!!!!!!!!!!!!!!!!!!!!!! DOING ONLY ONE ITERATION OF SELECTION AS THE SELECTION CRITERION IS SET TO ZERO + exit 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 - 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*,'N_det = ',N_det do i = 1, N_states_diag @@ -67,10 +230,89 @@ subroutine all_single do i = 1, 2 print*,'psi_coef = ',psi_coef(i,1) enddo -! call save_wavefunction deallocate(pt2,norm_pert,E_before) 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 implicit none integer :: i,k @@ -79,6 +321,8 @@ subroutine all_single_no_1h_or_1p 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 @@ -124,7 +368,7 @@ subroutine all_single_no_1h_or_1p endif E_before = CI_energy enddo - threshold_davidson = 1.d-10 + threshold_davidson = 1.d-16 soft_touch threshold_davidson davidson_criterion call diagonalize_CI print*,'Final Step ' @@ -215,85 +459,6 @@ subroutine all_single_no_1h_or_1p_or_2p deallocate(pt2,norm_pert,E_before) 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 implicit none integer :: i,k diff --git a/plugins/FOBOCI/all_singles_split.irp.f b/plugins/FOBOCI/all_singles_split.irp.f index e7b0943f..9ddf369a 100644 --- a/plugins/FOBOCI/all_singles_split.irp.f +++ b/plugins/FOBOCI/all_singles_split.irp.f @@ -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) 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) - integer :: i,i_hole + integer :: i,i_hole,j n_det_max_jacobi = 50 soft_touch n_det_max_jacobi 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_psi_det_as_input_psi(ndet_generators_input,psi_det_generators_input,psi_coef_generators_input) call all_single - threshold_davidson = 1.d-10 - soft_touch threshold_davidson davidson_criterion - call diagonalize_CI +! 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_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 soft_touch n_det_max_jacobi 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 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_2h1p(N_det_generators,N_det_generators) - integer :: i,i_hole + double precision, intent(inout) :: dressing_matrix_1h2p(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 - integer :: n_det_1h1p,n_det_2h1p - 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 + call all_single threshold_davidson = 1.d-12 soft_touch threshold_davidson davidson_criterion 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) - deallocate(psi_ref_coef_out) - deallocate(psi_coef_1h1p) - deallocate(psi_coef_2h1p) + + + double precision, allocatable :: matrix_ref_1h_1p(:,:) + double precision, allocatable :: matrix_ref_1h_1p_dressing_1h1p(:,:) + double precision, allocatable :: matrix_ref_1h_1p_dressing_1h2p(:,:) + 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 @@ -197,47 +480,56 @@ subroutine all_single_split_for_1p(dressing_matrix_1h1p,dressing_matrix_1h2p) soft_touch n_det_max_jacobi end -subroutine all_single_for_1p(dressing_matrix_1h1p,dressing_matrix_1h2p) - implicit none - use bitmasks - double precision, intent(inout) :: dressing_matrix_1h1p(N_det_generators,N_det_generators) - double precision, intent(inout) :: dressing_matrix_1h2p(N_det_generators,N_det_generators) - integer :: i,i_hole - n_det_max_jacobi = 50 - soft_touch n_det_max_jacobi - - integer :: n_det_1h1p,n_det_1h2p - integer(bit_kind), allocatable :: psi_ref_out(:,:,:) - integer(bit_kind), allocatable :: psi_1h1p(:,:,:) - integer(bit_kind), allocatable :: psi_1h2p(:,:,:) - double precision, allocatable :: psi_ref_coef_out(:,:) - double precision, allocatable :: psi_coef_1h1p(:,:) - double precision, allocatable :: psi_coef_1h2p(:,:) - call all_single_no_1h_or_1p_or_2p - - threshold_davidson = 1.d-12 - soft_touch threshold_davidson davidson_criterion - call diagonalize_CI - call give_n_1h1p_and_n_1h2p_in_psi_det(n_det_1h1p,n_det_1h2p) - allocate(psi_ref_out(N_int,2,N_det_generators)) - allocate(psi_1h1p(N_int,2,n_det_1h1p)) - allocate(psi_1h2p(N_int,2,n_det_1h2p)) - allocate(psi_ref_coef_out(N_det_generators,N_states)) - allocate(psi_coef_1h1p(n_det_1h1p,N_states)) - allocate(psi_coef_1h2p(n_det_1h2p,N_states)) - 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) - 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_1h2p,psi_ref_out,psi_ref_coef_out,N_det_generators, & - psi_1h2p,psi_coef_1h2p,n_det_1h2p) - - deallocate(psi_ref_out) - deallocate(psi_1h1p) - deallocate(psi_1h2p) - deallocate(psi_ref_coef_out) - deallocate(psi_coef_1h1p) - deallocate(psi_coef_1h2p) - -end +! subroutine all_single_for_1p(i_particl,dressing_matrix_1h1p,dressing_matrix_1h2p,dressing_matrix_extra_1h_or_1p) +! implicit none +! 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_1h2p(N_det_generators,N_det_generators) +! double precision, intent(inout) :: dressing_matrix_extra_1h_or_1p(N_det_generators,N_det_generators) +! integer :: i +! n_det_max_jacobi = 50 +! soft_touch n_det_max_jacobi +! +! integer :: n_det_1h1p,n_det_1h2p,n_det_extra_1h_or_1p +! integer(bit_kind), allocatable :: psi_ref_out(:,:,:) +! integer(bit_kind), allocatable :: psi_1h1p(:,:,:) +! integer(bit_kind), allocatable :: psi_1h2p(:,:,:) +! integer(bit_kind), allocatable :: psi_extra_1h_or_1p(:,:,:) +! double precision, allocatable :: psi_ref_coef_out(:,:) +! double precision, allocatable :: psi_coef_1h1p(:,:) +! double precision, allocatable :: psi_coef_1h2p(:,:) +! double precision, allocatable :: psi_coef_extra_1h_or_1p(:,:) +!!!!call all_single_no_1h_or_1p_or_2p +! call all_single +! +! threshold_davidson = 1.d-12 +! soft_touch threshold_davidson davidson_criterion +! call diagonalize_CI +! 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_ref_out(N_int,2,N_det_generators)) +! allocate(psi_1h1p(N_int,2,n_det_1h1p)) +! allocate(psi_1h2p(N_int,2,n_det_1h2p)) +! 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_1h2p(n_det_1h2p,N_states)) +! allocate(psi_coef_extra_1h_or_1p(n_det_extra_1h_or_1p,N_states)) +! 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) +! 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_1h2p,psi_ref_out,psi_ref_coef_out,N_det_generators, & +! 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, & +! 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 diff --git a/plugins/FOBOCI/collect_all_lmct.irp.f b/plugins/FOBOCI/collect_all_lmct.irp.f new file mode 100644 index 00000000..96eb2858 --- /dev/null +++ b/plugins/FOBOCI/collect_all_lmct.irp.f @@ -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 + diff --git a/plugins/FOBOCI/corr_energy_2h2p.irp.f b/plugins/FOBOCI/corr_energy_2h2p.irp.f new file mode 100644 index 00000000..ada46bf2 --- /dev/null +++ b/plugins/FOBOCI/corr_energy_2h2p.irp.f @@ -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 diff --git a/plugins/FOBOCI/diag_fock_inactiv_virt.irp.f b/plugins/FOBOCI/diag_fock_inactiv_virt.irp.f index a4c6b652..83955e61 100644 --- a/plugins/FOBOCI/diag_fock_inactiv_virt.irp.f +++ b/plugins/FOBOCI/diag_fock_inactiv_virt.irp.f @@ -3,6 +3,7 @@ subroutine diag_inactive_virt_and_update_mos integer :: i,j,i_inact,j_inact,i_virt,j_virt double precision :: tmp(mo_tot_num_align,mo_tot_num) character*(64) :: label + print*,'Diagonalizing the occ and virt Fock operator' tmp = 0.d0 do i = 1, mo_tot_num tmp(i,i) = Fock_matrix_mo(i,i) @@ -33,3 +34,50 @@ subroutine diag_inactive_virt_and_update_mos 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 diff --git a/plugins/FOBOCI/dress_simple.irp.f b/plugins/FOBOCI/dress_simple.irp.f index 2f662f4d..99566a8e 100644 --- a/plugins/FOBOCI/dress_simple.irp.f +++ b/plugins/FOBOCI/dress_simple.irp.f @@ -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) f = 1.d0/(E_ref-haa) - if(second_order_h)then +! if(second_order_h)then lambda_i = f - else - ! You write the new Hamiltonian matrix - do k = 1, Ndet_generators - H_matrix_tmp(k,Ndet_generators+1) = H_array(k) - H_matrix_tmp(Ndet_generators+1,k) = H_array(k) - enddo - H_matrix_tmp(Ndet_generators+1,Ndet_generators+1) = haa - ! Then diagonalize it - call lapack_diag(eigenvalues,eigenvectors,H_matrix_tmp,Ndet_generators+1,Ndet_generators+1) - ! Then you extract the effective denominator - accu = 0.d0 - do k = 1, Ndet_generators - accu += eigenvectors(k,1) * H_array(k) - enddo - lambda_i = eigenvectors(Ndet_generators+1,1)/accu - endif +! else +! ! You write the new Hamiltonian matrix +! do k = 1, Ndet_generators +! H_matrix_tmp(k,Ndet_generators+1) = H_array(k) +! H_matrix_tmp(Ndet_generators+1,k) = H_array(k) +! enddo +! H_matrix_tmp(Ndet_generators+1,Ndet_generators+1) = haa +! ! Then diagonalize it +! call lapack_diag(eigenvalues,eigenvectors,H_matrix_tmp,Ndet_generators+1,Ndet_generators+1) +! ! Then you extract the effective denominator +! accu = 0.d0 +! do k = 1, Ndet_generators +! accu += eigenvectors(k,1) * H_array(k) +! enddo +! lambda_i = eigenvectors(Ndet_generators+1,1)/accu +! endif do k=1,idx(0) contrib = H_array(idx(k)) * H_array(idx(k)) * lambda_i 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 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 end diff --git a/plugins/FOBOCI/fobo_scf.irp.f b/plugins/FOBOCI/fobo_scf.irp.f new file mode 100644 index 00000000..8656b633 --- /dev/null +++ b/plugins/FOBOCI/fobo_scf.irp.f @@ -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 diff --git a/plugins/FOBOCI/foboci_lmct_mlct_threshold_old.irp.f b/plugins/FOBOCI/foboci_lmct_mlct_threshold_old.irp.f index 087f791b..dc6519b8 100644 --- a/plugins/FOBOCI/foboci_lmct_mlct_threshold_old.irp.f +++ b/plugins/FOBOCI/foboci_lmct_mlct_threshold_old.irp.f @@ -9,12 +9,9 @@ subroutine FOBOCI_lmct_mlct_old_thr double precision :: norm_tmp(N_states),norm_total(N_states) logical :: test_sym double precision :: thr,hij - double precision :: threshold double precision, allocatable :: dressing_matrix(:,:) logical :: verbose,is_ok verbose = .True. - threshold = threshold_singles - print*,'threshold = ',threshold thr = 1.d-12 allocate(unpaired_bitmask(N_int,2)) allocate (occ(N_int*bit_kind_size,2)) @@ -36,7 +33,14 @@ subroutine FOBOCI_lmct_mlct_old_thr print*,'' print*,'' 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 + lmct = .True. integer :: i_hole_osoci i_hole_osoci = list_inact(i) print*,'--------------------------' @@ -51,27 +55,91 @@ subroutine FOBOCI_lmct_mlct_old_thr print*,'Passed set generators' call set_bitmask_particl_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 if(.not.is_ok)cycle - ! so all the mono excitation on the new generators allocate(dressing_matrix(N_det_generators,N_det_generators)) + dressing_matrix = 0.d0 if(.not.do_it_perturbative)then -! call all_single - dressing_matrix = 0.d0 + do k = 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) dressing_matrix(k,l) = hkl enddo enddo - double precision :: hkl -! 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 debug_det(reunion_of_bitmask,N_int) + hkl = dressing_matrix(1,1) + do k = 1, N_det_generators + dressing_matrix(k,k) = dressing_matrix(k,k) - hkl + 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 +! 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 call set_intermediate_normalization_lmct_old(norm_tmp,i_hole_osoci) + do k = 1, N_states print*,'norm_tmp = ',norm_tmp(k) norm_total(k) += norm_tmp(k) @@ -83,9 +151,12 @@ subroutine FOBOCI_lmct_mlct_old_thr if(.True.)then print*,'' print*,'DOING THEN THE MLCT !!' + print*,'Threshold_mlct = ',threshold_mlct + lmct = .False. do i = 1, n_virt_orb integer :: i_particl_osoci i_particl_osoci = list_virt(i) + print*,'--------------------------' ! First set the current generators to the one of 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_hole_as_input(reunion_of_bitmask) !! ! 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 if(.not.is_ok)cycle 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 diag_dressed_matrix_and_set_to_psi_det(psi_det_generators,N_det_generators,dressing_matrix) call all_single +! if(dressing_2h2p)then +! call diag_dressed_2h2p_hamiltonian_and_update_psi_det(i_particl_osoci,lmct) +! endif endif call set_intermediate_normalization_mlct_old(norm_tmp,i_particl_osoci) do k = 1, N_states @@ -132,24 +206,6 @@ subroutine FOBOCI_lmct_mlct_old_thr deallocate(dressing_matrix) enddo 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 norm_total = norm_generators_restart @@ -174,10 +230,8 @@ subroutine FOBOCI_mlct_old double precision :: norm_tmp,norm_total logical :: test_sym double precision :: thr - double precision :: threshold logical :: verbose,is_ok verbose = .False. - threshold = 1.d-2 thr = 1.d-12 allocate(unpaired_bitmask(N_int,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_hole_as_input(reunion_of_bitmask) ! ! 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 is_ok =.True. if(.not.is_ok)cycle @@ -250,10 +304,8 @@ subroutine FOBOCI_lmct_old double precision :: norm_tmp,norm_total logical :: test_sym double precision :: thr - double precision :: threshold logical :: verbose,is_ok verbose = .False. - threshold = 1.d-2 thr = 1.d-12 allocate(unpaired_bitmask(N_int,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_bitmask_particl_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 if(.not.is_ok)cycle ! ! so all the mono excitation on the new generators diff --git a/plugins/FOBOCI/foboci_reunion.irp.f b/plugins/FOBOCI/foboci_reunion.irp.f new file mode 100644 index 00000000..fcfaff58 --- /dev/null +++ b/plugins/FOBOCI/foboci_reunion.irp.f @@ -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 + diff --git a/plugins/FOBOCI/generators_restart_save.irp.f b/plugins/FOBOCI/generators_restart_save.irp.f index dca4c901..09d4aa2b 100644 --- a/plugins/FOBOCI/generators_restart_save.irp.f +++ b/plugins/FOBOCI/generators_restart_save.irp.f @@ -1,126 +1,74 @@ -use bitmasks +use bitmasks + BEGIN_PROVIDER [ integer, N_det_generators_restart ] implicit none BEGIN_DOC - ! Number of determinants in the wave function + ! Read the wave function END_DOC - logical :: exists - character*64 :: label + integer :: i integer, save :: ifirst = 0 -!if(ifirst == 0)then - PROVIDE ezfio_filename - call ezfio_has_determinants_n_det(exists) - 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) + double precision :: norm + if(ifirst == 0)then + call ezfio_get_determinants_n_det(N_det_generators_restart) 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 - 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 [ double precision, psi_coef_generators_restart, (N_det_generators_restart,N_states) ] implicit none BEGIN_DOC - ! The wave function determinants. Initialized with Hartree-Fock if the EZFIO file - ! is empty + ! read wf + ! END_DOC - integer :: i - logical :: exists - character*64 :: label - + integer :: i, k integer, save :: ifirst = 0 -!if(ifirst == 0)then - provide N_det_generators_restart - if(.True.)then - call ezfio_has_determinants_N_int(exists) - if (exists) then - call ezfio_has_determinants_bit_kind(exists) - if (exists) then - call ezfio_has_determinants_N_det(exists) - if (exists) then - call ezfio_has_determinants_N_states(exists) - if (exists) then - call ezfio_has_determinants_psi_det(exists) - endif - endif - 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 + double precision, allocatable :: psi_coef_read(:,:) + if(ifirst == 0)then + call read_dets(psi_det_generators_restart,N_int,N_det_generators_restart) + do k = 1, N_int + ref_generators_restart(k,1) = psi_det_generators_restart(k,1,1) + ref_generators_restart(k,2) = psi_det_generators_restart(k,2,1) + enddo + 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 ifirst = 1 -!endif + deallocate(psi_coef_read) + else + print*,'PB in generators_restart restart !!!' + endif END_PROVIDER - - -BEGIN_PROVIDER [ double precision, psi_coef_generators_restart, (psi_det_size,N_states_diag) ] - implicit none - BEGIN_DOC - ! The wave function coefficients. Initialized with Hartree-Fock if the EZFIO file - ! 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 - - - +BEGIN_PROVIDER [ integer, size_select_max] + implicit none + BEGIN_DOC + ! Size of the select_max array + END_DOC + size_select_max = 10000 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 diff --git a/plugins/FOBOCI/hcc_1h1p.irp.f b/plugins/FOBOCI/hcc_1h1p.irp.f new file mode 100644 index 00000000..66cf2fd4 --- /dev/null +++ b/plugins/FOBOCI/hcc_1h1p.irp.f @@ -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 + diff --git a/plugins/FOBOCI/modify_generators.irp.f b/plugins/FOBOCI/modify_generators.irp.f index c756f0c2..359b6405 100644 --- a/plugins/FOBOCI/modify_generators.irp.f +++ b/plugins/FOBOCI/modify_generators.irp.f @@ -6,6 +6,7 @@ subroutine set_generators_to_psi_det END_DOC N_det_generators = N_det integer :: i,k + print*,'N_det = ',N_det do i=1,N_det_generators do k=1,N_int psi_det_generators(k,1,i) = psi_det(k,1,i) diff --git a/plugins/FOBOCI/new_approach.irp.f b/plugins/FOBOCI/new_approach.irp.f index 49dcafc3..8e2f2e53 100644 --- a/plugins/FOBOCI/new_approach.irp.f +++ b/plugins/FOBOCI/new_approach.irp.f @@ -24,6 +24,7 @@ subroutine new_approach double precision, allocatable :: dressing_matrix_1h1p(:,:) double precision, allocatable :: dressing_matrix_2h1p(:,:) double precision, allocatable :: dressing_matrix_1h2p(:,:) + double precision, allocatable :: dressing_matrix_extra_1h_or_1p(:,:) double precision, allocatable :: H_matrix_tmp(:,:) logical :: verbose,is_ok @@ -45,7 +46,7 @@ subroutine new_approach verbose = .True. - threshold = threshold_singles + threshold = threshold_lmct print*,'threshold = ',threshold thr = 1.d-12 print*,'' @@ -81,12 +82,14 @@ subroutine new_approach ! so all the mono excitation on the new generators allocate(dressing_matrix_1h1p(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_2h1p = 0.d0 + dressing_matrix_extra_1h_or_1p = 0.d0 if(.not.do_it_perturbative)then n_good_hole +=1 ! 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)) do j = 1,N_det_generators do k = 1, N_det_generators @@ -96,7 +99,7 @@ subroutine new_approach enddo do j = 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 hjk = H_matrix_tmp(1,1) @@ -130,6 +133,7 @@ subroutine new_approach endif deallocate(dressing_matrix_1h1p) deallocate(dressing_matrix_2h1p) + deallocate(dressing_matrix_extra_1h_or_1p) enddo print*,'' @@ -155,12 +159,14 @@ subroutine new_approach ! so all the mono excitation on the new generators allocate(dressing_matrix_1h1p(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_1h2p = 0.d0 + dressing_matrix_extra_1h_or_1p = 0.d0 if(.not.do_it_perturbative)then n_good_hole +=1 ! 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)) do j = 1,N_det_generators do k = 1, N_det_generators @@ -170,7 +176,7 @@ subroutine new_approach enddo do j = 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 hjk = H_matrix_tmp(1,1) @@ -205,7 +211,10 @@ subroutine new_approach endif deallocate(dressing_matrix_1h1p) deallocate(dressing_matrix_1h2p) + deallocate(dressing_matrix_extra_1h_or_1p) enddo + + double precision, allocatable :: H_matrix_total(:,:) integer :: n_det_total 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 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 - 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 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 enddo enddo - print*,'H matrix to diagonalize' - double precision :: href - href = H_matrix_total(1,1) - do i = 1, n_det_total - H_matrix_total(i,i) -= href + + ! Adding the correlation energy + logical :: orb_taken_good_det(mo_tot_num) + 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 + 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 - do i = 1, n_det_total - write(*,'(100(X,F16.8))')H_matrix_total(i,:) - enddo - double precision, allocatable :: eigvalues(:),eigvectors(:,:) - 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*,'e_dressed = ',eigvalues(1) + nuclear_repulsion + href - do i = 1, n_det_total - print*,'coef = ',eigvectors(i,1) - enddo - integer(bit_kind), allocatable :: psi_det_final(:,:,:) - double precision, allocatable :: psi_coef_final(:,:) - double precision :: norm + + do i = 1, N_det_generators_restart + ! Add the 2h2p, 2h1p and 1h2p correlation energy + H_matrix_total(i,i) += total_corr_e_2h2p + total_corr_e_2h1p + total_corr_e_1h2p + total_corr_e_1h1p_spin_flip + ! Substract the 2h1p part that have already been taken into account + do j = 1, n_inact_orb + iorb = list_inact(j) + if(.not.orb_taken_good_det(iorb))cycle + 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 + ! Substract the 1h2p part that have already been taken into account + do j = 1, n_virt_orb + 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_det_final(N_int,2,n_det_total)) 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) 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 j = 1, N_states - 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) + print*,'coef = ',eigvectors(i,1),H_matrix_total(i,i) - H_matrix_total(1,1) 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) - print*,'' -!do i = 1, N_det -! call debug_det(psi_det(1,1,i),N_int) -! print*,'coef = ',psi_coef(i,1) -!enddo + + do i = 1, N_det + call debug_det(psi_det(1,1,i),N_int) + print*,'coef = ',psi_coef(i,1) + enddo provide one_body_dm_mo 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 do j = 1, n_inact_orb 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*,'DM ',iorb,jorb,dabs(one_body_dm_mo(iorb,jorb)) endif enddo do j = 1, n_virt_orb 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*,'DM ',iorb,jorb,dabs(one_body_dm_mo(iorb,jorb)) endif diff --git a/plugins/FOBOCI/new_new_approach.irp.f b/plugins/FOBOCI/new_new_approach.irp.f new file mode 100644 index 00000000..b904a5b3 --- /dev/null +++ b/plugins/FOBOCI/new_new_approach.irp.f @@ -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 diff --git a/plugins/FOBOCI/routines_dressing.irp.f b/plugins/FOBOCI/routines_dressing.irp.f index 910f1109..125143da 100644 --- a/plugins/FOBOCI/routines_dressing.irp.f +++ b/plugins/FOBOCI/routines_dressing.irp.f @@ -55,15 +55,11 @@ subroutine provide_matrix_dressing(dressing_matrix,ndet_generators_input,psi_det i_pert = 0 endif 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 exit endif enddo -! print*,'' -! print*,'lambda_i,f = ',lambda_i,f -! print*,'i_pert = ',i_pert -! print*,'' if(i_pert==1)then lambda_i = f i_pert_count +=1 @@ -79,9 +75,122 @@ subroutine provide_matrix_dressing(dressing_matrix,ndet_generators_input,psi_det 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 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, & psi_det_outer_input,psi_coef_outer_input,n_det_outer_input) 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 enddo 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 i_pert = 0 endif 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 exit endif enddo +! i_pert = 0 if(i_pert==1)then lambda_i = f i_pert_count +=1 @@ -170,114 +280,379 @@ subroutine diag_dressed_matrix_and_set_to_psi_det(psi_det_generators_input,Ndet_ 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 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 :: 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_restart_tmp = 0 n_det_1h = 0 n_det_1h1p = 0 n_det_2h1p = 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 ==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 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, 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) stop endif 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 print*,'PB !!!!' print*,'You have forgotten something in your generators ... ' stop 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 -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 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 :: n_det_ref_restart_tmp,n_det_1h integer :: number_of_holes,n_h, number_of_particles,n_p - n_det_ref_restart_tmp = 0 - n_det_1h = 0 + logical :: is_the_hole_in_det + n_det_ref_1h_1p = 0 + n_det_2h1p = 0 n_det_1h1p = 0 - n_det_1h2p = 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 + 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_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 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 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) stop endif 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*,'You have forgotten something in your generators ... ' - stop - endif + 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 + 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 -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 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_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_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_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_extra_1h_or_1p(n_det_extra_1h_or_1p, N_states) integer :: i,j integer :: degree 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_1h1p(:) integer, allocatable :: index_2h1p(:) + integer, allocatable :: index_extra_1h_or_1p(:) + logical :: is_the_hole_in_det allocate(index_1h1p(n_det)) allocate(index_2h1p(n_det)) + allocate(index_extra_1h_or_1p(n_det)) allocate(index_generator(N_det)) n_det_generators_tmp = 0 n_det_1h1p_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 n_h = number_of_holes(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 n_det_2h1p_tmp +=1 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 do j = 1, N_det_generators 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 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 j = 1, N_int 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 + 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_1h1p) deallocate(index_2h1p) + deallocate(index_extra_1h_or_1p) 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 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_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_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_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_extra_1h_or_1p(n_det_extra_1h_or_1p, N_states) integer :: i,j integer :: degree 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_1h1p(:) 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_1h2p(n_det)) + allocate(index_extra_1h_or_1p(n_det)) allocate(index_generator(N_det)) n_det_generators_tmp = 0 n_det_1h1p_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 n_h = number_of_holes(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 n_det_1h2p_tmp +=1 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 do j = 1, N_det_generators 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 + 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_1h1p) deallocate(index_1h2p) + deallocate(index_extra_1h_or_1p) end diff --git a/plugins/FOBOCI/routines_foboci.irp.f b/plugins/FOBOCI/routines_foboci.irp.f index 696011a9..4aca60d7 100644 --- a/plugins/FOBOCI/routines_foboci.irp.f +++ b/plugins/FOBOCI/routines_foboci.irp.f @@ -332,20 +332,20 @@ subroutine save_osoci_natural_mos enddo tmp = tmp_bis -!! Symetrization act-virt - do j = 1, n_virt_orb - j_virt= list_virt(j) - accu = 0.d0 - do i = 1, n_act_orb - jorb = list_act(i) - accu += dabs(tmp_bis(j_virt,jorb)) - enddo - do i = 1, n_act_orb - iorb = list_act(i) - 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)) - enddo - enddo +!!! Symetrization act-virt +! do j = 1, n_virt_orb +! j_virt= list_virt(j) +! accu = 0.d0 +! do i = 1, n_act_orb +! jorb = list_act(i) +! accu += dabs(tmp_bis(j_virt,jorb)) +! enddo +! do i = 1, n_act_orb +! iorb = list_act(i) +! 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)) +! enddo +! enddo !! Symetrization act-inact !do j = 1, n_inact_orb @@ -387,16 +387,16 @@ subroutine save_osoci_natural_mos print*,'ACTIVE ORBITAL ',iorb do j = 1, n_inact_orb 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*,'DM ',iorb,jorb,dabs(tmp(iorb,jorb)) + print*,'DM ',iorb,jorb,(tmp(iorb,jorb)) endif enddo do j = 1, n_virt_orb 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*,'DM ',iorb,jorb,dabs(tmp(iorb,jorb)) + print*,'DM ',iorb,jorb,(tmp(iorb,jorb)) endif enddo enddo @@ -410,8 +410,9 @@ subroutine save_osoci_natural_mos enddo label = "Natural" + 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) @@ -518,16 +519,16 @@ subroutine set_osoci_natural_mos print*,'ACTIVE ORBITAL ',iorb do j = 1, n_inact_orb 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*,'DM ',iorb,jorb,dabs(tmp(iorb,jorb)) + print*,'DM ',iorb,jorb,(tmp(iorb,jorb)) endif enddo do j = 1, n_virt_orb 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*,'DM ',iorb,jorb,dabs(tmp(iorb,jorb)) + print*,'DM ',iorb,jorb,(tmp(iorb,jorb)) endif enddo enddo @@ -602,15 +603,210 @@ end subroutine provide_properties implicit none - integer :: i - double precision :: accu - 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 + call print_mulliken_sd + call print_hcc 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 diff --git a/plugins/Full_CI/H_apply.irp.f b/plugins/Full_CI/H_apply.irp.f index d6888dc3..596c947a 100644 --- a/plugins/Full_CI/H_apply.irp.f +++ b/plugins/Full_CI/H_apply.irp.f @@ -7,6 +7,11 @@ s.set_selection_pt2("epstein_nesbet_2x2") #s.unset_openmp() 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.set_perturbation("epstein_nesbet_2x2") s.unset_openmp() diff --git a/plugins/Full_CI/micro_pt2.irp.f b/plugins/Full_CI/micro_pt2.irp.f index d78a942d..9ce45eb5 100644 --- a/plugins/Full_CI/micro_pt2.irp.f +++ b/plugins/Full_CI/micro_pt2.irp.f @@ -24,8 +24,12 @@ subroutine run_wf integer(ZMQ_PTR) :: zmq_to_qp_run_socket print *, 'Getting wave function' + zmq_context = f77_zmq_ctx_new () + 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 write_double(6,ci_energy,'Energy') zmq_state = 'h_apply_fci_pt2' @@ -33,6 +37,8 @@ subroutine run_wf call provide_everything integer :: rc, i + print *, 'Contribution to PT2 running' + !$OMP PARALLEL PRIVATE(i) i = omp_get_thread_num() call H_apply_FCI_PT2_slave_tcp(i) diff --git a/plugins/Full_CI/var_pt2_ratio.irp.f b/plugins/Full_CI/var_pt2_ratio.irp.f index 3d942a30..1ea52dda 100644 --- a/plugins/Full_CI/var_pt2_ratio.irp.f +++ b/plugins/Full_CI/var_pt2_ratio.irp.f @@ -11,7 +11,7 @@ program var_pt2_ratio_run 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 pt2 = 1.d0 @@ -30,6 +30,7 @@ program var_pt2_ratio_run threshold_selectors = 1.d0 threshold_generators = 0.999d0 + selection_criterion_save = selection_criterion call diagonalize_CI call H_apply_FCI_PT2(pt2, norm_pert, H_pert_diag, N_st) E_ref = CI_energy(1) + pt2(1) @@ -46,6 +47,8 @@ program var_pt2_ratio_run Nmax = max(Nmax,Nmin+10) ! Select new determinants 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 Nmax = N_det N_det = Nmin + (Nmax-Nmin)/2 diff --git a/plugins/Full_CI_ZMQ/fci_zmq.irp.f b/plugins/Full_CI_ZMQ/fci_zmq.irp.f index b3a89b74..3d324555 100644 --- a/plugins/Full_CI_ZMQ/fci_zmq.irp.f +++ b/plugins/Full_CI_ZMQ/fci_zmq.irp.f @@ -1,3 +1,4 @@ +<<<<<<< HEAD program fci_zmq @@ -270,3 +271,47 @@ end ! end do ! ! 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 diff --git a/plugins/Generators_restart/generators.irp.f b/plugins/Generators_restart/generators.irp.f index 0a82e6f9..17854330 100644 --- a/plugins/Generators_restart/generators.irp.f +++ b/plugins/Generators_restart/generators.irp.f @@ -1,5 +1,5 @@ use bitmasks - + BEGIN_PROVIDER [ integer, N_det_generators ] implicit none BEGIN_DOC @@ -8,17 +8,18 @@ BEGIN_PROVIDER [ integer, N_det_generators ] integer :: i integer, save :: ifirst = 0 double precision :: norm - read_wf = .True. if(ifirst == 0)then - N_det_generators = N_det + call ezfio_get_determinants_n_det(N_det_generators) ifirst = 1 + else + print*,'PB in generators restart !!!' endif call write_int(output_determinants,N_det_generators,'Number of generators') END_PROVIDER - BEGIN_PROVIDER [ integer(bit_kind), psi_det_generators, (N_int,2,psi_det_size) ] -&BEGIN_PROVIDER [ double precision, psi_coef_generators, (psi_det_size,N_states) ] + BEGIN_PROVIDER [ integer(bit_kind), psi_det_generators, (N_int,2,N_det_generators) ] +&BEGIN_PROVIDER [ double precision, psi_coef_generators, (N_det_generators,N_states) ] implicit none BEGIN_DOC ! read wf @@ -26,17 +27,20 @@ END_PROVIDER END_DOC integer :: i, k integer, save :: ifirst = 0 + double precision, allocatable :: psi_coef_read(:,:) if(ifirst == 0)then - do i=1,N_det_generators - do k=1,N_int - psi_det_generators(k,1,i) = psi_det(k,1,i) - psi_det_generators(k,2,i) = psi_det(k,2,i) - enddo + call read_dets(psi_det_generators,N_int,N_det_generators) + allocate (psi_coef_read(N_det_generators,N_states)) + call ezfio_get_determinants_psi_coef(psi_coef_read) 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 ifirst = 1 + deallocate(psi_coef_read) + else + print*,'PB in generators restart !!!' endif END_PROVIDER diff --git a/plugins/Hartree_Fock/Fock_matrix.irp.f b/plugins/Hartree_Fock/Fock_matrix.irp.f index 397f8f83..af9255c8 100644 --- a/plugins/Hartree_Fock/Fock_matrix.irp.f +++ b/plugins/Hartree_Fock/Fock_matrix.irp.f @@ -223,6 +223,7 @@ END_PROVIDER ao_bi_elec_integral_beta_tmp = 0.d0 !$OMP DO SCHEDULE(dynamic) + !DIR$ NOVECTOR do i8=0_8,ao_integrals_map%map_size n_elements = n_elements_max call get_cache_map(ao_integrals_map,i8,keys,values,n_elements) diff --git a/plugins/Hartree_Fock/damping_SCF.irp.f b/plugins/Hartree_Fock/damping_SCF.irp.f index 6a532b25..aa6f02b0 100644 --- a/plugins/Hartree_Fock/damping_SCF.irp.f +++ b/plugins/Hartree_Fock/damping_SCF.irp.f @@ -96,7 +96,7 @@ subroutine damping_SCF a = (E_new + E - 2.d0*E_half)*2.d0 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_beta = (1.d0-lambda) * D_beta + lambda * D_new_beta 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,*) - 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 ezfio_set_hartree_fock_energy(E_min) diff --git a/plugins/MRCC_CASSD/mrcc_cassd.irp.f b/plugins/MRCC_CASSD/mrcc_cassd.irp.f index 38cd3c55..0d49be89 100644 --- a/plugins/MRCC_CASSD/mrcc_cassd.irp.f +++ b/plugins/MRCC_CASSD/mrcc_cassd.irp.f @@ -65,8 +65,17 @@ subroutine run_pt2(N_st,energy) threshold_selectors = 1.d0 threshold_generators = 0.999d0 - N_det_generators = lambda_mrcc_pt2(0) - do i=1,N_det_generators + 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) do k=1,N_int psi_det_generators(k,1,i) = psi_non_ref(k,1,j) diff --git a/plugins/MRCC_Utils/H_apply.irp.f b/plugins/MRCC_Utils/H_apply.irp.f index 57d6d5c1..0874e584 100644 --- a/plugins/MRCC_Utils/H_apply.irp.f +++ b/plugins/MRCC_Utils/H_apply.irp.f @@ -25,7 +25,7 @@ print s -s = H_apply_zmq("mrcc_PT2") +s = H_apply("mrcc_PT2") s.energy = "ci_electronic_energy_dressed" s.set_perturbation("epstein_nesbet_2x2") s.unset_openmp() diff --git a/plugins/MRCC_Utils/mrcc_utils.irp.f b/plugins/MRCC_Utils/mrcc_utils.irp.f index 513e7d09..315006ff 100644 --- a/plugins/MRCC_Utils/mrcc_utils.irp.f +++ b/plugins/MRCC_Utils/mrcc_utils.irp.f @@ -1,93 +1,11 @@ use bitmasks 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 END_PROVIDER - -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/ 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 [ double precision, lambda_mrcc, (N_states, N_det_non_ref) ] &BEGIN_PROVIDER [ integer, lambda_mrcc_pt2, (0:psi_det_size) ] &BEGIN_PROVIDER [ integer, lambda_mrcc_pt3, (0:psi_det_size) ] implicit none @@ -99,49 +17,41 @@ END_PROVIDER integer :: i_pert_count double precision :: hii, lambda_pert integer :: N_lambda_mrcc_pt2, N_lambda_mrcc_pt3 - integer :: histo(200), j - histo = 0 - if(old_lambda) then - lambda_mrcc = lambda_mrcc_old - lambda_mrcc_pt2 = lambda_mrcc_pt2_old - lambda_mrcc_pt3 = lambda_mrcc_pt3_old - else - 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 + 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 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 + 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(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 - 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 - 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 + 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 - enddo + endif enddo - lambda_mrcc_pt2(0) = N_lambda_mrcc_pt2 - lambda_mrcc_pt3(0) = N_lambda_mrcc_pt3 - end if + enddo + 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)) @@ -149,44 +59,6 @@ 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/ 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) ] @@ -362,16 +234,6 @@ logical function is_generable(det1, det2, Nint) return end if 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) @@ -680,10 +542,10 @@ 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 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(bit_kind) :: myDet(N_int, 2), myMask(N_int, 2) 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 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 print *, "TI", nex, N_det_non_ref 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(A_val_mwen(nex), A_ind_mwen(nex)) 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_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 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) do hh = 1, hh_shortcut(0) - !print *, hh, "/", hh_shortcut(0) do pp = hh_shortcut(hh), hh_shortcut(hh+1)-1 allocate(lref(N_det_non_ref)) lref = 0 @@ -715,12 +591,8 @@ BEGIN_PROVIDER [ double precision, dIj, (hh_shortcut(hh_shortcut(0)+1)-1) ] if(.not. ok) cycle call apply_particle(myMask, pp_exists(1, pp), myDet, ok, N_int) 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) 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 end if 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 if(lref(i) /= 0) then 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 end if end do @@ -744,19 +616,19 @@ BEGIN_PROVIDER [ double precision, dIj, (hh_shortcut(hh_shortcut(0)+1)-1) ] 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 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 wk = 0 if(mod(at_row, 10000) == 0) print *, "AtA", at_row, "/", nex do i=1,N_det_ref 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 do a_col = 1, nex t = 0d0 r1 = 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 r1 += 1 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 if(a_col == at_row) then - t = (t + 1d0)! / 2d0 - !print *, a_col, t-1d0 + t = (t + 1d0) end if if(t /= 0d0) then wk += 1 - !AtA_ind(1, wk) = at_row - !AtA_ind(2, wk) = a_col A_ind_mwen(wk) = a_col - !AtA_val(wk) = t A_val_mwen(wk) = t end if end do @@ -796,7 +664,6 @@ BEGIN_PROVIDER [ double precision, dIj, (hh_shortcut(hh_shortcut(0)+1)-1) ] x = AtB if(AtA_size > size(AtA_val)) stop "SIZA" print *, "ATA SIZE", ata_size - allocate (x_new(nex)) integer :: iproc, omp_get_thread_num iproc = omp_get_thread_num() do i=1,nex @@ -821,7 +688,7 @@ BEGIN_PROVIDER [ double precision, dIj, (hh_shortcut(hh_shortcut(0)+1)-1) ] double precision :: norm_cas norm_cas = 0d0 do i = 1, N_det_ref - norm_cas += psi_ref_coef(i,1)**2 + norm_cas += psi_ref_coef(i,s)**2 end do 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) 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) do j=1, size(X) @@ -858,7 +708,7 @@ BEGIN_PROVIDER [ double precision, dIj, (hh_shortcut(hh_shortcut(0)+1)-1) ] end do - if(mod(k, 50) == 0) then + if(mod(k, 100) == 0) then print *, "residu ", k, norm, "norm t", sqrt(t) end if @@ -866,77 +716,51 @@ BEGIN_PROVIDER [ double precision, dIj, (hh_shortcut(hh_shortcut(0)+1)-1) ] end do print *, "CONVERGENCE : ", norm + dIj_unique(:size(X), s) = X(:) + -!do k=0,500 -! 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 + end 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" END_PROVIDER -double precision function get_dij_index(II, i, Nint) - integer, intent(in) :: II, i, Nint - double precision, external :: get_dij +BEGIN_PROVIDER [ double precision, dij, (N_det_ref, N_det_non_ref, N_states) ] + integer :: s,i,j + 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 - 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 function -double precision function get_dij(det1, det2, Nint) +double precision function get_dij(det1, det2, s, Nint) use bitmasks implicit none - integer, intent(in) :: Nint + integer, intent(in) :: s, Nint integer(bit_kind) :: det1(Nint, 2), det2(Nint, 2) integer :: degree, f, exc(0:2, 2, 2), t integer*2 :: h1, h2, p1, p2, s1, s2 @@ -976,7 +800,7 @@ double precision function get_dij(det1, det2, Nint) end if 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 function diff --git a/plugins/Molden/NEEDED_CHILDREN_MODULES b/plugins/Molden/NEEDED_CHILDREN_MODULES index 305dfb78..80d0af12 100644 --- a/plugins/Molden/NEEDED_CHILDREN_MODULES +++ b/plugins/Molden/NEEDED_CHILDREN_MODULES @@ -1 +1 @@ -MO_Basis Utils +MO_Basis Utils diff --git a/plugins/Molden/aos.irp.f b/plugins/Molden/aos.irp.f deleted file mode 100644 index 71f8c5b8..00000000 --- a/plugins/Molden/aos.irp.f +++ /dev/null @@ -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 diff --git a/plugins/Molden/print_mo.irp.f b/plugins/Molden/print_mo.irp.f index b147fe50..6ac51bdb 100644 --- a/plugins/Molden/print_mo.irp.f +++ b/plugins/Molden/print_mo.irp.f @@ -104,6 +104,8 @@ subroutine write_Ao_basis(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)')'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,*)'' @@ -126,7 +128,9 @@ subroutine write_Mo_basis(i_unit_output) write(i_unit_output,'(18X,F8.5)')-1.d0 write(i_unit_output,*)'' 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)) enddo write(i_unit_output,*)'' diff --git a/plugins/Perturbation/pt2_equations.irp.f b/plugins/Perturbation/pt2_equations.irp.f index e990a37c..e406cd03 100644 --- a/plugins/Perturbation/pt2_equations.irp.f +++ b/plugins/Perturbation/pt2_equations.irp.f @@ -125,6 +125,8 @@ subroutine pt2_moller_plesset ($arguments) delta_e = (Fock_matrix_diag_mo(h1) - Fock_matrix_diag_mo(p1)) + & (Fock_matrix_diag_mo(h2) - Fock_matrix_diag_mo(p2)) delta_e = 1.d0/delta_e +! print*,'h1,p1',h1,p1 +! print*,'h2,p2',h2,p2 else if (degree == 1) then call decode_exc(exc,degree,h1,p1,h2,p2,s1,s2) delta_e = Fock_matrix_diag_mo(h1) - Fock_matrix_diag_mo(p1) diff --git a/plugins/Properties/hyperfine_constants.irp.f b/plugins/Properties/hyperfine_constants.irp.f index c1d88d2c..e31b3ba4 100644 --- a/plugins/Properties/hyperfine_constants.irp.f +++ b/plugins/Properties/hyperfine_constants.irp.f @@ -133,3 +133,16 @@ END_PROVIDER enddo 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 + diff --git a/plugins/Properties/mulliken.irp.f b/plugins/Properties/mulliken.irp.f index d56c9a44..cc0a2f8e 100644 --- a/plugins/Properties/mulliken.irp.f +++ b/plugins/Properties/mulliken.irp.f @@ -105,3 +105,34 @@ END_PROVIDER enddo 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 + diff --git a/plugins/Properties/print_hcc.irp.f b/plugins/Properties/print_hcc.irp.f index f0091e1e..45bca5e6 100644 --- a/plugins/Properties/print_hcc.irp.f +++ b/plugins/Properties/print_hcc.irp.f @@ -1,17 +1,6 @@ -program print_hcc +program print_hcc_main implicit none read_wf = .True. touch read_wf - call test + call print_hcc 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 - diff --git a/plugins/Properties/print_mulliken.irp.f b/plugins/Properties/print_mulliken.irp.f index 100c8556..d4be534a 100644 --- a/plugins/Properties/print_mulliken.irp.f +++ b/plugins/Properties/print_mulliken.irp.f @@ -2,34 +2,5 @@ program print_mulliken implicit none read_wf = .True. touch read_wf - print*,'Mulliken spin densities' - - call test + call print_mulliken_sd 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 - diff --git a/plugins/QmcChem/dressed_dmc.irp.f b/plugins/QmcChem/dressed_dmc.irp.f new file mode 100644 index 00000000..0a48e871 --- /dev/null +++ b/plugins/QmcChem/dressed_dmc.irp.f @@ -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 + ! -=-=-=-==-=-=-= + + 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 diff --git a/plugins/QmcChem/e_curve_qmc.irp.f b/plugins/QmcChem/e_curve_qmc.irp.f new file mode 100644 index 00000000..4beed3fa --- /dev/null +++ b/plugins/QmcChem/e_curve_qmc.irp.f @@ -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 + diff --git a/plugins/QmcChem/save_for_qmcchem.irp.f b/plugins/QmcChem/save_for_qmcchem.irp.f index c8ddb4d9..a281a184 100644 --- a/plugins/QmcChem/save_for_qmcchem.irp.f +++ b/plugins/QmcChem/save_for_qmcchem.irp.f @@ -1,9 +1,46 @@ program save_for_qmc - read_wf = .True. - TOUCH read_wf - print *, "N_det = ", N_det - call write_spindeterminants - if (do_pseudo) then - call write_pseudopotential - endif + + integer :: iunit + integer, external :: get_unit_and_open + logical :: exists + double precision :: e_ref + + ! 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 diff --git a/plugins/loc_cele/loc.f b/plugins/loc_cele/loc.f index 575932a3..edc3aa7a 100644 --- a/plugins/loc_cele/loc.f +++ b/plugins/loc_cele/loc.f @@ -17,9 +17,11 @@ C data small/1.d-6/ zprt=.true. - niter=500 + niter=1000000 conv=1.d-8 +C niter=1000000 +C conv=1.d-6 write (6,5) n,m,conv 5 format (//5x,'Unitary transformation of',i3,' vectors'/ * 5x,'following the principle of maximum overlap with a set of', diff --git a/plugins/loc_cele/loc_cele.irp.f b/plugins/loc_cele/loc_cele.irp.f index e9c26f9d..c9036aa1 100644 --- a/plugins/loc_cele/loc_cele.irp.f +++ b/plugins/loc_cele/loc_cele.irp.f @@ -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) 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 ! irot(2,1) = 21 ! the first mo to be rotated is the 21 th MO @@ -106,25 +275,67 @@ ! irot(4,1) = 23 ! ! irot(5,1) = 24 ! ! irot(6,1) = 25 ! -! do i = 1,12 -! irot(i,1) = i+6 -! enddo - irot(1,1) = 5 - irot(2,1) = 6 - irot(3,1) = 7 - irot(4,1) = 8 - irot(5,1) = 9 - irot(6,1) = 10 + +!N2 +! irot(1,1) = 5 +! irot(2,1) = 6 +! irot(3,1) = 7 +! irot(4,1) = 8 +! irot(5,1) = 9 +! 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) print*,'irot(i,1) = ',irot(i,1) enddo - 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 +! pause ! you define the guess vectors that you want ! the new MO to be close to @@ -138,233 +349,21 @@ ! own guess vectors for the MOs ! The new MOs are provided in output ! in the same order than the guess MOs - - ! C-C bonds - ! 1-2 -! i_atom = 1 -! 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 - -! 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 ! +! do i = 1, nrot(1) +! j = 5+(i-1)*15 +! cmoref(j,i,1) = 0.2d0 +! cmoref(j+3,i,1) = 0.12d0 +! print*,'j = ',j +! enddo +! pause print*,'passed the definition of the referent vectors ' - !Building the S (overlap) matrix in the AO basis. - - - do i = 1, ao_num - do j = 1, ao_num - s(i,j,1) = ao_overlap(i,j) + do j =1, ao_num + s(i,j,1) = ao_overlap(i,j) enddo enddo !Now big loop over symmetry @@ -398,20 +397,13 @@ ! do i=1,nmo(isym) - do i=1,ao_num - do j=1,nrot(isym) - - ddum(i,j)=0.d0 - - do k=1,ao_num - - ddum(i,j)=ddum(i,j)+s(i,k,isym)*cmo(k,irot(j,isym),isym) - - enddo - - enddo - + do i=1,ao_num + ddum(i,j)=0.d0 + do k=1,ao_num + ddum(i,j)=ddum(i,j)+s(i,k,isym)*cmo(k,irot(j,isym),isym) + enddo + enddo enddo @@ -441,7 +433,7 @@ do i=1,nrot(isym) 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 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) @@ -459,7 +451,7 @@ enddo !big loop over symmetry - 10 format (4E20.12) + 10 format (4E18.12) ! Now we copyt the newcmo into the mo_coef @@ -472,9 +464,7 @@ enddo enddo enddo -! if(dabs(newcmo(3,19,1) - mo_coef(3,19)) .gt.1.d-10 )then - print*,'mo_coef(3,19)',mo_coef(3,19) - pause +! pause ! we say that it hase been touched, and valid and that everything that diff --git a/plugins/mrcepa0/EZFIO.cfg b/plugins/mrcepa0/EZFIO.cfg new file mode 100644 index 00000000..9979f537 --- /dev/null +++ b/plugins/mrcepa0/EZFIO.cfg @@ -0,0 +1,5 @@ +[lambda_type] +type: Strictly_positive_int +doc: lambda type ( 0 = none, 1 = last version ) +interface: ezfio,provider,ocaml +default: 0 diff --git a/plugins/mrcepa0/dressing.irp.f b/plugins/mrcepa0/dressing.irp.f index e4b63208..3a91f42e 100644 --- a/plugins/mrcepa0/dressing.irp.f +++ b/plugins/mrcepa0/dressing.irp.f @@ -6,7 +6,7 @@ use bitmasks &BEGIN_PROVIDER [ double precision, delta_ii_mrcc, (N_states, N_det_ref) ] use bitmasks 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),allocatable :: buf(:,:,:) logical :: ok @@ -14,16 +14,16 @@ use bitmasks delta_ij_mrcc = 0d0 delta_ii_mrcc = 0d0 - i_state = 1 + print *, "Dij", dij(1,1,1) provide hh_shortcut psi_det_size! lambda_mrcc !$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(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) do gen= 1, N_det_generators allocate(buf(N_int, 2, N_det_non_ref)) 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) call apply_hole(psi_det_generators(1,1,gen), hh_exists(1, h), mask, ok, N_int) if(.not. ok) cycle @@ -36,7 +36,9 @@ use bitmasks if(n > N_det_non_ref) stop "MRCC..." end do n = n - 1 + if(n /= 0) call mrcc_part_dress(delta_ij_mrcc, delta_ii_mrcc,gen,n,buf,N_int,omask) + end do deallocate(buf) 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 :: mobiles(2), smallerlist 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) 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)) end do - else call get_excitation_degree_vector(miniList,tq(1,1,i_alpha),degree_alpha,Nint,N_minilist,idx_alpha) 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) call i_h_j(tq(1,1,i_alpha),psi_non_ref(1,1,idx_alpha(l_sd)),Nint,hij_cache(k_sd)) enddo - ! |I> do i_I=1,N_det_ref ! Find triples and quadruple grand parents @@ -199,7 +200,6 @@ subroutine mrcc_part_dress(delta_ij_, delta_ii_,i_generator,n_selected,det_buffe ! |alpha> do k_sd=1,idx_alpha(0) - ! Loop if lambda == 0 logical :: loop ! loop = .True. @@ -220,18 +220,16 @@ subroutine mrcc_part_dress(delta_ij_, delta_ii_,i_generator,n_selected,det_buffe ! ! - 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) - 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) = psi_non_ref_coef(idx_alpha(k_sd), i_state) / psi_ref_coef(i_I, i_state) enddo - ! |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 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,2) = psi_ref(k,2,i_I) enddo - logical :: ok call apply_excitation(psi_ref(1,1,i_I), exc, tmp_det, ok, Nint) 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 enddo 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) 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) ! 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 - 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) = psi_non_ref_coef(idx_alpha(l_sd), i_state) / psi_ref_coef(i_I, i_state) * phase * phase2 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) enddo enddo - + do i_state=1,N_states ci_inv(i_state) = psi_ref_coef_inv(i_I,i_state) enddo @@ -292,7 +288,6 @@ subroutine mrcc_part_dress(delta_ij_, delta_ii_,i_generator,n_selected,det_buffe enddo enddo call omp_set_lock( psi_ref_lock(i_I) ) - do i_state=1,N_states if(dabs(psi_ref_coef(i_I,i_state)).ge.5.d-5)then do l_sd=1,idx_alpha(0) @@ -546,12 +541,12 @@ END_PROVIDER implicit none integer :: i,j,k double precision :: Hjk, Hki, Hij - double precision, external :: get_dij + !double precision, external :: get_dij integer i_state, degree provide lambda_mrcc dIj 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 j=1,i 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_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) end do delta_cas(j,i,i_state) = delta_cas(i,j,i_state) @@ -659,7 +654,7 @@ end function integer, allocatable :: idx_sorted_bit(:) integer, external :: get_index_in_psi_det_sorted_bit, searchDet logical, external :: is_in_wavefunction, detEq - double precision, external :: get_dij + !double precision, external :: get_dij integer :: II, blok integer*8, save :: notf = 0 @@ -675,7 +670,7 @@ end function enddo ! 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 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 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(notf,i_state, sortRef, sortRefIdx) + !$OMP shared(notf,i_state, sortRef, sortRefIdx, dij) do blok=1,cepa0_shortcut(0) do i=cepa0_shortcut(blok), cepa0_shortcut(blok+1)-1 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) !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 delta_mrcepa0_ij(J, det_cepa0_idx(i), i_state) += contrib diff --git a/plugins/mrcepa0/dressing_slave.irp.f b/plugins/mrcepa0/dressing_slave.irp.f index 9e8ff0ce..f1d6f029 100644 --- a/plugins/mrcepa0/dressing_slave.irp.f +++ b/plugins/mrcepa0/dressing_slave.irp.f @@ -55,7 +55,7 @@ subroutine mrsc2_dressing_slave(thread,iproc) logical, external :: is_in_wavefunction, isInCassd, detEq integer,allocatable :: komon(:) logical :: komoned - double precision, external :: get_dij + !double precision, external :: get_dij zmq_to_qp_run_socket = new_zmq_to_qp_run_socket() 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 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) dleat(i_state, kn, 1) = 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 = 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 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) @@ -182,7 +182,7 @@ subroutine mrsc2_dressing_slave(thread,iproc) if(I_i == J) cycle !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 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) diff --git a/plugins/mrcepa0/mrcepa0_general.irp.f b/plugins/mrcepa0/mrcepa0_general.irp.f index 0ef4c92b..53a0822d 100644 --- a/plugins/mrcepa0/mrcepa0_general.irp.f +++ b/plugins/mrcepa0/mrcepa0_general.irp.f @@ -16,10 +16,11 @@ subroutine run(N_st,energy) double precision :: thresh_mrcc + thresh_mrcc = 1d-7 n_it_mrcc_max = 10 - if(no_mono_dressing) then + if(n_it_mrcc_max == 1) then do j=1,N_states_diag do i=1,N_det 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' threshold_selectors = 1.d0 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_selectors = lambda_mrcc_pt3(0) + N_det_ref diff --git a/plugins/qmcpack/qp_convert_qmcpack_to_ezfio.py b/plugins/qmcpack/qp_convert_qmcpack_to_ezfio.py index 0dc99029..e911af28 100755 --- a/plugins/qmcpack/qp_convert_qmcpack_to_ezfio.py +++ b/plugins/qmcpack/qp_convert_qmcpack_to_ezfio.py @@ -183,6 +183,9 @@ def get_nb_permutation(str_): def order_l_l_sym(l_l_sym): + + l_order_mo = [i for i,_ in enumerate(l_l_sym)] + n = 1 for i in range(len(l_l_sym)): if n != 1: @@ -192,11 +195,11 @@ def order_l_l_sym(l_l_sym): l = l_l_sym[i] n = get_nb_permutation(l[2]) - l_l_sym[i:i + n] = sorted(l_l_sym[i:i + n], - key=lambda x: x[2], - cmp=compare_gamess_style) + 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[0][2], + 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_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_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 @@ -256,7 +264,7 @@ def print_mo_coef(mo_coef_block, l_l_sym): i_a = int(l[1]) - 1 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]) if i_block != nb_block - 1: @@ -348,6 +356,7 @@ d_rep={"+":"1","-":"0"} det_without_header = det_raw[pos+2::] + for line_raw in det_without_header.split("\n"): line = line_raw @@ -355,8 +364,14 @@ for line_raw in det_without_header.split("\n"): try: float(line) 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]) print line.strip() print "END_DET" + diff --git a/scripts/compilation/qp_create_ninja.py b/scripts/compilation/qp_create_ninja.py index adcfb6f7..cc1c8aa8 100755 --- a/scripts/compilation/qp_create_ninja.py +++ b/scripts/compilation/qp_create_ninja.py @@ -37,7 +37,7 @@ from qp_path import QP_ROOT, QP_SRC, QP_EZFIO LIB = "" # join(QP_ROOT, "lib", "rdtsc.o") 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") header = r"""# @@ -96,7 +96,8 @@ def ninja_create_env_variable(pwd_config_file): l_string.append(str_) 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("") @@ -387,6 +388,8 @@ def get_l_file_for_module(path_module): l_src.append(f) obj = '{0}.o'.format(os.path.splitext(f)[0]) l_obj.append(obj) + elif f.lower().endswith(".o"): + l_obj.append(join(path_module.abs, f)) elif f == "EZFIO.cfg": l_depend.append(join(path_module.abs, "ezfio_interface.irp.f")) diff --git a/scripts/ezfio_interface/ei_handler.py b/scripts/ezfio_interface/ei_handler.py index a3f3600b..d7cd9c95 100755 --- a/scripts/ezfio_interface/ei_handler.py +++ b/scripts/ezfio_interface/ei_handler.py @@ -345,7 +345,7 @@ def save_ezfio_provider(path_head, dict_code_provider): path = "{0}/ezfio_interface.irp.f".format(path_head) 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), "\n"] diff --git a/scripts/ezfio_interface/ezfio_generate_provider.py b/scripts/ezfio_interface/ezfio_generate_provider.py index 6cd919dc..89fdfa03 100755 --- a/scripts/ezfio_interface/ezfio_generate_provider.py +++ b/scripts/ezfio_interface/ezfio_generate_provider.py @@ -22,6 +22,7 @@ BEGIN_PROVIDER [ %(type)s, %(name)s %(size)s ] logical :: has PROVIDE ezfio_filename + %(test_null_size)s call ezfio_has_%(ezfio_dir)s_%(ezfio_name)s(has) if (has) then call ezfio_get_%(ezfio_dir)s_%(ezfio_name)s(%(name)s) @@ -44,6 +45,7 @@ END_PROVIDER def __repr__(self): self.set_write() + self.set_test_null_size() for v in self.values: if not v: msg = "Error : %s is not set in EZFIO.cfg" % (v) @@ -54,20 +56,31 @@ END_PROVIDER 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): self.write = "" - if self.type in self.write_correspondance: - write = self.write_correspondance[self.type] - output = self.output - name = self.name + if "size" in self.__dict__: + return + else: + if self.type in self.write_correspondance: + write = self.write_correspondance[self.type] + output = self.output + name = self.name - l_write = ["", - " call write_time(%(output)s)", - " call %(write)s(%(output)s, %(name)s, &", - " '%(name)s')", - ""] + l_write = ["", + " call write_time(%(output)s)", + " call %(write)s(%(output)s, %(name)s, &", + " '%(name)s')", + ""] - self.write = "\n".join(l_write) % locals() + self.write = "\n".join(l_write) % locals() def set_type(self, t): self.type = t.lower() diff --git a/scripts/ezfio_interface/qp_edit_template b/scripts/ezfio_interface/qp_edit_template index 408ca3f7..9c7a1386 100644 --- a/scripts/ezfio_interface/qp_edit_template +++ b/scripts/ezfio_interface/qp_edit_template @@ -6,7 +6,7 @@ open Core.Std;; WARNING 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 | Ao_basis -> () (* TODO *) | Mo_basis -> () (* TODO *) - end + end ;; @@ -169,7 +169,9 @@ let run check_only ezfio_filename = in (* 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 *) let editor = @@ -193,7 +195,7 @@ let run check_only ezfio_filename = List.iter ~f:(fun x -> set temp_string x) tasks; (* Remove temp_file *) - Sys.remove temp_filename; + Sys.remove temp_filename ;; diff --git a/scripts/generate_h_apply.py b/scripts/generate_h_apply.py index 436f092d..ae0064cf 100755 --- a/scripts/generate_h_apply.py +++ b/scripts/generate_h_apply.py @@ -8,11 +8,22 @@ copy_buffer declarations decls_main deinit_thread -do_double_excitations +skip +init_main +filter_integrals +filter2p +filter2h2p_double +filter2h2p_single filter1h filter1p -filter2h2p -filter2p +only_2p_single +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 filter_integrals filter_only_1h1p_double @@ -182,7 +193,7 @@ class H_apply(object): if (is_a_2p(hole)) cycle """ def filter_1p(self): - self["filter0p"] = """ + self["filter1p"] = """ ! ! DIR$ FORCEINLINE if (is_a_1p(hole)) cycle """ @@ -208,6 +219,27 @@ class H_apply(object): 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): self["skip"] = """ @@ -215,9 +247,12 @@ class H_apply(object): def set_filter_2h_2p(self): - self["filter2h2p"] = """ + self["filter2h2p_double"] = """ 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): @@ -248,13 +283,13 @@ class H_apply(object): """ self.data["deinit_thread"] = """ - !$ call omp_set_lock(lck) + ! OMP CRITICAL do k=1,N_st 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_H_pert_diag_in(k) = sum_H_pert_diag_in(k) + sum_H_pert_diag(k) enddo - !$ call omp_unset_lock(lck) + ! OMP END CRITICAL deallocate (e_2_pert_buffer, coef_pert_buffer) """ self.data["size_max"] = "8192" @@ -356,12 +391,12 @@ class H_apply(object): self.data["skip"] = """ if (i_generator < size_select_max) 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 norm_psi(k) = norm_psi(k) + psi_coef_generators(i_generator,k)*psi_coef_generators(i_generator,k) pt2_old(k) = 0.d0 enddo - !$ call omp_unset_lock(lck) + ! OMP END CRITICAL cycle endif select_max(i_generator) = 0.d0 @@ -401,7 +436,16 @@ class H_apply_zmq(H_apply): H_pert_diag(k) = 0.d0 norm_psi(k) = 0.d0 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): H_apply.set_selection_pt2(self,pert) @@ -416,3 +460,4 @@ class H_apply_zmq(H_apply): select_max(i_generator) = 0.d0 endif """ + diff --git a/src/AO_Basis/aos.irp.f b/src/AO_Basis/aos.irp.f index aa805093..8d420b15 100644 --- a/src/AO_Basis/aos.irp.f +++ b/src/AO_Basis/aos.irp.f @@ -25,7 +25,7 @@ END_PROVIDER BEGIN_DOC ! Coefficients including the AO normalization 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 :: i,j,k nz=100 @@ -34,9 +34,11 @@ END_PROVIDER C_A(3) = 0.d0 ao_coef_normalized = 0.d0 do i=1,ao_num + powA(1) = ao_power(i,1) powA(2) = ao_power(i,2) powA(3) = ao_power(i,3) + 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) ao_coef_normalized(i,j) = ao_coef(i,j)/sqrt(norm) @@ -51,8 +53,42 @@ END_PROVIDER enddo ao_coef_normalization_factor(i) = 1.d0/sqrt(norm) enddo + 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_expo_ordered, (ao_num_align,ao_prim_num_max) ] implicit none @@ -170,3 +206,176 @@ BEGIN_PROVIDER [ character*(128), l_to_charater, (0:4)] l_to_charater(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 diff --git a/src/Bitmask/bitmask_cas_routines.irp.f b/src/Bitmask/bitmask_cas_routines.irp.f index 4441fb22..4984d9a8 100644 --- a/src/Bitmask/bitmask_cas_routines.irp.f +++ b/src/Bitmask/bitmask_cas_routines.irp.f @@ -212,6 +212,12 @@ logical function is_a_two_holes_two_particles(key_in) implicit none integer(bit_kind), intent(in) :: key_in(N_int,2) 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 if(N_int == 1)then i_diff = i_diff & @@ -456,6 +462,17 @@ logical function is_a_1h1p(key_in) 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) implicit none integer(bit_kind), intent(in) :: key_in(N_int,2) diff --git a/src/Bitmask/bitmasks.irp.f b/src/Bitmask/bitmasks.irp.f index 6fe36c57..7bb6e16e 100644 --- a/src/Bitmask/bitmasks.irp.f +++ b/src/Bitmask/bitmasks.irp.f @@ -95,9 +95,40 @@ BEGIN_PROVIDER [ integer, N_generators_bitmask ] 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 BEGIN_DOC ! Bitmasks for generator determinants. @@ -306,7 +337,7 @@ END_PROVIDER n_inact_orb = 0 n_virt_orb = 0 - if(N_generators_bitmask == 1)then + if(N_generators_bitmask_restart == 1)then 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,2) = xor(generators_bitmask_restart(j,2,1,1),cas_bitmask(j,2,1)) @@ -319,15 +350,15 @@ END_PROVIDER i_hole = 1 i_gen = 1 do i = 1, N_int - inact_bitmask(i,1) = generators_bitmask(i,1,i_hole,i_gen) - inact_bitmask(i,2) = generators_bitmask(i,2,i_hole,i_gen) + inact_bitmask(i,1) = generators_bitmask_restart(i,1,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)) enddo i_part = 2 i_gen = 3 do i = 1, N_int - virt_bitmask(i,1) = generators_bitmask(i,1,i_part,i_gen) - virt_bitmask(i,2) = generators_bitmask(i,2,i_part,i_gen) + virt_bitmask(i,1) = generators_bitmask_restart(i,1,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)) enddo endif diff --git a/src/Determinants/H_apply.irp.f b/src/Determinants/H_apply.irp.f index e5490e69..b047efdc 100644 --- a/src/Determinants/H_apply.irp.f +++ b/src/Determinants/H_apply.irp.f @@ -214,8 +214,13 @@ subroutine remove_duplicates_in_psi_det(found_duplicates) duplicate(i) = .False. enddo - do i=1,N_det-1 + found_duplicates = .False. + i=0 + j=0 + do while (i 2.d0) then $printout_now wall_0 = wall_1 endif - !$ call omp_unset_lock(lck) + !$OMP END CRITICAL enddo !$OMP END DO deallocate( mask, fock_diag_tmp ) !$OMP END PARALLEL - !$ call omp_destroy_lock(lck) $copy_buffer $generate_psi_guess diff --git a/src/Determinants/H_apply_zmq.template.f b/src/Determinants/H_apply_zmq.template.f index c492a739..fde09a8f 100644 --- a/src/Determinants/H_apply_zmq.template.f +++ b/src/Determinants/H_apply_zmq.template.f @@ -10,9 +10,9 @@ subroutine $subroutine($params_main) $decls_main + integer :: i integer :: i_generator double precision :: wall_0, wall_1 - integer(omp_lock_kind) :: lck integer(bit_kind), allocatable :: mask(:,:,:) integer :: ispin, k integer :: rc @@ -26,6 +26,9 @@ subroutine $subroutine($params_main) integer(ZMQ_PTR) :: zmq_socket_pair 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') 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) enddo - integer(ZMQ_PTR) :: collector_thread - external :: $subroutine_collector - rc = pthread_create(collector_thread, $subroutine_collector) + allocate ( pt2_generators(N_states,N_det_generators), & + norm_pert_generators(N_states,N_det_generators), & + H_pert_diag_generators(N_states,N_det_generators) ) - !$OMP PARALLEL DEFAULT(private) - !$OMP TASK PRIVATE(rc) - rc = omp_get_thread_num() - call $subroutine_slave_inproc(rc) - !$OMP END TASK - !$OMP TASKWAIT + PROVIDE nproc N_states + !$OMP PARALLEL DEFAULT(NONE) & + !$OMP PRIVATE(i) & + !$OMP SHARED(zmq_socket_pair,N_states, pt2_generators, norm_pert_generators, H_pert_diag_generators, n, task_id, i_generator) & + !$OMP num_threads(nproc+1) + 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 - 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_parallel_job(zmq_to_qp_run_socket,'$subroutine') @@ -62,6 +67,7 @@ subroutine $subroutine($params_main) $copy_buffer $generate_psi_guess + deallocate ( pt2_generators, norm_pert_generators, H_pert_diag_generators) end subroutine $subroutine_slave_tcp(iproc) @@ -168,8 +174,8 @@ subroutine $subroutine_slave(thread, iproc) fock_diag_tmp, i_generator, iproc $params_post) endif - call task_done_to_taskserver(zmq_to_qp_run_socket,worker_id,task_id,1) - call push_pt2(zmq_socket_push,pt2,norm_pert,H_pert_diag,N_st,task_id) + 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,i_generator,N_st,task_id) enddo @@ -186,7 +192,7 @@ subroutine $subroutine_collector use f77_zmq implicit none BEGIN_DOC -! Collects results from the selection +! Collects results from the selection in an array of generators END_DOC integer :: k, rc @@ -194,7 +200,7 @@ subroutine $subroutine_collector integer(ZMQ_PTR), external :: new_zmq_pull_socket integer(ZMQ_PTR) :: zmq_socket_pull 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) :: zmq_to_qp_run_socket @@ -202,22 +208,25 @@ subroutine $subroutine_collector zmq_to_qp_run_socket = new_zmq_to_qp_run_socket() zmq_socket_pull = new_zmq_pull_socket() - 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(:), norm_pert(:), H_pert_diag(:) + 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 - norm_pert = 0.d0 - H_pert_diag = 0.d0 + pt2_result = 0.d0 + norm_pert_result = 0.d0 + H_pert_diag_result = 0.d0 accu = 0_8 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 do k=1,N_states - pt2(k,2) = pt2(k,1) + pt2(k,2) - norm_pert(k,2) = norm_pert(k,1) + norm_pert(k,2) - H_pert_diag(k,2) = H_pert_diag(k,1) + H_pert_diag(k,2) + pt2_result(k,i_generator) = pt2(k) + norm_pert_result(k,i_generator) = norm_pert(k) + H_pert_diag_result(k,i_generator) = H_pert_diag(k) enddo accu = accu + 1_8 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.) - 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) diff --git a/src/Determinants/SC2.irp.f b/src/Determinants/SC2.irp.f index ea942307..4f321b87 100644 --- a/src/Determinants/SC2.irp.f +++ b/src/Determinants/SC2.irp.f @@ -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 implicit none 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) double precision, intent(inout) :: u_in(dim_in,N_st) double precision, intent(out) :: energies(N_st) + double precision, intent(out) :: diag_H_elements(dim_in) double precision, intent(in) :: convergence ASSERT (N_st > 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 = converged if (converged) then + do i = 1, dim_in + diag_H_elements(i) = H_jj_dressed(i) - H_jj_ref(i) + enddo exit endif e_corr_double_before = e_corr_double diff --git a/src/Determinants/davidson.irp.f b/src/Determinants/davidson.irp.f index 3d074563..e7480ca2 100644 --- a/src/Determinants/davidson.irp.f +++ b/src/Determinants/davidson.irp.f @@ -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 - 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 + if (N_st > 1) then - 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 ! =================== @@ -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 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 !$OMP DO do i=1,sze U(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 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) W(i,k,iter+1) = W(i,k,iter+1) + W(i,l,iter2)*y(l,iter2,k,1) enddo + !$OMP END DO NOWAIT 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 R(i,k) = lambda(k) * U(i,k,iter+1) - W(i,k,iter+1) enddo + !$OMP END DO + !$OMP SINGLE residual_norm(k) = u_dot_u(R(1,k),sze) to_print(1,k) = lambda(k) + nuclear_repulsion to_print(2,k) = residual_norm(k) + !$OMP END SINGLE enddo + !$OMP END PARALLEL 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) diff --git a/src/Determinants/determinants.irp.f b/src/Determinants/determinants.irp.f index 609379f2..63617352 100644 --- a/src/Determinants/determinants.irp.f +++ b/src/Determinants/determinants.irp.f @@ -58,7 +58,7 @@ BEGIN_PROVIDER [ integer, psi_det_size ] else psi_det_size = 1 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') END_PROVIDER diff --git a/src/Determinants/diagonalize_CI.irp.f b/src/Determinants/diagonalize_CI.irp.f index b533bed2..d4716b86 100644 --- a/src/Determinants/diagonalize_CI.irp.f +++ b/src/Determinants/diagonalize_CI.irp.f @@ -36,225 +36,223 @@ END_PROVIDER 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_s2, (N_states_diag) ] - BEGIN_DOC - ! Eigenvectors/values of the CI matrix - END_DOC - implicit none - double precision :: ovrlp,u_dot_v - integer :: i_good_state - integer, allocatable :: index_good_state_array(:) - logical, allocatable :: good_state_array(:) - double precision, allocatable :: s2_values_tmp(:) - integer :: i_other_state - double precision, allocatable :: eigenvectors(:,:), eigenvalues(:) - integer :: i_state - double precision :: s2,e_0 - integer :: i,j,k - double precision, allocatable :: s2_eigvalues(:) - double precision, allocatable :: e_array(:) - integer, allocatable :: iorder(:) - - ! Guess values for the "N_states_diag" states of the CI_eigenvectors - do j=1,min(N_states_diag,N_det) - do i=1,N_det - CI_eigenvectors(i,j) = psi_coef(i,j) - enddo - enddo - - do j=N_det+1,N_states_diag - do i=1,N_det - CI_eigenvectors(i,j) = 0.d0 - enddo - enddo - - if (diag_algorithm == "Davidson") then - - call davidson_diag(psi_det,CI_eigenvectors,CI_electronic_energy, & - size(CI_eigenvectors,1),N_det,N_states_diag,N_int,output_determinants) - 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)) - enddo - - - else if (diag_algorithm == "Lapack") then - - allocate (eigenvectors(size(H_matrix_all_dets,1),N_det)) - allocate (eigenvalues(N_det)) - call lapack_diag(eigenvalues,eigenvectors, & - H_matrix_all_dets,size(H_matrix_all_dets,1),N_det) - CI_electronic_energy(:) = 0.d0 - if (s2_eig) then - i_state = 0 - allocate (s2_eigvalues(N_det)) - allocate(index_good_state_array(N_det),good_state_array(N_det)) - good_state_array = .False. - do j=1,N_det - call get_s2_u0(psi_det,eigenvectors(1,j),N_det,size(eigenvectors,1),s2) - s2_eigvalues(j) = s2 - ! Select at least n_states states with S^2 values closed to "expected_s2" - if(dabs(s2-expected_s2).le.0.3d0)then - i_state +=1 - index_good_state_array(i_state) = j - good_state_array(j) = .True. - endif - if(i_state.eq.N_states) then - exit - 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)) + BEGIN_DOC + ! Eigenvectors/values of the CI matrix + END_DOC + implicit none + double precision :: ovrlp,u_dot_v + integer :: i_good_state + integer, allocatable :: index_good_state_array(:) + logical, allocatable :: good_state_array(:) + double precision, allocatable :: s2_values_tmp(:) + integer :: i_other_state + double precision, allocatable :: eigenvectors(:,:), eigenvalues(:) + integer :: i_state + double precision :: s2,e_0 + integer :: i,j,k + double precision, allocatable :: s2_eigvalues(:) + double precision, allocatable :: e_array(:) + integer, allocatable :: iorder(:) + + ! Guess values for the "N_states_diag" states of the CI_eigenvectors + do j=1,min(N_states_diag,N_det) + do i=1,N_det + CI_eigenvectors(i,j) = psi_coef(i,j) + enddo + enddo + + do j=N_det+1,N_states_diag + do i=1,N_det + CI_eigenvectors(i,j) = 0.d0 + enddo + enddo + + if (diag_algorithm == "Davidson") then + + call davidson_diag(psi_det,CI_eigenvectors,CI_electronic_energy,& + size(CI_eigenvectors,1),N_det,N_states_diag,N_int,output_determinants) + 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)) + enddo + + + else if (diag_algorithm == "Lapack") then + + allocate (eigenvectors(size(H_matrix_all_dets,1),N_det)) + allocate (eigenvalues(N_det)) + call lapack_diag(eigenvalues,eigenvectors, & + H_matrix_all_dets,size(H_matrix_all_dets,1),N_det) + CI_electronic_energy(:) = 0.d0 + if (s2_eig) then + i_state = 0 + allocate (s2_eigvalues(N_det)) + allocate(index_good_state_array(N_det),good_state_array(N_det)) + good_state_array = .False. + do j=1,N_det + call get_s2_u0(psi_det,eigenvectors(1,j),N_det,size(eigenvectors,1),s2) + s2_eigvalues(j) = s2 + ! Select at least n_states states with S^2 values closed to "expected_s2" + if(dabs(s2-expected_s2).le.0.3d0)then + i_state +=1 + index_good_state_array(i_state) = j + good_state_array(j) = .True. + endif + if(i_state.eq.N_states) then + exit + endif enddo - i_other_state = 0 - do j = 1, N_det - if(good_state_array(j))cycle - i_other_state +=1 - 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 - + 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 + i_other_state = 0 + do j = 1, N_det + if(good_state_array(j))cycle + i_other_state +=1 + 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) - - 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) + 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_eigvalues(j) + CI_electronic_energy(j) = eigenvalues(j) + CI_eigenvectors_s2(j) = s2 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 - 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_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*,'= ',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) + deallocate(eigenvectors,eigenvalues) 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_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*,'= ',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 - + subroutine diagonalize_CI implicit none BEGIN_DOC diff --git a/src/Determinants/diagonalize_CI_SC2.irp.f b/src/Determinants/diagonalize_CI_SC2.irp.f index 97161ad3..498792d9 100644 --- a/src/Determinants/diagonalize_CI_SC2.irp.f +++ b/src/Determinants/diagonalize_CI_SC2.irp.f @@ -23,8 +23,10 @@ END_PROVIDER threshold_convergence_SC2 = 1.d-10 END_PROVIDER + 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, Diag_H_elements_SC2, (N_det) ] implicit none BEGIN_DOC ! Eigenvectors/values of the CI matrix @@ -39,7 +41,8 @@ END_PROVIDER enddo 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 subroutine diagonalize_CI_SC2 @@ -54,5 +57,6 @@ subroutine diagonalize_CI_SC2 psi_coef(i,j) = CI_SC2_eigenvectors(i,j) 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 diff --git a/src/Determinants/filter_connected.irp.f b/src/Determinants/filter_connected.irp.f index 46280b31..8bd0f1f2 100644 --- a/src/Determinants/filter_connected.irp.f +++ b/src/Determinants/filter_connected.irp.f @@ -207,6 +207,7 @@ subroutine create_microlist(minilist, N_minilist, key_mask, microlist, idx_micro do j=1,n_element(1) nt = list(j,1) idx_microlist(cur_microlist(nt)) = i + ! TODO : Page faults do k=1,Nint microlist(k,1,cur_microlist(nt)) = minilist(k,1,i) microlist(k,2,cur_microlist(nt)) = minilist(k,2,i) diff --git a/src/Determinants/s2.irp.f b/src/Determinants/s2.irp.f index 9810b219..9a60dbd9 100644 --- a/src/Determinants/s2.irp.f +++ b/src/Determinants/s2.irp.f @@ -301,13 +301,21 @@ subroutine diagonalize_s2_betweenstates(keys_tmp,psi_coefs_inout,n,nmax_keys,nma print*,'' print*,'nstates = ',nstates allocate(s2(nstates,nstates),overlap(nstates,nstates)) - do i = 1, nstates - overlap(i,i) = u_dot_u(psi_coefs_inout(1,i),n) - do j = i+1, nstates - overlap(i,j) = u_dot_v(psi_coefs_inout(1,j),psi_coefs_inout(1,i),n) - overlap(j,i) = overlap(i,j) - enddo - enddo + !$OMP PARALLEL DO COLLAPSE(2) DEFAULT(NONE) SCHEDULE(dynamic) & + !$OMP PRIVATE(i,j) SHARED(overlap,psi_coefs_inout,nstates,n) + do i = 1, nstates + do j = 1, nstates + if (i < j) then + cycle + 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' do i = 1, nstates 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) print*,'passed ortho' - do i = 1, nstates - overlap(i,i) = u_dot_u(psi_coefs_inout(1,i),n) - do j = i+1, nstates - overlap(i,j) = u_dot_v(psi_coefs_inout(1,j),psi_coefs_inout(1,i),n) - overlap(j,i) = overlap(i,j) - enddo - enddo + !$OMP PARALLEL DO COLLAPSE(2) DEFAULT(NONE) SCHEDULE(dynamic) & + !$OMP PRIVATE(i,j) SHARED(overlap,psi_coefs_inout,nstates,n) + do i = 1, nstates + do j = 1, nstates + if (i < j) then + cycle + 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 ' do i = 1, nstates write(*,'(10(F16.10,X))')overlap(i,:) diff --git a/src/Determinants/save_natorb.irp.f b/src/Determinants/save_natorb.irp.f index e56f9821..674ba32e 100644 --- a/src/Determinants/save_natorb.irp.f +++ b/src/Determinants/save_natorb.irp.f @@ -2,5 +2,6 @@ program save_natorb read_wf = .True. touch read_wf call save_natural_mos + call save_ref_determinant end diff --git a/src/Determinants/slater_rules.irp.f b/src/Determinants/slater_rules.irp.f index 3374dfb2..133d9e52 100644 --- a/src/Determinants/slater_rules.irp.f +++ b/src/Determinants/slater_rules.irp.f @@ -970,12 +970,13 @@ subroutine create_minilist_find_previous(key_mask, fullList, miniList, N_fullLis integer, intent(in) :: Nint integer(bit_kind), intent(in) :: fullList(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 integer,intent(out) :: N_miniList integer(bit_kind) :: key_mask(Nint, 2) integer :: ni, i, k, l, N_subList + allocate (subList(Nint, 2, N_fullList)) fullMatch = .false. N_miniList = 0 @@ -1032,6 +1033,8 @@ subroutine create_minilist_find_previous(key_mask, fullList, miniList, N_fullLis enddo N_minilist = N_minilist + N_subList end if + + deallocate(sublist) 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)) !DIR$ FORCEINLINE 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 enddo diff --git a/src/Integrals_Bielec/ao_bi_integrals.irp.f b/src/Integrals_Bielec/ao_bi_integrals.irp.f index eb443701..2c46d42d 100644 --- a/src/Integrals_Bielec/ao_bi_integrals.irp.f +++ b/src/Integrals_Bielec/ao_bi_integrals.irp.f @@ -4,6 +4,7 @@ double precision function ao_bielec_integral(i,j,k,l) ! integral of the AO basis or (ij|kl) ! i(r1) j(r1) 1/r12 k(r2) l(r2) END_DOC + integer,intent(in) :: i,j,k,l integer :: p,q,r,s 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 if (read_ao_integrals) then - integer :: load_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' ao_bielec_integrals_in_map = .True. return - endif endif 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') do l=1,ao_num - write(task,*) l + write(task,*) "triangle ", l call add_task_to_taskserver(zmq_to_qp_run_socket,task) enddo - integer(ZMQ_PTR) :: collector_thread - external :: ao_bielec_integrals_in_map_collector - rc = pthread_create(collector_thread, ao_bielec_integrals_in_map_collector) - - !$OMP PARALLEL DEFAULT(private) - !$OMP TASK PRIVATE(i) + PROVIDE nproc + !$OMP PARALLEL DEFAULT(private) num_threads(nproc+1) i = omp_get_thread_num() - call ao_bielec_integrals_in_map_slave_inproc(i) - !$OMP END TASK - !$OMP TASKWAIT + if (i==0) then + call ao_bielec_integrals_in_map_collector(i) + else + call ao_bielec_integrals_in_map_slave_inproc(i) + endif !$OMP END PARALLEL - rc = pthread_join(collector_thread) - 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)), ' )' ao_bielec_integrals_in_map = .True. + 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") endif diff --git a/src/Integrals_Bielec/ao_bielec_integrals_in_map_slave.irp.f b/src/Integrals_Bielec/ao_bielec_integrals_in_map_slave.irp.f index f15376b5..ce4518cf 100644 --- a/src/Integrals_Bielec/ao_bielec_integrals_in_map_slave.irp.f +++ b/src/Integrals_Bielec/ao_bielec_integrals_in_map_slave.irp.f @@ -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) 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' endif rc = f77_zmq_send( zmq_socket_push, buffer_i, key_kind*n_integrals, ZMQ_SNDMORE) 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' endif rc = f77_zmq_send( zmq_socket_push, buffer_value, integral_kind*n_integrals, ZMQ_SNDMORE) 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' endif rc = f77_zmq_send( zmq_socket_push, task_id, 4, 0) 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' endif @@ -60,7 +60,7 @@ subroutine push_integrals(zmq_socket_push, n_integrals, buffer_i, buffer_value, ! integer :: idummy ! rc = f77_zmq_recv( zmq_socket_push, idummy, 4, 0) ! 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' ! endif 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) :: zmq_socket_push + character*(64) :: state + zmq_to_qp_run_socket = new_zmq_to_qp_run_socket() zmq_socket_push = new_zmq_push_socket(thread) @@ -103,81 +105,21 @@ subroutine ao_bielec_integrals_in_map_slave(thread,iproc) do call get_task_from_taskserver(zmq_to_qp_run_socket,worker_id, task_id, task) if (task_id == 0) exit - read(task,*) l - do j=1,l-1 - 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) + read(task,*) j, l + call compute_ao_integrals_jl(j,l,n_integrals,buffer_i,buffer_value) 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) enddo - deallocate( buffer_i, buffer_value ) 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_push_socket(zmq_socket_push,thread) 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 use map_module use f77_zmq @@ -199,19 +141,59 @@ subroutine ao_bielec_integrals_in_map_collector integer(ZMQ_PTR) :: zmq_socket_pull 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_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 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 > 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) accu += n_integrals if (task_id /= 0) then @@ -227,9 +209,11 @@ subroutine ao_bielec_integrals_in_map_collector control = get_ao_map_size(ao_integrals_map) if (control /= accu) then - print *, irp_here, 'Control : ', control - print *, 'Accu : ', accu - print *, 'Some integrals were lost during the parallel computation. (2)' + print *, '' + print *, irp_here + print *, 'Control : ', control + print *, 'Accu : ', accu + print *, 'Some integrals were lost during the parallel computation.' print *, 'Try to reduce the number of threads.' stop endif diff --git a/src/Integrals_Bielec/map_integrals.irp.f b/src/Integrals_Bielec/map_integrals.irp.f index 4041242e..fdcf4038 100644 --- a/src/Integrals_Bielec/map_integrals.irp.f +++ b/src/Integrals_Bielec/map_integrals.irp.f @@ -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) sze = key_max call map_init(ao_integrals_map,sze) - print*, 'AO map initialized' + print*, 'AO map initialized : ', sze END_PROVIDER subroutine bielec_integrals_index(i,j,k,l,i1) @@ -230,7 +230,6 @@ subroutine clear_ao_map end - !! MO Map !! ====== diff --git a/src/Integrals_Bielec/mo_bi_integrals.irp.f b/src/Integrals_Bielec/mo_bi_integrals.irp.f index 4d471545..0a468c24 100644 --- a/src/Integrals_Bielec/mo_bi_integrals.irp.f +++ b/src/Integrals_Bielec/mo_bi_integrals.irp.f @@ -28,12 +28,10 @@ BEGIN_PROVIDER [ logical, mo_bielec_integrals_in_map ] mo_bielec_integrals_in_map = .True. if (read_mo_integrals) then - integer :: load_mo_integrals print*,'Reading the MO integrals' - if (load_mo_integrals(trim(ezfio_filename)//'/work/mo_integrals.bin') == 0) then - print*, 'MO integrals provided' - return - endif + call map_load_from_disk(trim(ezfio_filename)//'/work/mo_ints',mo_integrals_map) + print*, 'MO integrals provided' + return endif call add_integrals_to_map(full_ijkl_bitmask_4) @@ -72,7 +70,7 @@ subroutine add_integrals_to_map(mask_ijkl) integer :: i2,i3,i4 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 !------------------------------- @@ -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), ')' 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") endif @@ -329,7 +328,7 @@ end double precision, allocatable :: iqrs(:,:), iqsr(:,:), iqis(:), iqri(:) if (.not.do_direct_integrals) then - PROVIDE ao_bielec_integrals_in_map + PROVIDE ao_bielec_integrals_in_map mo_coef endif mo_bielec_integral_jj_from_ao = 0.d0 @@ -495,4 +494,13 @@ subroutine clear_mo_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_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 diff --git a/src/Integrals_Bielec/qp_ao_ints.irp.f b/src/Integrals_Bielec/qp_ao_ints.irp.f index c60b4e5d..93f62a7d 100644 --- a/src/Integrals_Bielec/qp_ao_ints.irp.f +++ b/src/Integrals_Bielec/qp_ao_ints.irp.f @@ -17,10 +17,15 @@ program qp_ao_ints double precision :: integral, ao_bielec_integral integral = ao_bielec_integral(1,1,1,1) - !$OMP PARALLEL DEFAULT(PRIVATE) PRIVATE(i) - i = omp_get_thread_num() - call ao_bielec_integrals_in_map_slave_tcp(i) - !$OMP END PARALLEL + character*(64) :: state + call wait_for_state(zmq_state,state) + do while (state /= 'Stopped') + !$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' end diff --git a/src/Integrals_Monoelec/mo_mono_ints.irp.f b/src/Integrals_Monoelec/mo_mono_ints.irp.f index 714222ec..5bae9868 100644 --- a/src/Integrals_Monoelec/mo_mono_ints.irp.f +++ b/src/Integrals_Monoelec/mo_mono_ints.irp.f @@ -5,6 +5,7 @@ BEGIN_PROVIDER [ double precision, mo_mono_elec_integral,(mo_tot_num_align,mo_to ! array of the mono electronic hamiltonian on the MOs basis ! : sum of the kinetic and nuclear electronic potential END_DOC + print*,'Providing the mono electronic integrals' do j = 1, mo_tot_num do i = 1, mo_tot_num mo_mono_elec_integral(i,j) = mo_nucl_elec_integral(i,j) + mo_kinetic_integral(i,j) + mo_pseudo_integral(i,j) diff --git a/src/Integrals_Monoelec/pot_ao_pseudo_ints.irp.f b/src/Integrals_Monoelec/pot_ao_pseudo_ints.irp.f index 615ed127..789bc9ea 100644 --- a/src/Integrals_Monoelec/pot_ao_pseudo_ints.irp.f +++ b/src/Integrals_Monoelec/pot_ao_pseudo_ints.irp.f @@ -3,10 +3,14 @@ BEGIN_PROVIDER [ double precision, ao_pseudo_integral, (ao_num_align,ao_num)] BEGIN_DOC ! Pseudo-potential END_DOC + ao_pseudo_integral = 0.d0 if (do_pseudo) then - ao_pseudo_integral = ao_pseudo_integral_local + ao_pseudo_integral_non_local - else - ao_pseudo_integral = 0.d0 + if (pseudo_klocmax > 0) then + ao_pseudo_integral += ao_pseudo_integral_local + endif + if (pseudo_kmax > 0) then + ao_pseudo_integral += ao_pseudo_integral_non_local + endif endif END_PROVIDER diff --git a/src/Integrals_Monoelec/pot_mo_ints.irp.f b/src/Integrals_Monoelec/pot_mo_ints.irp.f index 50019abb..69bb654d 100644 --- a/src/Integrals_Monoelec/pot_mo_ints.irp.f +++ b/src/Integrals_Monoelec/pot_mo_ints.irp.f @@ -6,24 +6,23 @@ BEGIN_PROVIDER [double precision, mo_nucl_elec_integral, (mo_tot_num_align,mo_to ! interaction nuclear electron on the MO basis END_DOC - mo_nucl_elec_integral = 0.d0 - !$OMP PARALLEL DO DEFAULT(none) & - !$OMP PRIVATE(i,j,i1,j1,c_j1,c_i1) & - !$OMP SHARED(mo_tot_num,ao_num,mo_coef, & - !$OMP mo_nucl_elec_integral, ao_nucl_elec_integral) - do i = 1, mo_tot_num - do j = 1, mo_tot_num - do i1 = 1,ao_num - c_i1 = mo_coef(i1,i) - do j1 = 1,ao_num - c_j1 = c_i1*mo_coef(j1,j) - mo_nucl_elec_integral(j,i) = mo_nucl_elec_integral(j,i) + & - c_j1 * ao_nucl_elec_integral(j1,i1) - enddo - enddo - enddo - enddo - !$OMP END PARALLEL DO + double precision, allocatable :: X(:,:) + allocate(X(ao_num_align,mo_tot_num)) + + call dgemm('N','N',ao_num,mo_tot_num,ao_num, & + 1.d0, & + ao_nucl_elec_integral, size(ao_nucl_elec_integral,1), & + mo_coef,size(mo_coef,1), & + 0.d0, X, size(X,1)) + + call dgemm('T','N',mo_tot_num,mo_tot_num,ao_num, & + 1.d0, & + mo_coef,size(mo_coef,1), & + X, size(X,1), & + 0.d0, mo_nucl_elec_integral, size(mo_nucl_elec_integral,1)) + + deallocate(X) + END_PROVIDER @@ -36,25 +35,25 @@ BEGIN_PROVIDER [double precision, mo_nucl_elec_integral_per_atom, (mo_tot_num_al ! where Rk is the geometry of the kth atom END_DOC - mo_nucl_elec_integral_per_atom = 0.d0 - do k = 1, nucl_num - !$OMP PARALLEL DO DEFAULT(none) & - !$OMP PRIVATE(i,j,i1,j1,c_j1,c_i1) & - !$OMP SHARED(mo_tot_num,ao_num,mo_coef, & - !$OMP mo_nucl_elec_integral_per_atom, ao_nucl_elec_integral_per_atom,k) - do i = 1, mo_tot_num - do j = 1, mo_tot_num - do i1 = 1,ao_num - c_i1 = mo_coef(i1,i) - do j1 = 1,ao_num - c_j1 = c_i1*mo_coef(j1,j) - mo_nucl_elec_integral_per_atom(j,i,k) = mo_nucl_elec_integral_per_atom(j,i,k) + & - c_j1 * ao_nucl_elec_integral_per_atom(j1,i1,k) - enddo - enddo - enddo - enddo - !$OMP END PARALLEL DO + allocate(X(ao_num_align,mo_tot_num)) + double precision, allocatable :: X(:,:) + + do k = 1, nucl_num + + call dgemm('N','N',ao_num,mo_tot_num,ao_num, & + 1.d0, & + ao_nucl_elec_integral_per_atom, size(ao_nucl_elec_integral_per_atom,1),& + mo_coef,size(mo_coef,1), & + 0.d0, X, size(X,1)) + + call dgemm('T','N',mo_tot_num,mo_tot_num,ao_num, & + 1.d0, & + mo_coef,size(mo_coef,1), & + X, size(X,1), & + 0.d0, mo_nucl_elec_integral_per_atom(1,1,k), size(mo_nucl_elec_integral_per_atom,1)) + enddo + + deallocate(X) END_PROVIDER diff --git a/src/Integrals_Monoelec/pseudopot.f90 b/src/Integrals_Monoelec/pseudopot.f90 index 32402c74..072ddbc9 100644 --- a/src/Integrals_Monoelec/pseudopot.f90 +++ b/src/Integrals_Monoelec/pseudopot.f90 @@ -109,9 +109,10 @@ end DIMENSION PM(0:100,0:100) MM=100 pi=dacos(-1.d0) + fourpi=4.d0*pi iabs_m=iabs(m) if(iabs_m.gt.l)stop 'm must be between -l and l' - factor= dsqrt( ((2*l+1)*fact(l-iabs_m))/(4.d0*pi*fact(l+iabs_m)) ) + factor= dsqrt( ((l+l+1)*fact(l-iabs_m))/(fourpi*fact(l+iabs_m)) ) if(dabs(x).gt.1.d0)then print*,'pb. in ylm_no' print*,'x=',x @@ -124,7 +125,6 @@ end if(m.eq.0)ylm_real=coef if(m.lt.0)ylm_real=dsqrt(2.d0)*coef*dsin(iabs_m*phi) - fourpi=4.d0*dacos(-1.d0) if(l.eq.0)ylm_real=dsqrt(1.d0/fourpi) xchap=dsqrt(1.d0-x**2)*dcos(phi) @@ -134,9 +134,9 @@ end if(l.eq.1.and.m.eq.0)ylm_real=dsqrt(3.d0/fourpi)*zchap if(l.eq.1.and.m.eq.-1)ylm_real=dsqrt(3.d0/fourpi)*ychap - if(l.eq.2.and.m.eq.2)ylm_real=dsqrt(15.d0/16.d0/pi)*(xchap**2-ychap**2) + if(l.eq.2.and.m.eq.2)ylm_real=dsqrt(15.d0/16.d0/pi)*(xchap*xchap-ychap*ychap) if(l.eq.2.and.m.eq.1)ylm_real=dsqrt(15.d0/fourpi)*xchap*zchap - if(l.eq.2.and.m.eq.0)ylm_real=dsqrt(5.d0/16.d0/pi)*(-xchap**2-ychap**2+2.d0*zchap**2) + if(l.eq.2.and.m.eq.0)ylm_real=dsqrt(5.d0/16.d0/pi)*(-xchap*xchap-ychap*ychap+2.d0*zchap*zchap) if(l.eq.2.and.m.eq.-1)ylm_real=dsqrt(15.d0/fourpi)*ychap*zchap if(l.eq.2.and.m.eq.-2)ylm_real=dsqrt(15.d0/fourpi)*xchap*ychap @@ -313,7 +313,7 @@ else if(ac.ne.0.d0.and.bc.ne.0.d0)then ! I n i t ! !=!=!=!=!=! - f=fourpi**2 + f=fourpi*fourpi theta_AC0=dacos( (a(3)-c(3))/ac ) phi_AC0=datan2((a(2)-c(2))/ac,(a(1)-c(1))/ac) @@ -1775,15 +1775,6 @@ double precision function binom_gen(alpha,n) enddo end - double precision FUNCTION ERF(X) - implicit double precision(a-h,o-z) - IF(X.LT.0.d0)THEN - ERF=-GAMMP(.5d0,X**2) - ELSE - ERF=GAMMP(.5d0,X**2) - ENDIF - RETURN - END double precision function coef_nk(n,k) implicit none @@ -1791,7 +1782,7 @@ double precision function coef_nk(n,k) double precision gam,dble_fact,fact - gam=dble_fact(2*(n+k)+1) + gam=dble_fact(n+n+k+k+1) ! coef_nk=1.d0/(dble(ISHFT(1,k))*fact(k)*gam) @@ -1862,7 +1853,7 @@ double precision function int_prod_bessel(l,gam,n,m,a,b,arg) term_rap = term_a / (2.d0*gam)**expo s_0_0=term_rap*a**(n)*b**(m) - if(mod(nlm,2).eq.0)s_0_0=s_0_0*dsqrt(pi/2.d0) + if(mod(nlm,2).eq.0)s_0_0=s_0_0*dsqrt(pi*.5d0) ! Initialise the first recurence terme for the q loop s_q_0 = s_0_0 @@ -1887,7 +1878,7 @@ double precision function int_prod_bessel(l,gam,n,m,a,b,arg) two_qkmp1 = two_qkmp1-2.d0 qk = qk-1.d0 enddo - inverses(q) = a_over_b_square/(dble(2*(q+n)+3) * dble(q+1)) + inverses(q) = a_over_b_square/(dble(q+n+q+n+3) * dble(q+1)) ! do k=0,q ! sum=sum+s_q_k ! s_q_k = a_over_b_square * ( dble(2*(q-k+m)+1)*dble(q-k)/(dble(2*(k+n)+3) * dble(k+1)) ) * s_q_k @@ -1900,9 +1891,10 @@ double precision function int_prod_bessel(l,gam,n,m,a,b,arg) else !Compute the s_q+1_0 - s_q_0=s_q_0*(2.d0*q+nlm+1)*b**2/((2.d0*(m+q)+3)*4.d0*(q+1)*gam) +! s_q_0=s_q_0*(2.d0*q+nlm+1)*b**2/((2.d0*(m+q)+3)*4.d0*(q+1)*gam) + s_q_0=s_q_0*(2.d0*q+nlm+1)*b*b/((8.d0*(m+q)+12.d0)*(q+1)*gam) - if(mod(n+m+l,2).eq.1)s_q_0=s_q_0*dsqrt(pi/2.d0) + if(mod(n+m+l,2).eq.1)s_q_0=s_q_0*dsqrt(pi*.5d0) ! Increment q q=q+1 intold=int @@ -2017,7 +2009,7 @@ double precision function int_prod_bessel_loc(l,gam,n,a) ! Int f_0 coef_nk=1.d0/dble_fact( n+n+1 ) expo=0.5d0*dfloat(n+l+1) - crochet=dble_fact(n+l-1)/(2.d0*gam)**expo + crochet=dble_fact(n+l-1)/(gam+gam)**expo if(mod(n+l,2).eq.0)crochet=crochet*dsqrt(0.5d0*pi) f_0 = coef_nk*a**n*crochet @@ -2029,7 +2021,7 @@ double precision function int_prod_bessel_loc(l,gam,n,a) int=int+f_k - f_k = f_k*(a**2*(2*(k+1)+n+l-1)) / (2*(k+1)*(2*(n+k+1)+1)*2*gam) + f_k = f_k*(a*a*dble(k+k+2+n+l-1)) / (dble((k+k+2)*(2*(n+k+1)+1)*2)*gam) if(dabs(int-intold).lt.1d-15)then done=.true. diff --git a/src/Utils/LinearAlgebra.irp.f b/src/Utils/LinearAlgebra.irp.f index 86a58729..00f61101 100644 --- a/src/Utils/LinearAlgebra.irp.f +++ b/src/Utils/LinearAlgebra.irp.f @@ -73,6 +73,10 @@ subroutine ortho_canonical(overlap,LDA,N,C,LDC,m) !DEC$ ATTRIBUTES ALIGN : 64 :: U, Vt, D integer :: info, i, j + if (n < 2) then + return + endif + allocate (U(ldc,n), Vt(lda,n), D(n), S_half(lda,n)) call svd(overlap,lda,U,ldc,D,Vt,lda,n,n) @@ -144,14 +148,19 @@ subroutine ortho_lowdin(overlap,LDA,N,C,LDC,m) integer, intent(in) :: LDA, ldc, n, m double precision, intent(in) :: overlap(lda,n) double precision, intent(inout) :: C(ldc,n) - double precision,allocatable :: U(:,:) - double precision :: Vt(lda,n) - double precision :: D(n) - double precision :: S_half(lda,n) + double precision, allocatable :: U(:,:) + double precision, allocatable :: Vt(:,:) + double precision, allocatable :: D(:) + double precision, allocatable :: S_half(:,:) !DEC$ ATTRIBUTES ALIGN : 64 :: U, Vt, D integer :: info, i, j, k - allocate(U(ldc,n)) + if (n < 2) then + return + endif + + allocate(U(ldc,n),Vt(lda,n),S_half(lda,n),D(n)) + call svd(overlap,lda,U,ldc,D,Vt,lda,m,n) !$OMP PARALLEL DEFAULT(NONE) & @@ -196,6 +205,7 @@ subroutine ortho_lowdin(overlap,LDA,N,C,LDC,m) call dgemm('N','N',m,n,n,1.d0,U,size(U,1),S_half,size(S_half,1),0.d0,C,size(C,1)) + deallocate(U,Vt,S_half,D) end diff --git a/src/Utils/fortran_mmap.c b/src/Utils/fortran_mmap.c new file mode 100644 index 00000000..eee8337e --- /dev/null +++ b/src/Utils/fortran_mmap.c @@ -0,0 +1,72 @@ +#include +#include +#include +#include +#include +#include +#include + + +void* mmap_fortran(char* filename, size_t bytes, int* file_descr, int read_only) +{ + int i; + int fd; + int result; + void* map; + + if (read_only == 1) + { + fd = open(filename, O_RDONLY, (mode_t)0600); + if (fd == -1) { + printf("%s:\n", filename); + perror("Error opening mmap file for reading"); + exit(EXIT_FAILURE); + } + map = mmap(NULL, bytes, PROT_READ, MAP_SHARED, fd, 0); + } + else + { + fd = open(filename, O_RDWR | O_CREAT, (mode_t)0600); + if (fd == -1) { + printf("%s:\n", filename); + perror("Error opening mmap file for writing"); + exit(EXIT_FAILURE); + } + + result = lseek(fd, bytes, SEEK_SET); + if (result == -1) { + close(fd); + printf("%s:\n", filename); + perror("Error calling lseek() to stretch the file"); + exit(EXIT_FAILURE); + } + + result = write(fd, "", 1); + if (result != 1) { + close(fd); + printf("%s:\n", filename); + perror("Error writing last byte of the file"); + exit(EXIT_FAILURE); + } + + map = mmap(NULL, bytes, PROT_READ | PROT_WRITE, MAP_SHARED, fd, 0); + } + + if (map == MAP_FAILED) { + close(fd); + printf("%s:\n", filename); + perror("Error mmapping the file"); + exit(EXIT_FAILURE); + } + + *file_descr = fd; + return map; +} + +void munmap_fortran(size_t bytes, int fd, void* map) +{ + if (munmap(map, bytes) == -1) { + perror("Error un-mmapping the file"); + } + close(fd); +} diff --git a/src/Utils/map_functions.irp.f b/src/Utils/map_functions.irp.f new file mode 100644 index 00000000..68ba342c --- /dev/null +++ b/src/Utils/map_functions.irp.f @@ -0,0 +1,115 @@ +subroutine map_save_to_disk(filename,map) + use map_module + use mmap_module + implicit none + character*(*), intent(in) :: filename + type(map_type), intent(inout) :: map + type(c_ptr) :: c_pointer(3) + integer :: fd(3) + integer*8 :: i,k + integer :: j + + + if (map % consolidated) then + stop 'map already consolidated' + endif + + call mmap(trim(filename)//'_consolidated_idx', (/ map % map_size + 2_8 /), 8, fd(1), .False., c_pointer(1)) + call c_f_pointer(c_pointer(1),map % consolidated_idx, (/ map % map_size +2_8/)) + + call mmap(trim(filename)//'_consolidated_key', (/ map % n_elements /), cache_key_kind, fd(2), .False., c_pointer(2)) + call c_f_pointer(c_pointer(2),map % consolidated_key, (/ map % n_elements /)) + + call mmap(trim(filename)//'_consolidated_value', (/ map % n_elements /), integral_kind, fd(3), .False., c_pointer(3)) + call c_f_pointer(c_pointer(3),map % consolidated_value, (/ map % n_elements /)) + + if (.not.associated(map%consolidated_key)) then + stop 'cannot consolidate map : consolidated_key not associated' + endif + + if (.not.associated(map%consolidated_value)) then + stop 'cannot consolidate map : consolidated_value not associated' + endif + + if (.not.associated(map%consolidated_idx)) then + stop 'cannot consolidate map : consolidated_idx not associated' + endif + + call map_sort(map) + k = 1_8 + do i=0_8, map % map_size + map % consolidated_idx (i+1) = k + do j=1, map % map(i) % n_elements + map % consolidated_value(k) = map % map(i) % value(j) + map % consolidated_key (k) = map % map(i) % key(j) + k = k+1_8 + enddo + deallocate(map % map(i) % value) + deallocate(map % map(i) % key) + map % map(i) % value => map % consolidated_value ( map % consolidated_idx (i+1) :) + map % map(i) % key => map % consolidated_key ( map % consolidated_idx (i+1) :) + enddo + map % consolidated_idx (map % map_size + 2_8) = k + map % consolidated = .True. + + +! call munmap( (/ map % map_size + 2_8 /), 8, fd(1), c_pointer(1)) +! call mmap(trim(filename)//'_consolidated_idx', (/ map % map_size + 2_8 /), 8, fd(1), .True., c_pointer(1)) +! call c_f_pointer(c_pointer(1),map % consolidated_idx, (/ map % map_size +2_8/)) +! +! call munmap( (/ map % n_elements /), cache_key_kind, fd(2), c_pointer(2)) +! call mmap(trim(filename)//'_consolidated_key', (/ map % n_elements /), cache_key_kind, fd(2), .True., c_pointer(2)) +! call c_f_pointer(c_pointer(2),map % consolidated_key, (/ map % n_elements /)) +! +! call munmap( (/ map % n_elements /), integral_kind, fd(3), c_pointer(3)) +! call mmap(trim(filename)//'_consolidated_value', (/ map % n_elements /), integral_kind, fd(3), .True., c_pointer(3)) +! call c_f_pointer(c_pointer(3),map % consolidated_value, (/ map % n_elements /)) + +end + +subroutine map_load_from_disk(filename,map) + use map_module + use mmap_module + implicit none + character*(*), intent(in) :: filename + type(map_type), intent(inout) :: map + type(c_ptr) :: c_pointer(3) + integer :: fd(3) + integer*8 :: i,k + integer :: n_elements + + + + if (map % consolidated) then + stop 'map already consolidated' + endif + + call mmap(trim(filename)//'_consolidated_idx', (/ map % map_size + 2_8 /), 8, fd(1), .True., c_pointer(1)) + call c_f_pointer(c_pointer(1),map % consolidated_idx, (/ map % map_size + 2_8/)) + + map% n_elements = map % consolidated_idx (map % map_size+2_8)-1 + + call mmap(trim(filename)//'_consolidated_key', (/ map % n_elements /), cache_key_kind, fd(2), .True., c_pointer(2)) + call c_f_pointer(c_pointer(2),map % consolidated_key, (/ map % n_elements /)) + + call mmap(trim(filename)//'_consolidated_value', (/ map % n_elements /), integral_kind, fd(3), .True., c_pointer(3)) + call c_f_pointer(c_pointer(3),map % consolidated_value, (/ map % n_elements /)) + + k = 1_8 + do i=0_8, map % map_size + deallocate(map % map(i) % value) + deallocate(map % map(i) % key) + map % map(i) % value => map % consolidated_value ( map % consolidated_idx (i+1) :) + map % map(i) % key => map % consolidated_key ( map % consolidated_idx (i+1) :) + map % map(i) % sorted = .True. + n_elements = map % consolidated_idx (i+2) - k + k = map % consolidated_idx (i+2) + map % map(i) % map_size = n_elements + map % map(i) % n_elements = n_elements + enddo + map % n_elements = k-1 + map % sorted = .True. + map % consolidated = .True. + +end + diff --git a/src/Utils/map_module.f90 b/src/Utils/map_module.f90 index 47adc83e..c2a5cbf1 100644 --- a/src/Utils/map_module.f90 +++ b/src/Utils/map_module.f90 @@ -30,8 +30,8 @@ module map_module integer*8, parameter :: map_mask = ibset(0_8,15)-1_8 type cache_map_type - integer(cache_key_kind), pointer :: key(:) real(integral_kind), pointer :: value(:) + integer(cache_key_kind), pointer :: key(:) logical :: sorted integer(cache_map_size_kind) :: map_size integer(cache_map_size_kind) :: n_elements @@ -40,9 +40,13 @@ module map_module type map_type type(cache_map_type), allocatable :: map(:) + real(integral_kind), pointer :: consolidated_value(:) + integer(cache_key_kind), pointer :: consolidated_key(:) + integer*8, pointer :: consolidated_idx(:) + logical :: sorted + logical :: consolidated integer(map_size_kind) :: map_size integer(map_size_kind) :: n_elements - logical :: sorted integer(omp_lock_kind) :: lock end type map_type @@ -92,6 +96,7 @@ subroutine map_init(map,keymax) map%n_elements = 0_8 map%map_size = ishft(keymax,map_shift) + map%consolidated = .False. allocate(map%map(0_8:map%map_size),stat=err) if (err /= 0) then @@ -618,6 +623,7 @@ subroutine search_key_big_interval(key,X,sze,idx,ibegin_in,iend_in) idx = ibegin + istep do while (istep > 16) idx = ibegin + istep + ! TODO : Cache misses if (cache_key < X(idx)) then iend = idx istep = ishft(idx-ibegin,-1) @@ -655,12 +661,10 @@ subroutine search_key_big_interval(key,X,sze,idx,ibegin_in,iend_in) idx = ibegin if (min(iend_in,sze) > ibegin+16) then iend = ibegin+16 - !DIR$ VECTOR ALIGNED do while (cache_key > X(idx)) idx = idx+1 end do else - !DIR$ VECTOR ALIGNED do while (cache_key > X(idx)) idx = idx+1 if (idx /= iend) then @@ -768,13 +772,11 @@ subroutine search_key_value_big_interval(key,value,X,Y,sze,idx,ibegin_in,iend_in value = Y(idx) if (min(iend_in,sze) > ibegin+16) then iend = ibegin+16 - !DIR$ VECTOR ALIGNED do while (cache_key > X(idx)) idx = idx+1 value = Y(idx) end do else - !DIR$ VECTOR ALIGNED do while (cache_key > X(idx)) idx = idx+1 value = Y(idx) @@ -848,8 +850,9 @@ subroutine get_cache_map(map,map_idx,keys,values,n_elements) n_elements = map%map(map_idx)%n_elements do i=1,n_elements - keys(i) = map%map(map_idx)%key(i) + shift + keys(i) = map%map(map_idx)%key(i) + shift values(i) = map%map(map_idx)%value(i) enddo end + diff --git a/src/Utils/mmap.f90 b/src/Utils/mmap.f90 new file mode 100644 index 00000000..75b996de --- /dev/null +++ b/src/Utils/mmap.f90 @@ -0,0 +1,69 @@ +module mmap_module + + use iso_c_binding + + interface + + ! File descriptors + ! ---------------- + + type(c_ptr) function c_mmap_fortran(filename, length, fd, read_only) bind(c,name='mmap_fortran') + use iso_c_binding + character(c_char), intent(in) :: filename(*) + integer(c_size_t), intent(in), value :: length + integer(c_int), intent(out) :: fd + integer(c_int), intent(in), value :: read_only + end function + + subroutine c_munmap(length, fd, map) bind(c,name='munmap_fortran') + use iso_c_binding + integer(c_size_t), intent(in), value :: length + integer(c_int), intent(in), value :: fd + type(c_ptr), intent(in), value :: map + end subroutine + + end interface + + contains + + subroutine mmap(filename, shape, bytes, fd, read_only, map) + use iso_c_binding + implicit none + character*(*), intent(in) :: filename ! Name of the mapped file + integer*8, intent(in) :: shape(:) ! Shape of the array to map + integer, intent(in) :: bytes ! Number of bytes per element + logical, intent(in) :: read_only ! If true, mmap is read-only + integer, intent(out) :: fd ! File descriptor + type(c_ptr), intent(out) :: map ! C Pointer + + integer(c_long) :: length + integer(c_int) :: fd_ + + length = PRODUCT( shape(:) ) * bytes + if (read_only) then + map = c_mmap_fortran( trim(filename)//char(0), length, fd_, 1) + else + map = c_mmap_fortran( trim(filename)//char(0), length, fd_, 0) + endif + fd = fd_ + end subroutine + + subroutine munmap(shape, bytes, fd, map) + use iso_c_binding + implicit none + integer*8, intent(in) :: shape(:) ! Shape of the array to map + integer, intent(in) :: bytes ! Number of bytes per element + integer, intent(in) :: fd ! File descriptor + type(c_ptr), intent(in) :: map ! C pointer + + integer(c_long) :: length + integer(c_int) :: fd_ + + length = PRODUCT( shape(:) ) * bytes + fd_ = fd + call c_munmap( length, fd_, map) + end subroutine + +end module mmap_module + + diff --git a/src/Utils/util.irp.f b/src/Utils/util.irp.f index a0ea668d..91a61a43 100644 --- a/src/Utils/util.irp.f +++ b/src/Utils/util.irp.f @@ -295,18 +295,6 @@ BEGIN_PROVIDER [ integer, nproc ] !$OMP END PARALLEL END_PROVIDER -BEGIN_PROVIDER [ integer, iproc_save, (nproc) ] - implicit none - BEGIN_DOC - ! iproc_save(i) = i-1. Used to start threads with pthreads. - END_DOC - integer :: i - do i=1,nproc - iproc_save(i) = i-1 - enddo - -END_PROVIDER - double precision function u_dot_v(u,v,sze) implicit none diff --git a/src/ZMQ/utils.irp.f b/src/ZMQ/utils.irp.f index 7164d9a6..d3b76f4f 100644 --- a/src/ZMQ/utils.irp.f +++ b/src/ZMQ/utils.irp.f @@ -46,31 +46,39 @@ END_PROVIDER &BEGIN_PROVIDER [ character*(128), zmq_socket_push_tcp_address ] &BEGIN_PROVIDER [ character*(128), zmq_socket_pull_inproc_address ] &BEGIN_PROVIDER [ character*(128), zmq_socket_push_inproc_address ] +&BEGIN_PROVIDER [ character*(128), zmq_socket_sub_tcp_address ] use f77_zmq implicit none BEGIN_DOC ! Socket which pulls the results (2) END_DOC - character*(8), external :: zmq_port - zmq_socket_pull_tcp_address = 'tcp://*:'//zmq_port(1)//' ' - zmq_socket_push_tcp_address = trim(qp_run_address)//':'//zmq_port(1)//' ' - zmq_socket_pull_inproc_address = 'inproc://'//zmq_port(1)//' ' + + zmq_socket_sub_tcp_address = trim(qp_run_address)//':'//zmq_port(1)//' ' + zmq_socket_pull_tcp_address = 'tcp://*:'//zmq_port(2)//' ' + zmq_socket_push_tcp_address = trim(qp_run_address)//':'//zmq_port(2)//' ' + zmq_socket_pull_inproc_address = 'inproc://'//zmq_port(2)//' ' zmq_socket_push_inproc_address = zmq_socket_pull_inproc_address - zmq_socket_pair_inproc_address = 'inproc://'//zmq_port(2)//' ' + zmq_socket_pair_inproc_address = 'inproc://'//zmq_port(3)//' ' + + ! /!\ Don't forget to change subroutine reset_zmq_addresses END_PROVIDER subroutine reset_zmq_addresses use f77_zmq implicit none + BEGIN_DOC + ! Socket which pulls the results (2) + END_DOC character*(8), external :: zmq_port - - zmq_socket_pull_tcp_address = 'tcp://*:'//zmq_port(1)//' ' - zmq_socket_push_tcp_address = trim(qp_run_address)//':'//zmq_port(1)//' ' - zmq_socket_pull_inproc_address = 'inproc://'//zmq_port(1)//' ' + + zmq_socket_sub_tcp_address = trim(qp_run_address)//':'//zmq_port(1)//' ' + zmq_socket_pull_tcp_address = 'tcp://*:'//zmq_port(2)//' ' + zmq_socket_push_tcp_address = trim(qp_run_address)//':'//zmq_port(2)//' ' + zmq_socket_pull_inproc_address = 'inproc://'//zmq_port(2)//' ' zmq_socket_push_inproc_address = zmq_socket_pull_inproc_address - zmq_socket_pair_inproc_address = 'inproc://'//zmq_port(2)//' ' -end + zmq_socket_pair_inproc_address = 'inproc://'//zmq_port(3)//' ' +end subroutine switch_qp_run_to_master @@ -87,6 +95,7 @@ subroutine switch_qp_run_to_master stop -1 endif qp_run_address = trim(buffer) + print *, 'Switched to qp_run master : ', trim(qp_run_address) integer :: i do i=len(buffer),1,-1 @@ -96,7 +105,6 @@ subroutine switch_qp_run_to_master exit endif enddo - call reset_zmq_addresses end @@ -126,6 +134,9 @@ function new_zmq_to_qp_run_socket() integer(ZMQ_PTR) :: new_zmq_to_qp_run_socket call omp_set_lock(zmq_lock) + if (zmq_context == 0_ZMQ_PTR) then + stop 'zmq_context is uninitialized' + endif new_zmq_to_qp_run_socket = f77_zmq_socket(zmq_context, ZMQ_REQ) call omp_unset_lock(zmq_lock) if (new_zmq_to_qp_run_socket == 0_ZMQ_PTR) then @@ -162,6 +173,9 @@ function new_zmq_pair_socket(bind) integer(ZMQ_PTR) :: new_zmq_pair_socket call omp_set_lock(zmq_lock) + if (zmq_context == 0_ZMQ_PTR) then + stop 'zmq_context is uninitialized' + endif new_zmq_pair_socket = f77_zmq_socket(zmq_context, ZMQ_PAIR) call omp_unset_lock(zmq_lock) if (new_zmq_pair_socket == 0_ZMQ_PTR) then @@ -181,14 +195,14 @@ function new_zmq_pair_socket(bind) endif endif - rc = f77_zmq_setsockopt(new_zmq_pair_socket, ZMQ_SNDHWM, 0, 4) + rc = f77_zmq_setsockopt(new_zmq_pair_socket, ZMQ_SNDHWM, 1, 4) if (rc /= 0) then - stop 'f77_zmq_setsockopt(new_zmq_pair_socket, ZMQ_SNDHWM, 0, 4)' + stop 'f77_zmq_setsockopt(new_zmq_pair_socket, ZMQ_SNDHWM, 1, 4)' endif - rc = f77_zmq_setsockopt(new_zmq_pair_socket, ZMQ_RCVHWM, 0, 4) + rc = f77_zmq_setsockopt(new_zmq_pair_socket, ZMQ_RCVHWM, 1, 4) if (rc /= 0) then - stop 'f77_zmq_setsockopt(new_zmq_pair_socket, ZMQ_RCVHWM, 0, 4)' + stop 'f77_zmq_setsockopt(new_zmq_pair_socket, ZMQ_RCVHWM, 1, 4)' endif rc = f77_zmq_setsockopt(new_zmq_pair_socket, ZMQ_IMMEDIATE, 1, 4) @@ -217,6 +231,9 @@ function new_zmq_pull_socket() integer(ZMQ_PTR) :: new_zmq_pull_socket call omp_set_lock(zmq_lock) + if (zmq_context == 0_ZMQ_PTR) then + stop 'zmq_context is uninitialized' + endif new_zmq_pull_socket = f77_zmq_socket(zmq_context, ZMQ_PULL) ! new_zmq_pull_socket = f77_zmq_socket(zmq_context, ZMQ_REP) call omp_unset_lock(zmq_lock) @@ -229,16 +246,11 @@ function new_zmq_pull_socket() stop 'Unable to set ZMQ_LINGER on pull socket' endif - rc = f77_zmq_setsockopt(new_zmq_pull_socket,ZMQ_RCVHWM,100000,4) + rc = f77_zmq_setsockopt(new_zmq_pull_socket,ZMQ_RCVHWM,1000,4) if (rc /= 0) then stop 'Unable to set ZMQ_RCVHWM on pull socket' endif - rc = f77_zmq_setsockopt(new_zmq_pull_socket,ZMQ_IMMEDIATE,1,4) - if (rc /= 0) then - stop 'Unable to set ZMQ_IMMEDIATE on pull socket' - endif - rc = f77_zmq_bind(new_zmq_pull_socket, zmq_socket_pull_tcp_address) if (rc /= 0) then print *, 'Unable to bind new_zmq_pull_socket (tcp)', zmq_socket_pull_tcp_address @@ -267,6 +279,9 @@ function new_zmq_push_socket(thread) integer(ZMQ_PTR) :: new_zmq_push_socket call omp_set_lock(zmq_lock) + if (zmq_context == 0_ZMQ_PTR) then + stop 'zmq_context is uninitialized' + endif new_zmq_push_socket = f77_zmq_socket(zmq_context, ZMQ_PUSH) ! new_zmq_push_socket = f77_zmq_socket(zmq_context, ZMQ_REQ) call omp_unset_lock(zmq_lock) @@ -279,7 +294,7 @@ function new_zmq_push_socket(thread) stop 'Unable to set ZMQ_LINGER on push socket' endif - rc = f77_zmq_setsockopt(new_zmq_push_socket,ZMQ_SNDHWM,100,4) + rc = f77_zmq_setsockopt(new_zmq_push_socket,ZMQ_SNDHWM,1000,4) if (rc /= 0) then stop 'Unable to set ZMQ_SNDHWM on push socket' endif @@ -307,6 +322,60 @@ end +function new_zmq_sub_socket() + use f77_zmq + implicit none + BEGIN_DOC + ! Socket to read the state published by the Task server + END_DOC + integer :: rc + integer(ZMQ_PTR) :: new_zmq_sub_socket + + call omp_set_lock(zmq_lock) + if (zmq_context == 0_ZMQ_PTR) then + stop 'zmq_context is uninitialized' + endif + new_zmq_sub_socket = f77_zmq_socket(zmq_context, ZMQ_SUB) + call omp_unset_lock(zmq_lock) + if (new_zmq_sub_socket == 0_ZMQ_PTR) then + stop 'Unable to create zmq sub socket' + endif + + rc = f77_zmq_setsockopt(new_zmq_sub_socket,ZMQ_RCVTIMEO,10000,4) + if (rc /= 0) then + stop 'Unable to set timeout in new_zmq_sub_socket' + endif + + rc = f77_zmq_setsockopt(new_zmq_sub_socket,ZMQ_SUBSCRIBE,"",0) + if (rc /= 0) then + stop 'Unable to subscribe new_zmq_sub_socket' + endif + + rc = f77_zmq_connect(new_zmq_sub_socket, zmq_socket_sub_tcp_address) + if (rc /= 0) then + stop 'Unable to connect new_zmq_sub_socket' + endif +end + + +subroutine end_zmq_sub_socket(zmq_socket_sub) + use f77_zmq + implicit none + BEGIN_DOC + ! Terminate socket on which the results are sent. + END_DOC + integer(ZMQ_PTR), intent(in) :: zmq_socket_sub + integer :: rc + + rc = f77_zmq_close(zmq_socket_sub) + if (rc /= 0) then + print *, 'f77_zmq_close(zmq_socket_sub)' + stop 'error' + endif + +end + + subroutine end_zmq_pair_socket(zmq_socket_pair) use f77_zmq implicit none @@ -347,14 +416,14 @@ subroutine end_zmq_pull_socket(zmq_socket_pull) integer :: rc character*(8), external :: zmq_port -! rc = f77_zmq_unbind(zmq_socket_pull,zmq_socket_pull_inproc_address) -! if (rc /= 0) then -! print *, rc -! print *, irp_here, 'f77_zmq_unbind(zmq_socket_pull,zmq_socket_pull_inproc_address)' -! stop 'error' -! endif + rc = f77_zmq_unbind(zmq_socket_pull,zmq_socket_pull_inproc_address) +! if (rc /= 0) then +! print *, rc +! print *, irp_here, 'f77_zmq_unbind(zmq_socket_pull,zmq_socket_pull_inproc_address)' +! stop 'error' +! endif - ! rc = f77_zmq_unbind(zmq_socket_pull,zmq_socket_pull_tcp_address) + rc = f77_zmq_unbind(zmq_socket_pull,zmq_socket_pull_tcp_address) ! if (rc /= 0) then ! print *, rc ! print *, irp_here, 'f77_zmq_unbind(zmq_socket_pull,zmq_socket_pull_tcp_address)' @@ -610,7 +679,7 @@ subroutine add_task_to_taskserver(zmq_to_qp_run_socket,task) end -subroutine task_done_to_taskserver(zmq_to_qp_run_socket,worker_id, task_id) +subroutine task_done_to_taskserver(zmq_to_qp_run_socket, worker_id, task_id) use f77_zmq implicit none BEGIN_DOC @@ -759,3 +828,31 @@ subroutine zmq_delete_task(zmq_to_qp_run_socket,zmq_socket_pull,task_id,more) endif end +subroutine wait_for_state(state_wait,state) + use f77_zmq + implicit none + BEGIN_DOC +! Wait for the ZMQ state to be ready + END_DOC + character*(64), intent(in) :: state_wait + character*(64), intent(out) :: state + integer(ZMQ_PTR) :: zmq_socket_sub + integer(ZMQ_PTR), external :: new_zmq_sub_socket + integer :: rc + + zmq_socket_sub = new_zmq_sub_socket() + state = "Waiting" + do while (state /= state_wait .and. state /= "Stopped") + rc = f77_zmq_recv( zmq_socket_sub, state, 64, 0) + if (rc > 0) then + state = trim(state(1:rc)) + else + print *, 'Timeout reached. Stopping' + state = "Stopped" + endif + end do + call end_zmq_sub_socket(zmq_socket_sub) +end + + + diff --git a/tests/bats/qp.bats b/tests/bats/qp.bats index 1ced9e1d..78ed973d 100644 --- a/tests/bats/qp.bats +++ b/tests/bats/qp.bats @@ -155,7 +155,7 @@ function run_all_1h_1p() { ezfio set determinants read_wf True qp_run mrcc_cassd $INPUT energy="$(ezfio get mrcc_cassd energy)" - eq $energy -76.2284994316618 1.e-4 + eq $energy -76.2288648023833 1.e-4 } @@ -166,7 +166,7 @@ function run_all_1h_1p() { } @test "SCF H2O VDZ pseudo" { - run_HF h2o_pseudo.ezfio -16.9483708495521 + run_HF h2o_pseudo.ezfio -16.9483703905461 } @test "FCI H2O VDZ pseudo" {