diff --git a/README.md b/README.md index afb5f931..a55dfc16 100644 --- a/README.md +++ b/README.md @@ -11,25 +11,29 @@ - [ビルド例](https://github.com/kohei-noda-qcrg/dirac_caspt2#ビルド例) - [How to use](https://github.com/kohei-noda-qcrg/dirac_caspt2#how-to-use) - [開発者のかたへ](https://github.com/kohei-noda-qcrg/dirac_caspt2#開発者のかたへ) - - [環境構築について](https://github.com/kohei-noda-qcrg/dirac_caspt2#環境構築について) - - [ビルドについて](https://github.com/kohei-noda-qcrg/dirac_caspt2#ビルドについて) - [テストについて](https://github.com/kohei-noda-qcrg/dirac_caspt2#テストについて) + - [ビルドについて](https://github.com/kohei-noda-qcrg/dirac_caspt2#ビルドについて) + - [環境構築について](https://github.com/kohei-noda-qcrg/dirac_caspt2#環境構築について) + + ## Requirements 以下のコンパイラおよびツール、ライブラリと依存性があり、ビルドを行う計算機でこれらがセットアップされている必要があります - [GNU Fortran](https://gcc.gnu.org/fortran/) or [Intel Fortran](https://www.intel.com/content/www/us/en/developer/tools/oneapi/fortran-compiler.html) compiler (並列計算をするために並列コンパイラを使うこともできます) -- [CMake](https://cmake.org/)(version>=3.7 が必要です) +- [CMake](https://cmake.org/)(version ≧ 3.7 が必要です) - cmakeが計算機に入っていないか、バージョンが古い場合[CMakeのGithub](https://github.com/Kitware/CMake/releases)からビルドするもしくはビルド済みのファイルを解凍して使用してください - [Intel MKL(Math Kernel Library)](https://www.intel.com/content/www/us/en/develop/documentation/get-started-with-mkl-for-dpcpp/top.html) - - MKLをリンクするため環境変数\$MKLROOTが設定されている必要があります + - MKLをリンクするため環境変数\$MKLROOTが設定されている必要があります \$MKLROOTが設定されているか確認するには、使用する計算機にログインして以下のコマンドを実行してMKLにパスが通っているかを確認してください ```sh echo $MKLROOT ``` - - 現時点ではMKLのBlas,LapackではなくBlas及びLapack単体でビルドする場合、-DMKL=offオプションを指定し、かつLDFLAGSを手動設定する必要があります + - 現時点ではMKLのBlas,Lapack以外のBlas,Lapackの実装を用いてビルドする場合、-DMKL=offオプションを指定し、かつLDFLAGSを手動設定する必要があります + - また、MKLのBlas,Lapack以外での動作は現在保障しておりませんのでご了承ください + ビルド例 ```sh mkdir build @@ -39,12 +43,12 @@ ``` -- [Python(version >= 3.6)](https://www.python.org/) +- [Python(version ≧ 3.6)](https://www.python.org/) - テストを実行するために使用します - - Python (version >=3.6)がインストールされておらず、かつルート権限がない場合[pyenv](https://github.com/pyenv/pyenv)などのPythonバージョンマネジメントツールを使用して非ルートユーザーでPythonをインストール、セットアップすることをおすすめします + - Python (version ≧ 3.6)がインストールされておらず、かつルート権限がない場合[pyenv](https://github.com/pyenv/pyenv)などのPythonバージョンマネジメントツールを使用して非ルートユーザーでPythonをインストール、セットアップすることをおすすめします - [pytest](https://docs.pytest.org/) - テストを実行するために使用します - - python (version >= 3.6)をインストールしていれば以下のコマンドで入手できます + - python (version ≧ 3.6)をインストールしていれば以下のコマンドで入手できます ```sh python -m pip install pytest ``` @@ -60,7 +64,7 @@ FC=ifort cmake .. --clean-first make ``` -- CMake version >= 3.13 を使っているなら以下のようなコマンドでもビルドができます +- CMake version ≧ 3.13 を使っているなら以下のようなコマンドでもビルドができます ```sh git clone https://github.com/kohei-noda-qcrg/dirac_caspt2 @@ -81,7 +85,7 @@ cmake --build build -j4 --clean-first ### ソフトウェアのテスト ビルド後はテストを行うことを推奨します -テストを行うには[Python(version >= 3.6)](https://www.python.org/)と[pytest](https://docs.pytest.org/)が必要です +テストを行うには[Python(version ≧ 3.6)](https://www.python.org/)と[pytest](https://docs.pytest.org/)が必要です testディレクトリより上位のディレクトリでpytestコマンドを実行することでテストが実行されます ```sh @@ -277,7 +281,7 @@ ras3 end ``` -各パラメータの意味と必須パラメータかどうかについては以下を参照してください +各パラメータの意味と必須パラメータかどうかについては以下を参照してください(requiredとあるものは必須パラメータです ```in Input for CASCI and CASPT2 @@ -333,6 +337,56 @@ end : The identifier at the end of active.inp (required) ## 開発者のかたへ +### テストについて + +- 新機能作成時は[単体テスト](https://ja.wikipedia.org/wiki/%E5%8D%98%E4%BD%93%E3%83%86%E3%82%B9%E3%83%88)を書いて小さい機能単位で細かくテストするような開発スタイルをお勧めします。単体テストのやり方については[このプロジェクトの単体テストのディレクトリ](https://github.com/kohei-noda-qcrg/dirac_caspt2/tree/main/test/unit_test)や[単体テストのチュートリアル的記事](https://qiita.com/5t111111/items/babb143562bae449150a)を参照したり、[単体テストについて検索](https://www.google.com/search?q=%E5%8D%98%E4%BD%93%E3%83%86%E3%82%B9%E3%83%88)して学ぶことをお勧めします + +- このプロジェクトでは、以下の手順でCASPT2エネルギーに一定以上の誤差があるかどうかをテストできます。誤差は10-8 a.u.まで許しています + - 実行するにはpytestをpython -m pip install pytestにより導入する必要があります + - pytestを導入したら + + ```sh + pytest + ``` + +を実行すれば自動的にテストが開始されます + +- mpiifortやmpif90,mpifortなどの並列コンパイラでかつビルド時に-DMPI=onオプションを有効にした場合、MPI並列用テストを行うことを推奨します。コマンドは以下の通りです + + ```sh + pytest --parallel=4 + ``` + +- また[Github Actions](https://github.co.jp/features/actions)を使うことで月50時間まではアップロード(push)された\*.f90,\*.F90,\*.cmake,CMakeLists.txt,\*.py,Github Actions用ファイルのいずれかが変更されたコミットに対して自動テストが走るようにし、意識しなくてもテストされている状態をつくりました。([.github/workflows/ci.ymlにGithub Actions用設定があります](https://github.com/kohei-noda-qcrg/dirac_caspt2/blob/main/.github/workflows/ci.yml)) +- CASPT2エネルギーのテストは複数の分子系で、できるだけ違うタイプのインプットを用いて、最初に基準と定めたアウトプットから**自動的に**(ここがテスト自動化の良い点です)判定する形式にしています + - このテストはいわゆる[統合試験](https://ja.wikipedia.org/wiki/%E3%82%BD%E3%83%95%E3%83%88%E3%82%A6%E3%82%A7%E3%82%A2%E3%83%86%E3%82%B9%E3%83%88#%E7%B5%B1%E5%90%88%E8%A9%A6%E9%A8%93_(Integration_Testing))です +- ツールはFortranのテストツールは機能が貧弱なので、pythonのpytestを用いました + - DIRACもpythonを用いてテストを書いています + - python側からビルドしたプログラムを実行し、アウトプットをリファレンス値と比較することで自動テストを実現します([testディレクトリ以下のpythonファイルを参照](https://github.com/kohei-noda-qcrg/dirac_caspt2/tree/main/test)してください) + +### ビルドについて + +- ビルドには[CMake](https://cmake.org/)を用います + - デフォルトのビルドの設定や、ビルドオプションの書き分け処理などは[このプロジェクトのルートディレクトリのCMakeLists.txt](https://github.com/kohei-noda-qcrg/dirac_caspt2/blob/main/CMakeLists.txt)に書きます + - 設定を追加したい場合は[公式ドキュメント](https://cmake.org/cmake/help/v3.7/)が正確でかなりわかりやすいので、"cmake やりたいこと"で検索してオプション名を見つけてから公式ドキュメントをみて追加することをお勧めします + +- ビルドオプションを変えるときは前のビルドを行ったディレクトリをディレクトリごと消してからビルドしてください + + 例えば以下のようにするとビルドオプションを再指定してからビルドされます + + ```sh + # Remove dir + rm -r build + # Reconfigure and rebuild and run test + FC=mpiifort cmake -DMPI=on -DOPENMP=on -B build && cmake --build build && pytest --parallel=4 + ``` + +- ビルドオプションは変えないもののビルド自体は最初からやり直したい場合は --clean-first オプションをつけると最初からビルドをやり直せます + + ```sh + cmake --build build --clean-first + ``` + ### 環境構築について #### relqc01のマシンにおいては[野田](https://github.com/kohei-noda-qcrg)がcmake、gitおよびDIRAC(19.0,21.1,22.0)の環境を用意しています @@ -359,6 +413,7 @@ export PS1='\[\033[01;32m\]\u@\h\[\033[01;34m\] \w\[\033[01;33m\]$(__git_ps1)\[\ - \$HOME/.bashrcにmodule use --append "/home/noda/modulefiles"を記述します - module load DIRAC/19.0 などと入力するとpam-diracコマンドが使えるようになります + - loadできるソフト一覧はmodule availで確認できます - DIRACのmoduleはDIRACを使うときだけ一時的にmodule loadすることをお勧めします - 従ってDIRACを実行する際は実行用のシェルスクリプト内でmodule loadすることを推奨します @@ -375,43 +430,4 @@ export PS1='\[\033[01;32m\]\u@\h\[\033[01;34m\] \w\[\033[01;33m\]$(__git_ps1)\[\ $PAM --mpi=$NPROCS --get="MRCONEE MDCIN*" '--keep_scratch' --mol=${MOLFILE} --inp=${INPFILE} --noarch &> $LOGFILE ``` -- 一旦モジュールの読み込みを解除したいときは module unload 解除したいモジュールの名前 を実行します - -### ビルドについて - -- デバッグ、リファクタリング時のビルドについて、何かおかしいと思ったら--clean-first オプションを用いて前のビルド結果を消してから再ビルドすることができます - - ```sh - cmake --build build --clean-first - ``` - -- ビルドには[CMake](https://cmake.org/)を用います - - ビルドの設定はCMakeLists.txtに書きます - - 設定を追加したい場合は[公式ドキュメント](https://cmake.org/cmake/help/v3.7/)が正確でかなりわかりやすいので、"cmake やりたいこと"で検索してオプション名を見つけてから公式ドキュメントをみて追加することをお勧めします - -### テストについて - -- テストを追加しました!まずはH2分子,STO-3G基底のみ追加しています。CASPT2エネルギーの誤差は10^-8まで許しています - - 実行するにはpytestをpython -m pip install pytestにより導入する必要があります - - pytestを導したら - - ```sh - pytest - ``` - -を実行すれば自動的にテストが開始されます -またmpiifortやmpif90,mpifortなどの並列コンパイラでかつビルド時に-DMPI=onオプションを有効にした場合、MPI並列用テストを以下のコマンドで行うことを推奨します - - ```sh - pytest --parallel=4 - ``` - - - また[github actions](https://github.co.jp/features/actions )を使うことで月50時間まではアップロード(push)されたすべてのコミットに対して自動テストが走るようにし、意識しなくてもテストされている状態をつくりました。 - -- 本来は[単体テスト](https://ja.wikipedia.org/wiki/%E5%8D%98%E4%BD%93%E3%83%86%E3%82%B9%E3%83%88)を用いてプログラムの部品レベルでテストを書くべきですが、本プログラムはテストを前提として書かれておらず[密結合](https://e-words.jp/w/%E5%AF%86%E7%B5%90%E5%90%88.html)のため[単体テストが書きづらい](https://qiita.com/yutachaos/items/857472c7d3c65d3cf316#%E5%8D%98%E4%BD%93%E3%83%86%E3%82%B9%E3%83%88-1)です -- 当面は複数の分子系で、できるだけ違うタイプのインプットを用いて、最初に基準と定めたアウトプットから**自動的に**(ここがテストの良い点です)判定する形式にする予定です - - 例えばCASPT2 energyが一定以上ずれていないかを判定するようにします - - いわゆる[統合試験](https://ja.wikipedia.org/wiki/%E3%82%BD%E3%83%95%E3%83%88%E3%82%A6%E3%82%A7%E3%82%A2%E3%83%86%E3%82%B9%E3%83%88#%E7%B5%B1%E5%90%88%E8%A9%A6%E9%A8%93_(Integration_Testing))のみを行います -- ツールはFortranのテストツールは機能が貧弱なので、pythonのpytestを用いました - - DIRACもpythonを用いてテストを書いています - - python側からビルドしたプログラムを実行し、アウトプットをリファレンス値と比較することで自動テストを実現します +- モジュールの読み込みを解除したいときは module unload 解除したいモジュールの名前 を実行します diff --git a/src/#test_abe.f90# b/src/#test_abe.f90# deleted file mode 100644 index a937fcf9..00000000 --- a/src/#test_abe.f90# +++ /dev/null @@ -1,323 +0,0 @@ -!++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ - -! Subroutine create_newmdcint ! 2 Electorn Integrals In Mdcint -program create_newmdcint - -! ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ - - Use four_caspt2_module - use omp_lib - - Implicit None - - Character*50 :: Filename - - Character :: datex*10, timex*8 - - integer :: nkr, nz - integer :: i0, mdcint, inz, nnz - integer :: ikr, jkr - integer :: ii, jj, kk, ll - integer :: iikr, jjkr, kkkr, llkr, iii, jjj, kkk, lll - integer, allocatable :: indk(:), indl(:), kr(:) - double precision, allocatable :: rklr(:), rkli(:) - ! Iwamuro modify - real :: cutoff - integer :: nnkr, ikr8, jkr8, iiit, jjjt, kkkt, lllt - integer, allocatable :: kkr(:), indk8(:), indl8(:) - real*8, allocatable :: rklr8(:), rkli8(:) - - integer :: i, loop = 0, omp_max, tid - Character*50 :: fileBaseName, mdcintBaseName, mdcintNew, mdcint_debug, mdcint_int, mdcintNum - - omp_max = omp_get_max_threads() - Allocate(kr(-nmo/2:nmo/2)) - kr = 0 - $omp parallel private(indk,indl,rklr,rkli,rklr8,rkli8,indk8,indl8,kkr,Filename,mdcintNew,mdcint_debug,datex,timex,nkr,ikr,jkr,nz,inz,realonly,iii,jjj,kkk,lll,iikr,jjkr,kkkr,llkr,nnkr,ikr8,jkr8,iiit,jjjt,kkkt,lllt,mdcint_int,mdcintNum) - - realonly = .false. - cutoff = 0.25D-12 - nnz = 1 - - tid = omp_get_thread_num() - - Allocate(indk(nmo**2)) - Allocate(indl(nmo**2)) - Allocate(rklr(nmo**2)) - Allocate(rkli(nmo**2)) - Allocate(rklr8(nmo**2)) - Allocate(rkli8(nmo**2)) - Allocate(indk8(nmo**2)) - Allocate(indl8(nmo**2)) - Allocate(kkr(-nmo/2:nmo/2)) - - kkr = 0 - nnkr = 0 - fileBaseName = "MDCINXXXX" - if (tid == 1) then - Filename = "MDCINT" - mdcintNew = "MDCINTNEW" - mdcint_debug = "MDCINT_debug" - mdcint_int = "MDCINT_int" - else - mdcintBaseName = "MDCINXXXX" - write(mdcintNum,"(I3)") tid-1 - Filename = TRIM(mdcintBaseName)//TRIM(ADJUSTL(mdcintNum)) - mdcintNew = "MDCINTNEW"//TRIM(ADJUSTL(mdcintNum)) - mdcint_debug = "MDCINT_debug"//TRIM(ADJUSTL(mdcintNum)) - mdcint_int = "MDCINT_int"//TRIM(ADJUSTL(mdcintNum)) - end if - ! mdcint=11 - open(tid+100, file=Filename, form ='unformatted', status='unknown') - ! open(mdcint, file=Filename, form ='unformatted', status='unknown') - ! open(mdcint, file="MDCINT", form ='unformatted', status='unknown') - if (tid == 1) then - read (tid+100) datex,timex,nkr,(kr(i0),kr(-1*i0),i0=1,nkr) - ! read (mdcint) datex,timex,nkr,(kr(i0),kr(-1*i0),i0=1,nkr) - else - read (tid+100) - ! read (mdcint) - end if - - read (tid+100,ERR=200) ikr,jkr, nz, (indk(inz),indl(inz), rklr(inz),rkli(inz), inz=1,nz) - ! read (mdcint,ERR=200) ikr,jkr, nz, (indk(inz),indl(inz), rklr(inz),rkli(inz), inz=1,nz) - - goto 201 - -200 realonly = .true. - write(*,*) "realonly = ", realonly -201 close(tid+100) -! 201 close(mdcint) - - ! open(mdcint, file="MDCINT", form='unformatted', status='unknown') - ! open(28, file="MDCINTNEW", form='unformatted', status='unknown') - ! open(29, file="MDCINT_debug", form='formatted', status='unknown') - ! open(30, file="MDCINT_int", form='formatted', status='unknown') - - open(tid+100, file=Filename, form='unformatted', status='unknown') - ! open(mdcint, file=Filename, form='unformatted', status='unknown') - open(tid+200, file=mdcintNew, form='unformatted', status='unknown') - open(tid+300, file=mdcint_debug, form='formatted', status='unknown') - ! open(30, file=mdcint_int, form='formatted', status='unknown') - if (tid == 1) then - read (tid+100) datex,timex,nkr, (kr(i0),kr(-1*i0),i0=1,nkr) - else - read(tid+100) - end if - write(tid+300,*) i,datex,timex,nkr, (kr(i0),kr(-1*i0),i0=1,nkr) - nnkr = nkr - kkr(:) = kr(:) - - ! write(28) datex, timex, nnkr, (kkr(i0),kkr(-1*i0),i0=1,nnkr) - ! write(29,*) datex, timex, nnkr, (kkr(i0),kkr(-1*i0),i0=1,nnkr) -!Iwamuro debug - ! write(*,*) "new_ikr1", datex, timex, nkr, (kr(i0),kr(-1*i0),i0=1,nkr) - ! write(*,*) Filename - -100 if (realonly) then - read (tid+100,end=1000) ikr,jkr, nz, & - (indk(inz),indl(inz),inz=1,nz), & - (rklr(inz), inz=1,nz) - rkli = 0.0d+00 - else - read (tid+100,end=1000) ikr,jkr, nz, & - (indk(inz),indl(inz),inz=1,nz), & - (rklr(inz),rkli(inz), inz=1,nz) - endif -! Debug output - ! write(*,*) "" - ! write(*,*) ikr,jkr, nz, & - ! (indk(inz),indl(inz),inz=1,nz), & - ! (rklr(inz),rkli(inz), inz=1,nz) - - ! write(*,*) "" - loop = loop + 1 -! Debug output end -!------------------------------------------------------------ - -!------------------------------! -! Create new ikr for UTChem ! -!------------------------------! - -! new ikr = iikr -! jkr = jjkr -! kkr = kkkr -! lkr = llkr - -! Do inz = 1,nz - - if (ikr<0) go to 100 - if (ikr == 0) then - write(20,*)ikr,jkr,nz,mdcint_debug,loop,i - write(tid+200) 0, 0, 0 - ! write(29,'(3I4)') 0, 0, 0 - ! write(30,'(3I4)') 0, 0, 0 - go to 1000 - endif - - ikr8 = ikr - jkr8 = jkr - indk8(:) = indk(:) - indl8(:) = indl(:) - rklr8(:) = rklr(:) - rkli8(:) = rkli(:) - - Do inz = 1,nz - ! Debug output (if write(*,*)) - if (inz == 1) then - ! write(*,*)"new_ikr2" - ! write(*,*)"Filename:", Filename - ! write(*,*)"inz:", inz - endif - iii = indmor(kr(ikr8)) - if (i == 2 .and. inz == 1) then - write(*,*) "iii",ikr,ikr8,iii,(-1)**(mod(iii,2)+1)*(iii/2+mod(iii,2)) - write(*,*) "kr(ikr)", kr(ikr8) - write(*,*) "indmor(kr(ikr))", indmor(kr(ikr)) - endif - - jjj = indmor(kr(jkr8)) - if (inz == 1) then - ! write(*,*) "kr(jkr)", kr(jkr) - ! write(*,*) "indmor(kr(jkr))", indmor(kr(jkr)) - endif - - kkk = indmor(kr(indk8(inz))) - if (inz == 1) then - ! write(*,*) "indk(inz)", indk(inz) - ! write(*,*) "kr(indk(inz))", kr(indk(inz)) - ! write(*,*) "indmor(kr(indk(inz)))", indmor(kr(indk(inz))) - endif - - lll = indmor(kr(indl8(inz))) - if (inz == 1) then - ! write(*,*) "indl(inz)", indl(inz) - ! write(*,*) "kr(indl(inz))", kr(indl(inz)) - ! write(*,*) "indmor(kr(indl(inz)))", indmor(kr(indl(inz))) - endif - - iikr = (-1)**(mod(iii,2)+1)*(iii/2+mod(iii,2)) - jjkr = (-1)**(mod(jjj,2)+1)*(jjj/2+mod(jjj,2)) - kkkr = (-1)**(mod(kkk,2)+1)*(kkk/2+mod(kkk,2)) - llkr = (-1)**(mod(lll,2)+1)*(lll/2+mod(lll,2)) - - iiit = iii-(-1)**iii - jjjt = jjj-(-1)**jjj - kkkt = kkk-(-1)**kkk - lllt = lll-(-1)**lll - - -! Iwamuro debug - if (inz == 1) then - ! write(*,*) "new_ikr2", iikr, jjkr, kkkr, llkr - endif -! Debug output end (if write(*,*)) - -!------------------------------------------------------------ - - ii = abs(iikr) - jj = abs(jjkr) - kk = abs(kkkr) - ll = abs(llkr) - - !--------------------------- - ! TYPE1 (++++) = (ij|kl) - ! TYPE2 (+-+-) = (ij~|kl~) - ! TYPE3 (+--+) = (ij~|k~l) - ! TYPE4 (+---) = (ij~|k~l~) - !--------------------------- - - If(iikr>0 .and. jjkr>0 .and. kkkr>0 .and. llkr>0) then !TYPE1 - if( (ii<=jj .and. kk<=ll .and. (iicutoff.or. & - abs(rkli(inz))>cutoff ) then -! write(28) -ikr,-jkr,nnz,-(indk(inz)),-(indl(inz)),rklr(inz),-(rkli(inz)) -! write(28) -iikr,-jjkr,nnz,-kkkr,-llkr,rklr8(inz),-(rkli8(inz)) - write(tid+200) iiit,jjjt,nnz,kkkt,lllt,rklr8(inz),-(rkli8(inz)) - ! write(29,'(5I4,2E32.16)') -iikr,-jjkr,nnz,-kkkr,-llkr,rklr(inz),-(rkli(inz)) - ! else - ! write(29,'(a6,5I4,2E32.16)')'else1',-iikr,-jjkr,nnz,-kkkr,-llkr,rklr(inz),-(rkli(inz)) - ! write(30,'(5I4,2E32.16)') iiit,jjjt,nnz,kkkt,lllt,rklr8(inz),-(rkli8(inz)) - endif - endif - - Else if (iikr>0 .and. jjkr<0 .and. kkkr>0 .and. llkr<0) then !TYPE2 - if (ii<=jj .and. kk<=ll .and. (iicutoff.or. & - abs(rkli(inz))>cutoff ) then -! write(28) -ikr,-jkr,nnz,-(indk(inz)),-(indl(inz)),rklr(inz),-(rkli(inz)) -! write(28) -iikr,-jjkr,nnz,-kkkr,-llkr,rklr8(inz),-(rkli8(inz)) - write(tid+200) iiit,jjjt,nnz,kkkt,lllt,rklr8(inz),-(rkli8(inz)) - ! write(29,'(5I4,2E32.16)') -iikr,-jjkr,nnz,-kkkr,-llkr,rklr(inz),-(rkli(inz)) - ! write(30,'(5I4,2E32.16)') iiit,jjjt,nnz,kkkt,lllt,rklr8(inz),-(rkli8(inz)) - ! else - ! write(29,'(a6,5I4,2E32.16)')'else2',-iikr,-jjkr,nnz,-kkkr,-llkr,rklr(inz),-(rkli(inz)) - endif - endif - - Else if (iikr>0 .and. jjkr<0 .and. kkkr<0 .and. llkr>0) then !TYPE3 - if(ii<=jj .and. kk<=ll .and. (iicutoff.or. & - abs(rkli(inz))>cutoff ) then -! write(28) -ikr,-jkr,nnz,-(indk(inz)),-(indl(inz)),rklr(inz),-(rkli(inz)) -! write(28) -iikr,-jjkr,nnz,-kkkr,-llkr,rklr8(inz),-(rkli8(inz)) - write(tid+200) iiit,jjjt,nnz,kkkt,lllt,rklr8(inz),-(rkli8(inz)) - ! write(29,'(5I4,2E32.16)') -iikr,-jjkr,nnz,-kkkr,-llkr,rklr(inz),-(rkli(inz)) - ! write(30,'(5I4,2E32.16)') iiit,jjjt,nnz,kkkt,lllt,rklr8(inz),-(rkli8(inz)) - ! else - ! write(29,'(a6,5I4,2E32.16)')'else3',-iikr,-jjkr,nnz,-kkkr,-llkr,rklr(inz),-(rkli(inz)) - endif - endif - - Else if (iikr>0 .and. jjkr<0 .and. kkkr<0 .and. llkr<0) then !TYPE4 - if(ii<=jj) then - if(abs(rklr(inz))>cutoff.or. & - abs(rkli(inz))>cutoff ) then -! write(28) -ikr,-jkr,nnz,-(indk(inz)),-(indl(inz)),rklr(inz),-(rkli(inz)) -! write(28) -iikr,-jjkr,nnz,-kkkr,-llkr,rklr8(inz),-(rkli8(inz)) - write(tid+200) iiit,jjjt,nnz,kkkt,lllt,rklr8(inz),-(rkli8(inz)) - ! write(29,'(5I4,2E32.16)') -iikr,-jjkr,nnz,-kkkr,-llkr,rklr(inz),-(rkli(inz)) - ! write(30,'(5I4,2E32.16)') iiit,jjjt,nnz,kkkt,lllt,rklr8(inz),-(rkli8(inz)) - ! else - ! write(29,'(a6,5I4,2E32.16)')'else4',-iikr,-jjkr,nnz,-kkkr,-llkr,rklr(inz),-(rkli(inz)) - endif - endif - ! else - ! write(28,'(a6,5I4,2E32.16)')'else',-iikr,-jjkr,nnz,-kkkr,-llkr,rklr(inz),-(rkli(inz)) - Endif -300 Enddo - - go to 100 - -!--------------------------------- UTChem integral translation------------------------------------ -!TYPE1 If( ((p10<=p20.and.p30<=p40.and.(p10 thres) then - realcvec = .false. - end if - end do - - do irec = 1, nroot - write (*, '("Root = ",I4)') irec - do j = 1, ndet - if ((ABS(mat(j, irec))**2) > 1.0d-02) then - i0 = idet(j) - write (*, *) (btest(i0, j0), j0=0, nact - 1) - write (*, '(I4,2(3X,E14.7)," Weights ",E14.7)') & - & j, mat(j, irec), & - & ABS(mat(j, irec))**2 - end if - end do - end do - - Deallocate (mat); Call memminus(KIND(mat), SIZE(mat), 2) - -1000 end subroutine casci - -! ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ - - FUNCTION comb(n, m) RESULT(res) - -! ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ - - Implicit NONE - - integer :: n, m, i, j, res, m0 - - j = 1 - - if (n - m < m) then - m0 = n - m - else - m0 = m - end if - - Do i = n - m0 + 1, n - j = j*i - End do - - Do i = 1, m0 - j = j/i - End do - - res = j -1000 end function comb diff --git a/src/casci_ty.f90 b/src/casci_ty.f90 index d97d7644..f8cd95a4 100644 --- a/src/casci_ty.f90 +++ b/src/casci_ty.f90 @@ -4,6 +4,7 @@ SUBROUTINE casci_ty ! ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ + use module_file_manager use four_caspt2_module Implicit NONE #ifdef HAVE_MPI @@ -63,15 +64,15 @@ SUBROUTINE casci_ty ! Print out CI matrix! if (rank == 0) then ! Only master ranks are allowed to create files used by CASPT2 except for MDCINTNEW. print *, 'debug1' - cimat = 10 + cimat = default_unit filename = 'CIMAT' - open (10, file='CIMAT', status='unknown', form='unformatted') - write (10) ndet - write (10) idet(1:ndet) - write (10) ecas(1:ndet) - write (10) 2**nact - 1 ! idetrの配列の要素数 - write (10) idetr(1:2**nact - 1) - close (10) + call open_unformatted_file(unit=cimat, file=filename, status='replace') + write (cimat) ndet + write (cimat) idet(1:ndet) + write (cimat) ecas(1:ndet) + write (cimat) 2**nact - 1 ! idetrの配列の要素数 + write (cimat) idetr(1:2**nact - 1) + close (cimat) ! Print out C1 matrix! @@ -79,14 +80,14 @@ SUBROUTINE casci_ty print *, 'debug2' - cimat = 10 + cimat = default_unit filename = 'CIMAT1' - open (10, file='CIMAT1', status='unknown', form='unformatted') - write (10) ndet - write (10) idet(1:ndet) - write (10) ecas(1:ndet) - write (10) mat(1:ndet, 1:ndet) - close (10) + call open_unformatted_file(unit=cimat, file=filename, status='replace') + write (cimat) ndet + write (cimat) idet(1:ndet) + write (cimat) ecas(1:ndet) + write (cimat) mat(1:ndet, 1:ndet) + close (cimat) end if ! Print out C1 matrix! @@ -159,4 +160,4 @@ FUNCTION comb(n, m) RESULT(res) End do res = j -1000 end function comb +end function comb diff --git a/src/casdet.f90 b/src/casdet.f90 deleted file mode 100644 index cab1e4ea..00000000 --- a/src/casdet.f90 +++ /dev/null @@ -1,67 +0,0 @@ -! ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ - - SUBROUTINE casdet(totsym) - -! ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ - - use four_caspt2_module - - Implicit NONE - - integer, intent(in) :: totsym - - integer :: nbitsa - integer :: i, isym - integer, allocatable :: idet0(:) - - Allocate (idet0(ndet)) - idet0 = 0 - ndet = 0 - - Do i = 1, 2**nact - 1 - if (nbitsa(i) == nelec) then - Call detsym(i, isym) -! if((nsymrpa == 1.and.((isym == totsym).or.(isym == totsym-1))).or. & - if ((nsymrpa == 1) .or. & - (nsymrpa /= 1 .and. (isym == totsym))) then - ndet = ndet + 1 - idet0(ndet) = i - End if - End if - End do - - Allocate (idet(ndet)) - idet(1:ndet) = idet0(1:ndet) - write (*, *) 'totsym = ', totsym - write (*, *) 'ndet = ', ndet -! write(*,*)idet(1:ndet) - Deallocate (idet0) - -1000 end subroutine casdet - -! ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ - - SUBROUTINE detsym(ii, isym) - -! ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ - - use four_caspt2_module - - Implicit NONE - - integer, intent(in) :: ii - integer, intent(out) :: isym - - integer :: i, j, jsym - - isym = nsymrpa + 1 - - Do i = 1, nact - if (btest(ii, i - 1) .eqv. .true.) then - j = i + ninact - jsym = irpamo(j) - isym = MULTB(jsym, isym) - End if - End do - -1000 end subroutine detsym diff --git a/src/casdet_ty_utchem.f90 b/src/casdet_ty_utchem.f90 deleted file mode 100644 index 82d09e95..00000000 --- a/src/casdet_ty_utchem.f90 +++ /dev/null @@ -1,91 +0,0 @@ -! ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ - -SUBROUTINE casdet_ty(totsym) - -! ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ - - use four_caspt2_module - - Implicit NONE - - integer, intent(in) :: totsym - - integer :: nbitsa - integer :: i, isym - integer, allocatable :: idet0(:) - - write (*, *) 'Enter casdet_ty' - Allocate (idet0(ndet)) - idet0 = 0 - ndet = 0 - - Do i = 1, 2**nact - 1 - if (nbitsa(i) == nelec) then - if (trim(ptgrp) == 'C1') then - ndet = ndet + 1 - idet0(ndet) = i - else - Call detsym_ty(i, isym) - if (isym == totsym) then - ndet = ndet + 1 - idet0(ndet) = i - end if - End if - End if - End do - - Allocate (idet(ndet)) - idet(1:ndet) = idet0(1:ndet) - write (*, *) 'totsym = ', totsym - write (*, *) 'ndet = ', ndet -! write(*,*)idet(1:ndet) - Deallocate (idet0) - -1000 end subroutine casdet_ty - -! ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ - -SUBROUTINE detsym_ty(ii, isym) - -! ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ - - use four_caspt2_module - - Implicit NONE - - integer, intent(in) :: ii - integer, intent(out) :: isym - - integer :: i, j, jsym, ielec, isym1 - - isym = 1 - ielec = 0 - Do i = 1, nact - if (btest(ii, i - 1) .eqv. .true.) then - ielec = ielec + 1 - j = i + ninact - jsym = irpamo(j) - if (mod(ielec, 2) == 1) then - isym1 = MULTB_DS(jsym, isym) ! isym will be double irrep: odd number of electron - if (isym1 > nsymrp) write (*, *) 'ielec, ii, isym, jsym, isym1', ielec, ii, isym, jsym + 1, isym1 - - isym = isym1 - else - if (mod(jsym, 2) == 1) then - isym1 = MULTB_D(jsym + 1, isym) ! isym will be single irrep: even number of electron !MULTB_D is (fai*|fai) - if (isym1 > nsymrp) write (*, *) 'ielec, ii, isym, jsym+1, isym1', ielec, ii, isym, jsym + 1, isym1 - - isym = isym1 - else - isym1 = MULTB_D(jsym - 1, isym) ! isym will be single irrep: even number of electron - if (isym1 > nsymrp) write (*, *) 'ielec, ii, isym, jsym-1, isym1', ielec, ii, isym, jsym - 1, isym1 - - isym = isym1 - end if - end if - - End if - End do - If (mod(ielec, 2) == 0) isym = isym + nsymrp ! even number electronic system - -1000 end subroutine detsym_ty diff --git a/src/create_binmdcint.f90 b/src/create_binmdcint.f90 index 81b41eaf..227b44db 100644 --- a/src/create_binmdcint.f90 +++ b/src/create_binmdcint.f90 @@ -4,6 +4,7 @@ Subroutine create_newmdcint ! 2 Electorn Integrals In Mdcint ! ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ + use module_file_manager Use four_caspt2_module ! use omp_lib Implicit None @@ -21,9 +22,10 @@ Subroutine create_newmdcint ! 2 Electorn Integrals In Mdcint real :: cutoff integer :: nnkr, iiit, jjjt, kkkt, lllt integer :: nkr, nz, file_idx, iostat - integer, parameter :: mdcint_unit_num = 100, mdcintnew_unit_num = 200 - logical :: is_file_exist + integer :: mdcint_unit, mdcintnew_unit + logical :: is_file_exist, is_end_of_file + mdcint_unit = default_unit; mdcintnew_unit = default_unit Call timing(date1, tsec1, date0, tsec0) date1 = date0 tsec1 = tsec0 @@ -31,10 +33,9 @@ Subroutine create_newmdcint ! 2 Electorn Integrals In Mdcint kr = 0 ! Get datex, timex, nkr, and kr from MDCINT becasuse there is no kr information in the MDCINXXX files. if (rank == 0) then - ! open (8, file="debug", form="formatted", status="unknown") - open (10, file="MDCINT", form="unformatted", status="unknown") - read (10) datex, timex, nkr, (kr(i0), kr(-1*i0), i0=1, nkr) - close (10) + call open_unformatted_file(unit=mdcint_unit, file="MDCINT", status="old", optional_action="read") + read (mdcint_unit) datex, timex, nkr, (kr(i0), kr(-1*i0), i0=1, nkr) + close (mdcint_unit) end if Allocate (indk(nmo**2)) Allocate (indl(nmo**2)) @@ -80,8 +81,8 @@ Subroutine create_newmdcint ! 2 Electorn Integrals In Mdcint ! First, All process write header information to MDCINTNEWrank call get_mdcint_filename(file_idx) - open (mdcintnew_unit_num, file=mdcintNew, form='unformatted', status='replace') - write (mdcintnew_unit_num) datex, timex, nkr, (kr(i0), kr(-1*i0), i0=1, nkr) + call open_unformatted_file(unit=mdcintnew_unit, file=mdcintNew, status="replace", optional_action="write") + write (mdcintnew_unit) datex, timex, nkr, (kr(i0), kr(-1*i0), i0=1, nkr) is_file_exist = .true. do while (is_file_exist) ! Continue reading 2-electron integrals until mdcint_filename doesn't exist. @@ -89,20 +90,18 @@ Subroutine create_newmdcint ! 2 Electorn Integrals In Mdcint inquire (file=mdcint_filename, exist=is_file_exist) ! mdcint_filename exists? if (.not. is_file_exist) exit ! Exit do while loop if mdcint_filename doesn't exist. - open (mdcint_unit_num, file=mdcint_filename, form='unformatted', status='unknown') - read (mdcint_unit_num) + call open_unformatted_file(unit=mdcint_unit, file=mdcint_filename, status="old", optional_action="read") + read (mdcint_unit) - read (mdcint_unit_num, iostat=iostat) ikr, jkr, nz, (indk(inz), indl(inz), rklr(inz), rkli(inz), inz=1, nz) + read (mdcint_unit, iostat=iostat) ikr, jkr, nz, (indk(inz), indl(inz), rklr(inz), rkli(inz), inz=1, nz) if (iostat == 0) then ! 2-integral values are complex numbers if iostat == 0 realonly = .false. ! Complex else ! 2-integral values are only real numbers if iostat /= 0 realonly = .true. ! Real if (rank == 0) print *, "realonly = ", realonly end if - close (mdcint_unit_num) - - open (mdcint_unit_num, file=mdcint_filename, form='unformatted', status='unknown') - read (mdcint_unit_num) + rewind (mdcint_unit) + read (mdcint_unit) nnkr = nkr rkli = 0.0d+00 @@ -113,25 +112,18 @@ Subroutine create_newmdcint ! 2 Electorn Integrals In Mdcint ! Continue to read 2-electron integrals until mdcint_filename reaches the end of file. mdcint_file_read: do if (realonly) then - read (mdcint_unit_num, iostat=iostat) ikr, jkr, nz, & + read (mdcint_unit, iostat=iostat) ikr, jkr, nz, & (indk(inz), indl(inz), inz=1, nz), & (rklr(inz), inz=1, nz) else - read (mdcint_unit_num, iostat=iostat) ikr, jkr, nz, & + read (mdcint_unit, iostat=iostat) ikr, jkr, nz, & (indk(inz), indl(inz), inz=1, nz), & (rklr(inz), rkli(inz), inz=1, nz) end if - ! iostat is less than 0 if end-of-file is reached. - if (iostat < 0) then - if (rank == 0) print *, "end-of-file reached." + call check_iostat(iostat=iostat, file=mdcint_filename, end_of_file_reached=is_end_of_file) + if (is_end_of_file) then exit mdcint_file_read - else if (iostat > 0) then - if (rank == 0) then - ! Error in reading 2-electron integrals. - print *, "error in reading 2-electron integrals. Filename", mdcint_filename - end if - stop end if !------------------------------! @@ -202,7 +194,7 @@ Subroutine create_newmdcint ! 2 Electorn Integrals In Mdcint (ii <= jj .and. ll <= kk .and. (ii < ll .or. (ii == ll .and. jj <= kk)))) then if (abs(rklr(inz)) > cutoff .or. & abs(rkli(inz)) > cutoff) then - write (200) iiit, jjjt, nnz, kkkt, lllt, rklr(inz), -(rkli(inz)) + write (mdcintnew_unit) iiit, jjjt, nnz, kkkt, lllt, rklr(inz), -(rkli(inz)) end if end if @@ -210,7 +202,7 @@ Subroutine create_newmdcint ! 2 Electorn Integrals In Mdcint if (ii <= jj .and. kk <= ll .and. (ii < kk .or. (ii == kk .and. jj <= ll))) then if (abs(rklr(inz)) > cutoff .or. & abs(rkli(inz)) > cutoff) then - write (200) iiit, jjjt, nnz, kkkt, lllt, rklr(inz), -(rkli(inz)) + write (mdcintnew_unit) iiit, jjjt, nnz, kkkt, lllt, rklr(inz), -(rkli(inz)) end if end if @@ -218,7 +210,7 @@ Subroutine create_newmdcint ! 2 Electorn Integrals In Mdcint if (ii <= jj .and. kk <= ll .and. (ii < kk .or. (ii == kk .and. jj <= ll))) then if (abs(rklr(inz)) > cutoff .or. & abs(rkli(inz)) > cutoff) then - write (200) iiit, jjjt, nnz, kkkt, lllt, rklr(inz), -(rkli(inz)) + write (mdcintnew_unit) iiit, jjjt, nnz, kkkt, lllt, rklr(inz), -(rkli(inz)) end if end if @@ -226,7 +218,7 @@ Subroutine create_newmdcint ! 2 Electorn Integrals In Mdcint if (ii <= jj) then if (abs(rklr(inz)) > cutoff .or. & abs(rkli(inz)) > cutoff) then - write (200) iiit, jjjt, nnz, kkkt, lllt, rklr(inz), -(rkli(inz)) + write (mdcintnew_unit) iiit, jjjt, nnz, kkkt, lllt, rklr(inz), -(rkli(inz)) end if end if End if @@ -245,12 +237,12 @@ Subroutine create_newmdcint ! 2 Electorn Integrals In Mdcint ! .or. (isp/=isq) ) then !------------------------------------------------------------------------------------------------- - close (mdcint_unit_num) + close (mdcint_unit) file_idx = file_idx + 1 end do - write (mdcintnew_unit_num) 0, 0, 0 - close (mdcintnew_unit_num) + write (mdcintnew_unit) 0, 0, 0 + close (mdcintnew_unit) Call timing(date1, tsec1, date0, tsec0) date1 = date0 tsec1 = tsec0 diff --git a/src/create_mdcint b/src/create_mdcint deleted file mode 100644 index 14dcec51..00000000 --- a/src/create_mdcint +++ /dev/null @@ -1,102 +0,0 @@ -!++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ -Program create_newmdcint ! 2 Electorn Integrals In Mdcint - -! ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ - - Implicit None - - Character*50 :: Filename - - Character :: Datex*10, Timex*8 - -! Integer :: Mdcint, Nkr, idum, nuniq, nmom, nmoc - integer(4) :: nkr, idum - integer :: mdcint, nuniq, nmom, nmoc -! integer :: nz, type - integer(4) :: nz - integer :: type - integer :: j0, i0, i1 - integer :: k0, l0, ii, jj, kk, ll, signind -! integer :: i, j, k, l, ikr, jkr, lkr, kkr, jtr0, itr0 - integer :: i, j, k, l, lkr, kkr, jtr0, itr0 - integer(4) :: ikr, jkr - integer :: SignIJ, SignKL, itr, jtr, ltr, ktr, inz, totalint, save, count - - complex*16 :: cint2 - -! integer, allocatable :: indk(:), indl(:), kr(:) - integer(4), allocatable :: indk(:), indl(:), kr(:) - -! real*8, allocatable :: rklr(:), rkli(:), int2rs(:), int2is(:) - - double precision, allocatable :: rklr(:), rkli(:) - -!From Module - integer :: ninact, nact, nsec - integer(4) :: nmo - real*8 :: tmem - -! integer, allocatable :: indtwr(:,:,:,:), indtwi(:,:,:,:) - - - nmoc = ninact + nact - nmom = ninact + nact + nsec - - Allocate(kr(-nmo/2:nmo/2)) ; Call memplus(KIND(kr) ,SIZE(kr) ,1) -! Allocate(indtwr(nmoc,nmoc,nmoc,nmoc)); Call memplus(KIND(indtwr),SIZE(indtwr),1) -! Allocate(indtwi(nmoc,nmoc,nmoc,nmoc)); Call memplus(KIND(indtwi),SIZE(indtwi),1) - - - kr = 0 - - - Allocate(indk(nmo**2)); Call memplus(KIND(indk),SIZE(indk),1) - Allocate(indl(nmo**2)); Call memplus(KIND(indl),SIZE(indl),1) - Allocate(rklr(nmo**2)); Call memplus(KIND(rklr),SIZE(rklr),1) - Allocate(rkli(nmo**2)); Call memplus(KIND(rkli),SIZE(rkli),1) - - - write(*,'("Current Memory is ",F10.2,"MB")')tmem/1024/1024 - - nuniq = 0 - indk(:) = 0 - indl(:) = 0 - rklr(:) = 0.0d+00 - rkli(:) = 0.0d+00 - - kr = 0 - - totalint = 0 - mdcint=11 - open( mdcint, file="openmdcint",form ='unformatted', status='unknown') - - read (mdcint) datex,timex,nkr, & - (kr(i0),kr(-1*i0),i0=1,nkr) - - open(28, file="MDCINTNEW", form ='unformatted', status='unknown') - - write(28) datex,timex,nkr, (kr(i0),kr(-1*i0),i0=1,nkr) - - write(28) -1, -1, 2, & - -1, -1, -2, -2, & - 7.30922279623399E-01, 6.78054083350211E-01 - - write(28) -1, -2, 2, & - -1, -2, -2, -1, & - -2.13224997405787E-01, 2.13224997405787E-01 - - write(28) -1, 2, 1, & - 1, -2, & - -2.20546608583155E-11 - - write(28) -2, -2, 1, & - -2, -2, & - 6.74991362063673E-01 - - write(28) 0, 0, 0 - - close(mdcint) - close(28) - -end Program create_newmdcint - diff --git a/src/diag.f90 b/src/diag.f90 index 3c31689f..bca97151 100644 --- a/src/diag.f90 +++ b/src/diag.f90 @@ -75,7 +75,6 @@ SUBROUTINE rdiag(sr, dimn, dimm, w, thresd, cutoff) dimm = dimn end if -1000 continue end subroutine rdiag ! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= diff --git a/src/e0after_tra.f90 b/src/e0after_tra.f90 deleted file mode 100644 index 3f72a21b..00000000 --- a/src/e0after_tra.f90 +++ /dev/null @@ -1,699 +0,0 @@ -! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= -! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= - - SUBROUTINE e0aftertra - -! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= -! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= - - use four_caspt2_module - - Implicit NONE - - integer :: ii, jj, kk, ll, typetype - integer :: j0, j, i, k, l, i0, i1, nuniq - integer :: k0, l0, nint - logical :: test - - real*8 :: i2r, i2i, dr, di, nsign - complex*16 :: oneeff, cmplxint, dens, energyHF(2) - complex*16, allocatable :: energy(:, :) - -! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= -! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= - - write (*, *) 'EIGEN(1)', eigen(1) - - Allocate (energy(nroot, 4)) - energy(1:nroot, 1:4) = 0.0d+00 - - debug = .FALSE. - thres = 1.0d-15 -! thres = 0.0d+00 - - open (5, file='e0after', status='unknown', form='unformatted') - -! AT PRESENT, CODE OF COMPLEX TYPE EXISTS ! - - write (*, *) 'iroot = ', iroot - -! Do iroot = 1, nroot - -! Do iroot = 1, 1 - -!CCCCCCCCCCCCCCCCCCCCCCCCCCCCC! -! energy HF1 ! -!"""""""""""""""""""""""""""""! -! One-electron sumation ! -! ! -! Inactive (core) part ! -! ! -!CCCCCCCCCCCCCCCCCCCCCCCCCCCCC! -!""""""""""""""""""""""""""""" - energyHF(1) = 0.0d+00 - - do i = 1, ninact + nelec - - cmplxint = 0.0d+00 - - Call tramo1(i, i, cmplxint) -! write(*,'(I4,E20.10)')i,DBLE(cmplxint) - energyHF(1) = energyHF(1) + cmplxint - - end do - -! write(*,*)'energyHF(1)',energyHF(1) - -!CCCCCCCCCCCCCCCCCCCCCCCCCCCCC! -! energy HF2 ! -!"""""""""""""""""""""""""""""! 1/2*[(rr|tt)-(rt|tr)} -! Two-electron sumation ! -! ! for inactive r and t -! Inactive (core) part ! -! ! -!CCCCCCCCCCCCCCCCCCCCCCCCCCCCC! -!""""""""""""""""""""""""""""" - energyHF(2) = 0.0d+00 - - do i = 1, ninact + nelec - do j = i, ninact + nelec - - Call tramo2(i, i, j, j, cmplxint) - - energyHF(2) = energyHF(2) + (0.5d+00)*cmplxint - - Call tramo2(i, j, j, i, cmplxint) - - energyHF(2) = energyHF(2) - (0.5d+00)*cmplxint - - end do - end do - - energyHF(2) = energyHF(2) + CONJG(energyHF(2)) - -! write(*,*)'energyHF(2)',energyHF(2) - -!CCCCCCCCCCCCCCCCCCCCCCCCCCCCC! -! energy 1 ! -!"""""""""""""""""""""""""""""! -! One-electron sumation ! -! ! -! Inactive (core) part ! -! ! -!CCCCCCCCCCCCCCCCCCCCCCCCCCCCC! -!""""""""""""""""""""""""""""" - do i = 1, ninact - - Call tramo1(i, i, cmplxint) - - energy(iroot, 1) = energy(iroot, 1) + cmplxint - - end do - -!CCCCCCCCCCCCCCCCCCCCCCCCCCCCC! -! energy 2 ! -!"""""""""""""""""""""""""""""! 1/2*[(rr|tt)-(rt|tr)} -! Two-electron sumation ! -! ! for inactive r and t -! Inactive (core) part ! -! ! -!CCCCCCCCCCCCCCCCCCCCCCCCCCCCC! -!""""""""""""""""""""""""""""" - do i = 1, ninact - do j = i, ninact - - Call tramo2(i, i, j, j, cmplxint) - - energy(iroot, 2) = energy(iroot, 2) + (0.5d+00)*cmplxint - - Call tramo2(i, j, j, i, cmplxint) - - energy(iroot, 2) = energy(iroot, 2) - (0.5d+00)*cmplxint - - end do - end do - - energy(iroot, 2) = energy(iroot, 2) + CONJG(energy(iroot, 2)) - -!CCCCCCCCCCCCCCCCCCCCCCCCCCCCC! -! energy 3 ! -!"""""""""""""""""""""""""""""! -! One-electron sumation ! -! ! hij + siguma [ (kk|ij)-(kj|ik) ] -! Active part ! k -! ! -! With effective one-e-int ! hij + siguma [ (ij|kk)-(ik|kj) ] -! ! k -!CCCCCCCCCCCCCCCCCCCCCCCCCCCCC! -!""""""""""""""""""""""""""""" - do i = ninact + 1, ninact + nact - do j = i, ninact + nact - - oneeff = 0.0d+00 - - do k = 1, ninact ! kk is inactive spinor - - Call tramo2(i, j, k, k, cmplxint) - - oneeff = oneeff + cmplxint - - Call tramo2(i, k, k, j, cmplxint) - - oneeff = oneeff - cmplxint - -300 end do ! k - - Call tramo1(i, j, cmplxint) - - oneeff = oneeff + cmplxint - -!___________________________________________________________! - ! - if (i == j) oneeff = 0.5d+00*oneeff ! -!___________________________________________________________! - - if (realcvec) then - - ii = i - ninact - jj = j - ninact - Call dim1_density_R(ii, jj, dr) - - energy(iroot, 3) = energy(iroot, 3) + oneeff*dr - - else - ii = i - ninact - jj = j - ninact - Call dim1_density(ii, jj, dr, di) - - dens = CMPLX(dr, di, 16) -! write(*,'(2I4,2E20.10)') i, j,DBLE(oneeff), DBLE(dens) - energy(iroot, 3) = energy(iroot, 3) + oneeff*dens - - end if - end do - end do - - energy(iroot, 3) = energy(iroot, 3) + CONJG(energy(iroot, 3)) - -!CCCCCCCCCCCCCCCCCCCCCCCCCCCCC! -! energy 4 ! -!"""""""""""""""""""""""""""""! 1/2*[(ij|kl)<0|EijEkl|0>-delta(jk)(ij|jl)<0|Eil|0>} -! Two-electron sumation ! -! ! i,j,k and l are active spinors -! active part ! -! ! -!CCCCCCCCCCCCCCCCCCCCCCCCCCCCC! -!""""""""""""""""""""""""""""" - - do i = ninact + 1, ninact + nact - do j = ninact + 1, ninact + nact - do k = ninact + 1, ninact + nact - do l = i, ninact + nact - -! if((i < ninact+3).and.(j < ninact+3).and.(k < ninact+3).and.(l < ninact+3)) then -! debug = .TRUE. ; write(*,*) i,j,k,l -! else -! debug = .FALSE. -! endif - - Call tramo2(i, j, k, l, cmplxint) - - If (i == l) cmplxint = cmplxint*(0.5d+00) - - if (realcvec) then - ii = i - ninact - jj = j - ninact - kk = k - ninact - ll = l - ninact - - Call dim2_density_R(ii, jj, kk, ll, dr) - - energy(iroot, 4) = energy(iroot, 4) & - + (0.5d+00)*dr*cmplxint - else - ii = i - ninact - jj = j - ninact - kk = k - ninact - ll = l - ninact - - Call dim2_density(ii, jj, kk, ll, dr, di) - - dens = CMPLX(dr, di, 16) - -! if(iroot==1) write(*,'(4I3,2E20.10)') i, j,k,l,DBLE(cmplxint), DBLE(dens) - if (iroot == 1) write (5) i, j, k, l, DBLE(cmplxint), DBLE(dens) - - energy(iroot, 4) = energy(iroot, 4) & - + (0.5d+00)*dens*cmplxint - end if - - if (j == k) then - - dr = 0.0d+00 - di = 0.0d+00 - - if (realcvec) then - - ii = i - ninact - ll = l - ninact - - Call dim1_density_R(ii, ll, dr) - - energy(iroot, 4) = energy(iroot, 4) & - - (0.5d+00)*dr*cmplxint - else - - ii = i - ninact - ll = l - ninact - - Call dim1_density(ii, ll, dr, di) - - dens = CMPLX(dr, di, 16) - energy(iroot, 4) = energy(iroot, 4) & - - (0.5d+00)*dens*cmplxint - end if - - end if - -100 end do ! l - end do ! k - end do ! j - end do ! i - - energy(iroot, 4) = energy(iroot, 4) + CONJG(energy(iroot, 4)) - -! if(ABS(eigen(iroot)-ecore & -! -(energy(iroot,1)+energy(iroot,2)+energy(iroot,3)+energy(iroot,4))) & -! > 1.0d-5 ) then - - write (*, *) 'energy 1 =', energy(iroot, 1) - write (*, *) 'energy 2 =', energy(iroot, 2) - write (*, *) 'energy 3 =', energy(iroot, 3) - write (*, *) 'energy 4 =', energy(iroot, 4) - - write (*, *) iroot, 't-energy(1-4)', & - energy(iroot, 1) + energy(iroot, 2) + energy(iroot, 3) + energy(iroot, 4) - - write (*, *) iroot, 't-energy', & - eigen(iroot) - ecore - write (*, *) iroot, 'eigen e0', & - eigen(iroot) - - write (*, *) 'C the error ', & - eigen(iroot) - ecore & - - (energy(iroot, 1) + energy(iroot, 2) + energy(iroot, 3) + energy(iroot, 4)) - -! else -! write(*,*)'C the error ', & -! eigen(iroot)-ecore & -! -(energy(iroot,1)+energy(iroot,2)+energy(iroot,3)+energy(iroot,4)) -! end if - -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -! end do ! iroot = 1, nroot - -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - write (*, *) 'energy HF =', energyHF(1) + energyHF(2) + ecore - -!!### end do ! about type - - close (5) - -1000 continue - deallocate (energy) - write (*, *) 'e0aftertra end' - End subroutine e0aftertra - -! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= -! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= - - SUBROUTINE e0aftertrac - -! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= -! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= - - use four_caspt2_module - - Implicit NONE - - integer :: ii, jj, kk, ll, typetype - integer :: j0, j, i, k, l, i0, i1, nuniq - integer :: k0, l0, nint - logical :: test - - real*8 :: i2r, i2i, dr, di, nsign - complex*16 :: oneeff, cmplxint, dens, energyHF(2) - complex*16, allocatable :: energy(:, :) - -! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= -! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= - - Allocate (energy(nroot, 4)) - energy(1:nroot, 1:4) = 0.0d+00 - - debug = .FALSE. - thres = 1.0d-15 -! thres = 0.0d+00 - - open (5, file='e0after', status='unknown', form='unformatted') - -! AT PRESENT, CODE OF COMPLEX TYPE EXISTS ! - - write (*, *) 'iroot = ', iroot - -! Do iroot = 1, nroot - -!CCCCCCCCCCCCCCCCCCCCCCCCCCCCC! -! energy HF1 ! -!"""""""""""""""""""""""""""""! -! One-electron sumation ! -! ! -! Inactive (core) part ! -! ! -!CCCCCCCCCCCCCCCCCCCCCCCCCCCCC! -!""""""""""""""""""""""""""""" - energyHF(1) = 0.0d+00 - - do i = 1, ninact + nelec - - cmplxint = 0.0d+00 - - Call tramo1(i, i, cmplxint) -! write(*,'(I4,E20.10)')i,DBLE(cmplxint) - energyHF(1) = energyHF(1) + cmplxint - - end do - -! do i = 1, ninact -! -! cmplxint = 0.0d+00 -! -! Call tramo1 ( i, i, cmplxint) -! energyHF(1) = energyHF(1) + cmplxint -! -! end do -! -! write(*,*)'energyHF(1)',energyHF(1) -! -! do i = ninact+1, ninact+nelec -! -! cmplxint = 0.0d+00 -! -! Call tramo1 ( i, i, cmplxint) -! energyHF(1) = energyHF(1) + cmplxint -! -! end do -! -! write(*,*)'energyHF(1)',energyHF(1) - -!CCCCCCCCCCCCCCCCCCCCCCCCCCCCC! -! energy HF2 ! -!"""""""""""""""""""""""""""""! 1/2*[(rr|tt)-(rt|tr)} -! Two-electron sumation ! -! ! for inactive r and t -! Inactive (core) part ! -! ! -!CCCCCCCCCCCCCCCCCCCCCCCCCCCCC! -!""""""""""""""""""""""""""""" - energyHF(2) = 0.0d+00 - - do i = 1, ninact + nelec - do j = i, ninact + nelec - - Call tramo2(i, i, j, j, cmplxint) -! write(*,*)"tramo2 1" - - energyHF(2) = energyHF(2) + (0.5d+00)*cmplxint - - Call tramo2(i, j, j, i, cmplxint) -! write(*,*)"tramo2 2" - - energyHF(2) = energyHF(2) - (0.5d+00)*cmplxint - - end do - end do - - energyHF(2) = energyHF(2) + DCONJG(energyHF(2)) - - write (*, *) 'energyHF(2)', energyHF(2) - -!CCCCCCCCCCCCCCCCCCCCCCCCCCCCC! -! energy 1 ! -!"""""""""""""""""""""""""""""! -! One-electron sumation ! -! ! -! Inactive (core) part ! -! ! -!CCCCCCCCCCCCCCCCCCCCCCCCCCCCC! -!""""""""""""""""""""""""""""" - do i = 1, ninact - - Call tramo1(i, i, cmplxint) - - energy(iroot, 1) = energy(iroot, 1) + cmplxint - - end do - -!CCCCCCCCCCCCCCCCCCCCCCCCCCCCC! -! energy 2 ! -!"""""""""""""""""""""""""""""! 1/2*[(rr|tt)-(rt|tr)} -! Two-electron sumation ! -! ! for inactive r and t -! Inactive (core) part ! -! ! -!CCCCCCCCCCCCCCCCCCCCCCCCCCCCC! -!""""""""""""""""""""""""""""" - do i = 1, ninact - do j = i, ninact - - Call tramo2(i, i, j, j, cmplxint) -! write(*,*)"tramo2 3" - energy(iroot, 2) = energy(iroot, 2) + (0.5d+00)*cmplxint - - Call tramo2(i, j, j, i, cmplxint) -! write(*,*)"tramo2 4" - energy(iroot, 2) = energy(iroot, 2) - (0.5d+00)*cmplxint - - end do - end do - - energy(iroot, 2) = energy(iroot, 2) + CONJG(energy(iroot, 2)) - -!CCCCCCCCCCCCCCCCCCCCCCCCCCCCC! -! energy 3 ! -!"""""""""""""""""""""""""""""! -! One-electron sumation ! -! ! hij + siguma [ (kk|ij)-(kj|ik) ] -! Active part ! k -! ! -! With effective one-e-int ! hij + siguma [ (ij|kk)-(ik|kj) ] -! ! k -!CCCCCCCCCCCCCCCCCCCCCCCCCCCCC! -!""""""""""""""""""""""""""""" - do i = ninact + 1, ninact + nact - do j = i, ninact + nact - - oneeff = 0.0d+00 - - do k = 1, ninact ! kk is inactive spinor - - Call tramo2(i, j, k, k, cmplxint) -! write(*,*) "tramo2 5" - oneeff = oneeff + cmplxint - - Call tramo2(i, k, k, j, cmplxint) -! write(*,*)"tramo2 6" - oneeff = oneeff - cmplxint - -300 end do ! k - - Call tramo1(i, j, cmplxint) - - oneeff = oneeff + cmplxint - -!___________________________________________________________! - ! - if (i == j) oneeff = 0.5d+00*oneeff ! -!___________________________________________________________! - - if (realcvec) then - - ii = i - ninact - jj = j - ninact - Call dim1_density_R(ii, jj, dr) - - energy(iroot, 3) = energy(iroot, 3) + oneeff*dr - - else - ii = i - ninact - jj = j - ninact - Call dim1_density(ii, jj, dr, di) - - dens = CMPLX(dr, di, 16) -! write(*,'(2I4,2E20.10)') i, j,DBLE(oneeff), DBLE(dens) - energy(iroot, 3) = energy(iroot, 3) + oneeff*dens - - end if - end do - end do - - energy(iroot, 3) = energy(iroot, 3) + CONJG(energy(iroot, 3)) -!Iwamuro modify -! write(*,*)"energy(iroot,3)",energy(iroot,3) - -!CCCCCCCCCCCCCCCCCCCCCCCCCCCCC! -! energy 4 ! -!"""""""""""""""""""""""""""""! 1/2*[(ij|kl)<0|EijEkl|0>-delta(jk)(ij|jl)<0|Eil|0>} -! Two-electron sumation ! -! ! i,j,k and l are active spinors -! active part ! -! ! -!CCCCCCCCCCCCCCCCCCCCCCCCCCCCC! -!""""""""""""""""""""""""""""" - - do i = ninact + 1, ninact + nact - do j = ninact + 1, ninact + nact - do k = ninact + 1, ninact + nact - do l = i, ninact + nact - -! if((i < ninact+3).and.(j < ninact+3).and.(k < ninact+3).and.(l < ninact+3)) then -! debug = .TRUE. ; write(*,*) i,j,k,l -! else -! debug = .FALSE. -! endif - - Call tramo2(i, j, k, l, cmplxint) -! write(*,*)"tramo2 7" -!Iwamuro modify -! write(*,*)'i, j, k, l, cmplxint =' -! write(*,'("testint2",4I4,2E15.5)') i, j, k, l, cmplxint - - If (i == l) cmplxint = cmplxint*(0.5d+00) - - if (realcvec) then - ii = i - ninact - jj = j - ninact - kk = k - ninact - ll = l - ninact - - Call dim2_density_R(ii, jj, kk, ll, dr) -! Iwamuro modify -! write(*,*)'i, jj, kk, ll, dr =' -! write(*, '(4I4, E15.5)') ii, jj, kk, ll, dr - - energy(iroot, 4) = energy(iroot, 4) & - + (0.5d+00)*dr*cmplxint - else - ii = i - ninact - jj = j - ninact - kk = k - ninact - ll = l - ninact - - Call dim2_density(ii, jj, kk, ll, dr, di) -! Iwamuro modify -! write(*,*)'ii, jj, kk, ll, dr, di =' -! Write(*,'(4i4, 2e15.5)') ii, jj, kk, ll, dr, di - - dens = CMPLX(dr, di, 16) - -! if(iroot==1) write(*,'(4I3,2E20.10)') i, j,k,l,DBLE(cmplxint), DBLE(dens) - if (iroot == 1) write (5) i, j, k, l, DBLE(cmplxint), DBLE(dens) - - energy(iroot, 4) = energy(iroot, 4) & - + (0.5d+00)*dens*cmplxint - -!Iwamuro modify -! write(*,*) "energy(iroot,4)1", energy(iroot,4) - end if - - if (j == k) then - - dr = 0.0d+00 - di = 0.0d+00 - - if (realcvec) then - - ii = i - ninact - ll = l - ninact - - Call dim1_density_R(ii, ll, dr) -! Iwamuro modify -! write(*,*)'i, ll, dr =' -! write(*,'(2I4, E15.5)') ii, ll, dr - - energy(iroot, 4) = energy(iroot, 4) & - - (0.5d+00)*dr*cmplxint -!Iwamuro modify -! write(*,*) "energy(iroot,4)2", energy(iroot,4) - else - - ii = i - ninact - ll = l - ninact - - Call dim1_density(ii, ll, dr, di) -!Iwamuro modify -! write(*,*)'ii, ll, dr, di =' -! write(*, '(2I4, 2E15.5)') ii, ll, dr, di - - dens = CMPLX(dr, di, 16) - energy(iroot, 4) = energy(iroot, 4) & - - (0.5d+00)*dens*cmplxint -!Iwamuro modify -! write(*,*) "energy(iroot,4)3", energy(iroot,4) - end if - - end if - -100 end do ! l - end do ! k - end do ! j - end do ! i - - energy(iroot, 4) = energy(iroot, 4) + CONJG(energy(iroot, 4)) - -! if(ABS(eigen(iroot)-ecore & -! -(energy(iroot,1)+energy(iroot,2)+energy(iroot,3)+energy(iroot,4))) & -! > 1.0d-5 ) then - - write (*, *) 'energy 1 =', energy(iroot, 1) - write (*, *) 'energy 2 =', energy(iroot, 2) - write (*, *) 'energy 3 =', energy(iroot, 3) - write (*, *) 'energy 4 =', energy(iroot, 4) - - write (*, *) iroot, 't-energy(1-4)', & - energy(iroot, 1) + energy(iroot, 2) + energy(iroot, 3) + energy(iroot, 4) - - write (*, *) iroot, 't-energy', & - eigen(iroot) - ecore - write (*, *) iroot, 'eigen e0', & - eigen(iroot) - - write (*, *) 'C the error ', & - eigen(iroot) - ecore & - - (energy(iroot, 1) + energy(iroot, 2) + energy(iroot, 3) + energy(iroot, 4)) - -! else -! write(*,*)'C the error ', & -! eigen(iroot)-ecore & -! -(energy(iroot,1)+energy(iroot,2)+energy(iroot,3)+energy(iroot,4)) -! end if - -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -! end do ! iroot = 1, nroot - -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - write (*, *) 'CAUTION! HF energy may not be obtained correctly ' - write (*, *) 'energy HF =', energyHF(1) + energyHF(2) + ecore - -!!### end do ! about type - - close (5) - -1000 continue - deallocate (energy) - write (*, *) 'e0aftertrac end' - End subroutine e0aftertrac diff --git a/src/e0after_tra_ty.f90 b/src/e0after_tra_ty.f90 index cc8aca0e..cde52775 100644 --- a/src/e0after_tra_ty.f90 +++ b/src/e0after_tra_ty.f90 @@ -6,12 +6,14 @@ SUBROUTINE e0aftertra_ty ! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= ! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= + use module_file_manager use four_caspt2_module Implicit NONE integer :: ii, jj, kk, ll integer :: j, i, k, l + integer :: e0after_unit real*8 :: dr, di complex*16 :: oneeff, cmplxint, dens, energyHF(2) @@ -27,9 +29,10 @@ SUBROUTINE e0aftertra_ty debug = .FALSE. thres = 1.0d-15 + e0after_unit = default_unit ! thres = 0.0d+00 if (rank == 0) then - open (5, file='e0after', status='unknown', form='unformatted') + call open_unformatted_file(unit=e0after_unit, file='e0after', status='new', optional_action='write') ! AT PRESENT, CODE OF COMPLEX TYPE EXISTS ! print *, 'iroot = ', iroot @@ -159,7 +162,7 @@ SUBROUTINE e0aftertra_ty oneeff = oneeff - cmplxint -300 end do ! k + end do ! k Call tramo1_ty(i, j, cmplxint) @@ -240,7 +243,7 @@ SUBROUTINE e0aftertra_ty ! if(iroot==1) write(*,'(4I3,2E20.10)') i, j,k,l,DBLE(cmplxint), DBLE(dens) ! Only master rank are allowed to create files used by CASPT2 except for MDCINTNEW. - if (iroot == 1 .and. rank == 0) write (5) i, j, k, l, DBLE(cmplxint), DBLE(dens) + if (iroot == 1 .and. rank == 0) write (e0after_unit) i, j, k, l, DBLE(cmplxint), DBLE(dens) energy(iroot, 4) = energy(iroot, 4) & + (0.5d+00)*dens*cmplxint @@ -274,7 +277,7 @@ SUBROUTINE e0aftertra_ty end if -100 end do ! l + end do ! l end do ! k end do ! j end do ! i @@ -318,9 +321,8 @@ SUBROUTINE e0aftertra_ty !!### end do ! about type if (rank == 0) then ! Only master ranks are allowed to create files used by CASPT2 except for MDCINTNEW. - close (5) + close (e0after_unit) end if -1000 continue deallocate (energy) print *, 'e0aftertra end' End subroutine e0aftertra_ty @@ -333,6 +335,7 @@ SUBROUTINE e0aftertrac_ty ! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= ! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= + use module_file_manager use four_caspt2_module Implicit NONE @@ -341,6 +344,7 @@ SUBROUTINE e0aftertrac_ty #endif integer :: ii, jj, kk, ll integer :: j, i, k, l + integer :: e0after_unit real*8 :: dr, di complex*16 :: oneeff, cmplxint, dens, energyHF(2) @@ -354,9 +358,10 @@ SUBROUTINE e0aftertrac_ty debug = .FALSE. thres = 1.0d-15 + e0after_unit = default_unit ! thres = 0.0d+00 if (rank == 0) then ! Only master ranks are allowed to create files used by CASPT2 except for MDCINTNEW. - open (5, file='e0after', status='unknown', form='unformatted') + call open_unformatted_file(unit=e0after_unit,file='e0after',status='new',optional_action='write') ! AT PRESENT, CODE OF COMPLEX TYPE EXISTS ! print *, 'iroot = ', iroot end if @@ -516,7 +521,7 @@ SUBROUTINE e0aftertrac_ty oneeff = oneeff - cmplxint -300 end do ! k + end do ! k Call tramo1_ty(i, j, cmplxint) @@ -597,7 +602,7 @@ SUBROUTINE e0aftertrac_ty dens = CMPLX(dr, di, 16) ! if(iroot==1) write(*,'(4I3,2E20.10)') i, j,k,l,DBLE(cmplxint), DBLE(dens) - if (iroot == 1 .and. rank == 0) write (5) i, j, k, l, DBLE(cmplxint), DBLE(dens) ! Only master ranks are allowed to create files used by CASPT2 except for MDCINTNEW. + if (iroot == 1 .and. rank == 0) write (e0after_unit) i, j, k, l, DBLE(cmplxint), DBLE(dens) ! Only master ranks are allowed to create files used by CASPT2 except for MDCINTNEW. energy(iroot, 4) = energy(iroot, 4) & + (0.5d+00)*dens*cmplxint @@ -631,7 +636,7 @@ SUBROUTINE e0aftertrac_ty end if -100 end do ! l + end do ! l end do ! k end do ! j end do ! i @@ -686,11 +691,8 @@ SUBROUTINE e0aftertrac_ty end if !!### end do ! about type if (rank == 0) then ! Only master ranks are allowed to create files used by CASPT2 except for MDCINTNEW. - close (5) + close (e0after_unit) end if -1000 continue deallocate (energy) -! print *,'e0aftertrac end' -! Iwamuro modify if (rank == 0) print *, 'e0aftertrac_ty end' End subroutine e0aftertrac_ty diff --git a/src/eeff_casci.f90 b/src/eeff_casci.f90 deleted file mode 100644 index 5fd5054a..00000000 --- a/src/eeff_casci.f90 +++ /dev/null @@ -1,115 +0,0 @@ -! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= -! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= - - PROGRAM eeff_casci ! Hyperfine coupling constant calculation for perpendicular term at CASCI level - -! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= -! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= - - use four_caspt2_module - - Implicit NONE - integer :: ii, jj, iq, i, j, imo, jmo, nhomo, i0, j0 - logical :: test, cutoff -! real*8 :: - complex*16 :: dens, eeff - complex*16,allocatable :: ci(:) , eeffmo (:,:), mat (:,:) - - character*50 :: filename - -! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= -! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= -! - - write(*,*)'' - write(*,*)' Eeff calculation' - write(*,*)' at CASCI level written by Abe in 2019' - write(*,*)'' - - open(5,file='active.inp',form='formatted',status='old') - read(5,'(I4)')ninact - read(5,'(I4)')nact - read(5,'(I4)')nsec - read(5,'(I4)')nelec - read(5,'(I4)')nroot - read(5,'(I4)')selectroot - close(5) - - nmo = ninact + nact + nsec - - write(*,*)'ninact =' ,ninact - write(*,*)'nact =' ,nact - write(*,*)'nsec =' ,nsec - write(*,*)'nelec =' ,nelec - write(*,*)'nroot =' ,nroot - write(*,*)'selectroot =' ,selectroot - write(*,*)'nmo =' ,nmo - - filename = 'r4dmoint1relp2' - - Allocate(eeffmo(nmo,nmo)) - - open(unit=12,file=trim(filename), status='old', form='unformatted') - read(12) - read(12)((eeffmo(jmo,imo),jmo=1,nmo),imo=1,nmo) - close(12) - - open(10,file='CIMAT1',form='unformatted',status='old') - - read(10) ndet - Allocate(idet(1:ndet)) - Allocate(mat(ndet,ndet)) - read(10) idet(1:ndet) - read(10) - read(10) mat(1:ndet,1:ndet) - close(10) - - Allocate(ci(ndet)) - ci = mat ( :, selectroot) - - Deallocate (mat) - - do j = 1, ndet - if((ABS(ci(j))**2) > 1.0d-02 ) then - i0 = idet(j) - write(*,*)(btest(i0,j0),j0=0,nact-1) - write(*,'(I4,2(3X,E14.7)," Weights ",E14.7)') & - & j, ci(j), ABS(ci(j))**2 - end if - end do - - - Allocate(cir(1:ndet,selectroot:selectroot)) - Allocate(cii(1:ndet,selectroot:selectroot)) - - cir(1:ndet,selectroot) = DBLE(ci(1:ndet)) - cii(1:ndet,selectroot) = DIMAG(ci(1:ndet)) - - deallocate(ci) - - iroot = selectroot - eeff = 0.0d+00 - nhomo = nelec + ninact - write(*,*) 'nhomo,eeffmo(nhomo,nhomo) ',nhomo,eeffmo(nhomo,nhomo ) - write(*,*) 'nhomo,eeffmo(nhomo,nhomo+1) ',nhomo,eeffmo(nhomo,nhomo+1 ) - - Do i = 1, nact - Do j = 1, nact - Call dim1_density_diag (i, j, dens) - ii = i + ninact - jj = j + ninact -! write(*,*) 'ii,jj,dens,eeffmo(ii,jj )',ii,jj,dens,eeffmo(ii,jj) - eeff = eeff + dens*eeffmo(ii,jj) - End do - End do - write(*,*)'eeff', eeff - - deallocate (cir) - deallocate (cii) - deallocate (idet) - deallocate (eeffmo) - - END program eeff_casci - - - diff --git a/src/eeff_casci_new.f90 b/src/eeff_casci_new.f90 deleted file mode 100644 index 3a9b8aa3..00000000 --- a/src/eeff_casci_new.f90 +++ /dev/null @@ -1,127 +0,0 @@ -! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= -! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= - -PROGRAM eeff_casci ! Hyperfine coupling constant calculation for perpendicular term at CASCI level - -! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= -! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= - - use four_caspt2_module - - Implicit NONE - integer :: ii, jj, iq, i, j, imo, jmo, nhomo - logical :: test, cutoff -! real*8 :: - complex*16 :: dens, eeff - complex*16, allocatable :: ci(:), eeffmo(:, :) - - character*50 :: filename - -! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= -! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= -! - - write (*, *) '' - write (*, *) ' Eeff calculation' - write (*, *) ' at CASCI level written by Abe in 2019' - write (*, *) '' - - open (5, file='active.inp', form='formatted', status='old') - read (5, '(I4)') ninact - read (5, '(I4)') nact - read (5, '(I4)') nsec - read (5, '(I4)') nelec - read (5, '(I4)') nroot - read (5, '(I4)') selectroot - close (5) - - nmo = ninact + nact + nsec - - write (*, *) 'ninact =', ninact - write (*, *) 'nact =', nact - write (*, *) 'nsec =', nsec - write (*, *) 'nelec =', nelec - write (*, *) 'nroot =', nroot - write (*, *) 'selectroot =', selectroot - write (*, *) 'nmo =', nmo - - filename = 'r4dmoint1relp2' - - Allocate (eeffmo(nmo, nmo)) - - open (unit=12, file=trim(filename), status='old', form='unformatted') - read (12) - read (12) ((eeffmo(jmo, imo), jmo=1, nmo), imo=1, nmo) - close (12) - - open (10, file='CIMAT', form='unformatted', status='old') - - read (10) ndet - Allocate (idet(1:ndet)) - read (10) idet(1:ndet) - - close (10) - - Allocate (ci(1:ndet)) - ci = 0.0d+00 - - open (10, file='NEWCICOEFF', form='unformatted', status='old') - read (10) ci(1:ndet) - close (10) - - Do crei = 1, nact - Do anhj = 1, nact - - dens = 0.0d+00 - - Do i0 = 1, ndet - i = idet(i0) - - call one_e_exct(i, crei, anhj, newidet, phase) - if (newidet == 0) goto 10 - i = newidet - phasenew = phase - j0 = 0 - - do i1 = 1, ndet - j = idet(i1) - if (j == i) then - j0 = i1 - goto 1 - end if - end do -1 continue - - if (j0 == 0) then - go to 10 - end if - - if (mod(phasenew, 2) == 0) then - dens = dens - ci(j)*DCONJG(ci(i)) - else - dens = dens - ci(j)*DCONJG(ci(i)) - end if - - ii = i + ninact - jj = j + ninact - if (ABS(dens) > 1.0d-15) write (*, *) 'ii,jj,dens,eeffmo(ii,jj )', ii, jj, dens, eeffmo(ii, jj) - eeff = eeff + dens*eeffmo(ii, jj) - - iroot = selectroot - eeff = 0.0d+00 - nhomo = nelec + ninact - write (*, *) 'nhomo,eeffmo(nhomo,nhomo) ', nhomo, eeffmo(nhomo, nhomo) - write (*, *) 'nhomo,eeffmo(nhomo,nhomo+1) ', nhomo, eeffmo(nhomo, nhomo + 1) - - Do i = 1, nact - Do j = 1, nact - Call dim1_density_diag(i, j, dens) - End do - End do - write (*, *) 'eeff', eeff - - deallocate (ci) - deallocate (idet) - deallocate (eeffmo) - - END program eeff_casci diff --git a/src/fockcasci.f90 b/src/fockcasci.f90 deleted file mode 100644 index 6e3b3b50..00000000 --- a/src/fockcasci.f90 +++ /dev/null @@ -1,146 +0,0 @@ -! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= -! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= - - SUBROUTINE fockcasci ! TO MAKE FOCK MATRIX for CASCI state - -! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= -! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= - - use four_caspt2_module - - Implicit NONE - - integer :: ii, jj, kk, ll - integer :: j, i, k, l - integer :: nint, n - - real*8 :: i2r, i2i, dr, di, nsign - complex*16 :: cmplxint, dens - -! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= -! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= - -!! NOW MAKE FOCK MATRIX FOR CASCI STATE -!! fij = hij + SIGUMA_kl[<0|Ekl|0>{(ij|kl)-(il|kj)} - - f = 0.0d+00 - - write (*, *) 'enter building fock matrix' - - do i = 1, ninact + nact - do j = i, ninact + nact - - f(i, j) = DCMPLX(oner(i, j), onei(i, j)) - - do k = 1, ninact - - Call intmo2(i, j, k, k, cmplxint) -!Iwamuro modify -! If (i==4 .and. j==6.and. abs(cmplxint) > 1.0d-05) then -! write(*,'(4I4, 4E20.10)') i,j,k,k,cmplxint,f(i,j) -! endif - f(i, j) = f(i, j) + cmplxint - - Call intmo2(i, k, k, j, cmplxint) -!Iwamuro modify -! If (i==4 .and. j==6.and. abs(cmplxint) > 1.0d-05) then -! write(*,'(4I4,4E20.10)') i,k,k,j,cmplxint,f(i,j) -! endif - f(i, j) = f(i, j) - cmplxint - - End do ! k - - do k = ninact + 1, ninact + nact ! ACTIVE SPACE - do l = ninact + 1, ninact + nact ! ACTIVE SPACE - - If (realcvec) then - Call dim1_density_R(k - ninact, l - ninact, dr) - Call intmo2(i, j, k, l, cmplxint) - f(i, j) = f(i, j) + dr*cmplxint - Call intmo2(i, l, k, j, cmplxint) - f(i, j) = f(i, j) - dr*cmplxint - - Else - dr = 0.0d+00 - Call dim1_density(k - ninact, l - ninact, dr, di) - dens = CMPLX(dr, di, 16) -!Iwamuro modify -! If (i==4 .and. j==6.and. abs(dens) > 0.0d-05) Write( *, '("dens1",4I4, 2E20.10)') i,j,k,l,dens -! If (i==6 .and. j==4.and. abs(dens) > 0.0d-05) Write( *, '("dens2",4I4, 2E20.10)') i,j,k,l,dens - Call intmo2(i, j, k, l, cmplxint) - f(i, j) = f(i, j) + dens*cmplxint - Call intmo2(i, l, k, j, cmplxint) - f(i, j) = f(i, j) - dens*cmplxint - - End if - - End do ! l - End do ! k - - f(j, i) = DCONJG(f(i, j)) - end do ! j - end do ! i - - do i = ninact + nact + 1, ninact + nact + nsec - do j = i, ninact + nact + nsec - - f(i, j) = DCMPLX(oner(i, j), onei(i, j)) -! if(i==19.and.j==19)write(*,'("int1 ",2I4,2E20.10)')i,j,f(i,j) - - do k = 1, ninact - - f(i, j) = f(i, j) + DCMPLX(int2r_f1(i, j, k, k), int2i_f1(i, j, k, k)) - f(i, j) = f(i, j) - DCMPLX(int2r_f2(i, k, k, j), int2i_f2(i, k, k, j)) - -! if(i==19.and.j==19) write(*,'("+int2 ",4I4,2E20.10)') i,j,k,k, & -! & DCMPLX(int2r_f1(i,j,k,k),int2i_f1(i,j,k,k)) -! -! if(i==19.and.j==19) write(*,'("-int2 ",4I4,2E20.10)') i,k,k,j, & -! & DCMPLX(int2r_f1(i,k,k,j),int2i_f1(i,k,k,j)) - - End do ! k - - do k = ninact + 1, ninact + nact ! ACTIVE SPACE - do l = ninact + 1, ninact + nact ! ACTIVE SPACE - - If (realcvec) then - Call dim1_density_R(k - ninact, l - ninact, dr) - - f(i, j) = f(i, j) + dr*DCMPLX(int2r_f1(i, j, k, l), int2i_f1(i, j, k, l)) - f(i, j) = f(i, j) - dr*DCMPLX(int2r_f2(i, l, k, j), int2i_f2(i, l, k, j)) - - Else - Call dim1_density(k - ninact, l - ninact, dr, di) - dens = CMPLX(dr, di, 16) -!Iwamuro modify -! If (i==4 .and. j==6.and. abs(dens) > 0.0d-05) Write( *, '("dens3",4I4, 2E20.10)') i,j,k,l,dens -! If (i==6 .and. j==4.and. abs(dens) > 0.0d-05) Write( *, '("dens4",4I4, 2E20.10)') i,j,k,l,dens - f(i, j) = f(i, j) + dens*DCMPLX(int2r_f1(i, j, k, l), int2i_f1(i, j, k, l)) - f(i, j) = f(i, j) - dens*DCMPLX(int2r_f2(i, l, k, j), int2i_f2(i, l, k, j)) - -! if(i==19.and.j==19) write(*,'("+int2 ",4I4,2E20.10)') i,j,k,l, & -! & DCMPLX(int2r_f1(i,j,k,l),int2i_f1(i,j,k,l)) - -! if(i==19.and.j==19) write(*,'("-int2 ",4I4,2E20.10)') i,l,k,j, & -! & DCMPLX(int2r_f2(i,l,k,j),int2i_f2(i,l,k,j)) - -! if(i==19.and.j==19) write(*,'("dens ",2I4,2E20.10)') k,l, dens - - End if - - End do ! l - End do ! k - -!Iwamuro modify - ! If (i==4 .and. j==6) Write( *, '(4I4, 2E20.10)') i,j,k,l,f(i,j) - f(j, i) = DCONJG(f(i, j)) -!Iwamuro modify -! write(*,'("fock",2I4,2E20.10)')i,j,f(j,i) -! if(i==19.and.j==19)write(*,'("fock ",2I4,2E20.10)')i,j,f(i,j) -! write(*,'("fock",2I4,2E20.10)')i,j,f(i,j) - - end do ! j - end do ! i - - write (*, *) 'fockcasci end' - end diff --git a/src/fockdiag.f90 b/src/fockdiag.f90 deleted file mode 100644 index 3d89854b..00000000 --- a/src/fockdiag.f90 +++ /dev/null @@ -1,161 +0,0 @@ -! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= -! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= - - SUBROUTINE fockdiag - -! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= -! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= - - use four_caspt2_module - - Implicit NONE - - integer :: i, j - integer :: i0, j0, n, dimn, n0, n1, nspace(3,3) - logical :: test, cutoff - - complex*16 :: trace1, trace2 - real*8, allocatable :: fa(:,:) - complex*16, allocatable :: fac(:,:), readmo(:,:,:) - -!Iwamuro modify - real*8 :: a(6,6) - integer :: x, y, z -! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= -! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= - - write(*,*)'fockdiag start' - REALF = .TRUE. - - Do i = 1, ninact+nact+nsec - Do j = 1, ninact+nact+nsec - If(ABS(DIMAG(f(i,j))) > 1.0d-12) then - REALF = .FALSE. - Endif - Enddo - Enddo - - - REALF = .FALSE. - - write(*,*)'REALF',REALF - - - If(REALF) then ! real*8 - Allocate(fa(nmo,nmo)) ; Call memplus(KIND(fa),SIZE(fa),1) - eps = 0.0d+00 - fa = 0.0d+00 - Else - Allocate(fac(nmo,nmo)); Call memplus(KIND(fac),SIZE(fac),2) - eps = 0.0d+00 - fac = 0.0d+00 - Endif - - nspace(1,1) = 1 - nspace(2,1) = ninact - nspace(3,1) = ninact - - nspace(1,2) = ninact+1 - nspace(2,2) = ninact+nact - nspace(3,2) = nact - - nspace(1,3) = ninact+nact+1 - nspace(2,3) = ninact+nact+nsec - nspace(3,3) = nsec - - - Do i0 = 1, 3 - - n0 = nspace(1,i0) - n1 = nspace(2,i0) - n = nspace(3,i0) - - if(i0 == 1) write(*,*)'FOR INACTIVE-INACTIVE ROTATION !' - if(i0 == 2) write(*,*)'FOR ACTIVE-ACTIVE ROTATION !' - if(i0 == 3) write(*,*)'FOR SECONDARY-SECONDARY ROTATION !' - - if(REALF) then - - Call rdiag0 (n, n0, n1, fa(n0:n1,n0:n1), eps(n0:n1) ) - - write(5)n0,n1,n - write(5)fa(n0:n1,n0:n1) - write(*,*)n0,n1,n - -! write(*,*)'rdiag fa ' -! do i = n0, n1 -! write(*,'(30E13.5)')(real(fa(i,j)),j = n0,n1) -! end do - -! write(*,*)'rdiag f' -! do i = n0, n1 -! write(*,'(30E13.5)')(DBLE(f(i,j)),j = n0,n1) -! end do - - - else - Call cdiag0 ( n, n0, n1, fac(n0:n1,n0:n1), eps(n0:n1) ) - -! fac(3,3) = 0.10000E+01 -! fac(4,4) = 0.10000E+01 - -! Write(*,*)'cdiag fa ', n0, n1, n -! do i = n0, n1 -! write(*,'(30E13.5)')(real(fac(i,j)),j = n0,n1) -! end do - -! write(*,*)'cdiag f ', n0, n1, n -! do i = n0, n1 -! write(*,'(30E13.5)')(DBLE(f(i,j)),j = n0,n1) -! end do - endif - - End do ! i0 - - - if(REALF) then - - Call traci(fa(ninact+1:ninact+nact,ninact+1:ninact+nact)) - - f(1:nmo,1:nmo) = fa(1:nmo,1:nmo) - - Call e0aftertra - - deallocate(fa) ; Call memminus(KIND(fa),SIZE(fa),1) - - else - - Call tracic(fac(ninact+1:ninact+nact,ninact+1:ninact+nact)) - - f(1:nmo,1:nmo) = fac(1:nmo,1:nmo) - - Call e0aftertrac - - deallocate (fac) ; Call memminus(KIND(fac),SIZE(fac),2) - - endif - -! Do i0 = (ninact+nact)/2+1, nmo/2 -! Do j0 = (ninact+nact)/2+1, nmo/2 -! -! if(ABS(f(2*i0,2*j0)-DCONJG(f(2*i0-1,2*j0-1))) > 1.0d-10) then -! write(*,'(2I4,2E20.10)')2*i0,2*j0,f(2*i0,2*j0) -! write(*,'(2I4,2E20.10)')2*i0-1,2*j0-1,f(2*i0-1,2*j0-1) -! write(*,*)' ' -! Endif -! -! Enddo -! Enddo - - - open(5, file='TRANSFOCK', status='unknown', form='unformatted') - write(5) nmo - write(5) f(1:nmo,1:nmo) - close(5) - - goto 1000 - 10 write(*,*)'reading err in orbcoeff' - 1000 continue - write(*,*)'fockdiag end' - end subroutine fockdiag - diff --git a/src/fockdiag_ty.f90 b/src/fockdiag_ty.f90 index 378faa00..9822fb64 100644 --- a/src/fockdiag_ty.f90 +++ b/src/fockdiag_ty.f90 @@ -6,11 +6,13 @@ SUBROUTINE fockdiag_ty ! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= ! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= + use module_file_manager use four_caspt2_module Implicit NONE integer :: i, j + integer :: transfock_unit integer :: i0, n, n0, n1, nspace(3, 3) real*8, allocatable :: fa(:, :) complex*16, allocatable :: fac(:, :) @@ -20,7 +22,7 @@ SUBROUTINE fockdiag_ty if (rank == 0) print *, 'fockdiag start' REALF = .TRUE. - + transfock_unit = default_unit Do i = 1, ninact + nact + nsec Do j = 1, ninact + nact + nsec If (ABS(DIMAG(f(i, j))) > 1.0d-12) then @@ -115,10 +117,10 @@ SUBROUTINE fockdiag_ty end if if (rank == 0) then ! Only master ranks are allowed to create files used by CASPT2 except for MDCINTNEW. - open (5, file='TRANSFOCK', status='unknown', form='unformatted') - write (5) nmo - write (5) f(1:nmo, 1:nmo) - close (5) + call open_unformatted_file(unit=transfock_unit, file='TRANSFOCK', status='new', optional_action='write') + write (transfock_unit) nmo + write (transfock_unit) f(1:nmo, 1:nmo) + close (transfock_unit) end if if (rank == 0) print *, 'fockdiag end' diff --git a/src/fockhf.f90 b/src/fockhf.f90 deleted file mode 100644 index acebdaa8..00000000 --- a/src/fockhf.f90 +++ /dev/null @@ -1,101 +0,0 @@ -! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= -! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= - - SUBROUTINE fockhf ! TO CALCULATE FOCK MATRIX OF HF STATE, A TEST - -! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= -! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= - - use four_caspt2_module - - Implicit NONE - integer :: ii, jj, kk, ll - integer :: j, i, k, l - integer :: nint, n - - real*8 :: i2r, i2i, dr, di, nsign - complex*16 :: cmplxint, dens - -! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= -! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= - - debug = .TRUE. - thres = 1.0d-15 -! thres = 0.0d+00 - -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! - -!! TEST TO CALCULATE FOCK MATRIX OF HF STATE fpq = hpq + SIGUMA_r[(pq|rr)-(pr|qr)] -!! THIS MUST BE DIAGONAL MATRIX AND DIAGONAL ELEMENTS CORESPONDS TO SPINOR ENERGIES. - write (*, *) ' ' - write (*, *) 'FOR TEST, FOCK MATRIX OF HF STATE IS CALCULATED ' - - n = 0 - f = 0.0d+00 - - do i = 1, ninact + nact + nsec - do j = i, ninact + nact + nsec - - f(i, j) = DCMPLX(oner(i, j), onei(i, j)) - - do k = 1, ninact + nelec - - i2r = 0.0d+00 - i2i = 0.0d+00 - dr = 0.0d+00 - di = 0.0d+00 - cmplxint = 0.0d+00 - - nint = ABS(indtwr(i, j, k, k)) - - nsign = SIGN(1, indtwr(i, j, k, k)) - i2r = int2r(nint)*nsign - - nsign = SIGN(1, indtwi(i, j, k, k)) - i2i = int2i(nint)*nsign - - cmplxint = CMPLX(i2r, i2i, 16) - - nint = ABS(indtwr(i, k, k, j)) - - nsign = SIGN(1, indtwr(i, k, k, j)) - i2r = int2r(nint)*nsign - - nsign = SIGN(1, indtwi(i, k, k, j)) - i2i = int2i(nint)*nsign - - cmplxint = cmplxint - CMPLX(i2r, i2i, 16) - - f(i, j) = f(i, j) + cmplxint -! write(*,*)f(i,j) - End do ! k - - f(j, i) = DCONJG(f(i, j)) - - End do ! j - End do ! i - - write (*, *) ' ' - write (*, *) 'OFF DIAGONAL ELEMENTS OF FOCK MATRIX WHICH IS LARGER THAN 1.0d-06 ' - write (*, *) ' ' - do i = 1, ninact + nact + nsec - do j = i, ninact + nact + nsec - if ((i /= j) .and. (ABS(f(i, j)) > 1.0d-6)) then -! if(i/=j)then - write (*, '(2I4,2E20.10)') i, j, f(i, j) - end if - end do - end do - write (*, *) ' ' - write (*, *) 'THESE DIAGONAL ELEMENTS SHOULD BE CORESPOND TO HF SPINOR ENERGY ' - write (*, *) ' ' - write (*, *) ' NO. Spinor Energy(Re) Spinor Energy(Im) '& - &, 'Spinor Energy (HF) ERROR' - do i = 1, ninact + nact + nsec - write (*, '(I4,4E20.10)') i, f(i, i), orbmo(i), orbmo(i) - dble(f(i, i)) - end do - - write (*, *) 'fockhf end' - - end SUBROUTINE fockhf diff --git a/src/fockhf1.f90 b/src/fockhf1.f90 deleted file mode 100644 index ecd52ca4..00000000 --- a/src/fockhf1.f90 +++ /dev/null @@ -1,100 +0,0 @@ -! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= -! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= - - SUBROUTINE fockhf1 ! TO CALCULATE FOCK MATRIX OF HF STATE, A TEST - -! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= -! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= - - use four_caspt2_module - - Implicit NONE - integer :: ii, jj, kk, ll - integer :: j, i, k, l - integer :: nint, n - - real*8 :: i2r, i2i, dr, di, nsign - complex*16 :: cmplxint, dens - -! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= -! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= - - debug = .TRUE. - thres = 1.0d-15 -! thres = 0.0d+00 - -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! - -!! TEST TO CALCULATE FOCK MATRIX OF HF STATE fpq = hpq + SIGUMA_r[(pq|rr)-(pr|qr)] -!! THIS MUST BE DIAGONAL MATRIX AND DIAGONAL ELEMENTS CORESPONDS TO SPINOR ENERGIES. - write (*, *) ' ' - write (*, *) 'FOR TEST, FOCK MATRIX OF HF STATE IS CALCULATED ' - - n = 0 - f = 0.0d+00 - - do i = 1, ninact + nact - do j = i, ninact + nact - - f(i, j) = DCMPLX(oner(i, j), onei(i, j)) - - do k = 1, ninact + nelec - - Call intmo2(i, j, k, k, cmplxint) - - f(i, j) = f(i, j) + cmplxint - - Call intmo2(i, k, k, j, cmplxint) - - f(i, j) = f(i, j) - cmplxint - -! write(*,*)f(i,j) - End do ! k - - f(j, i) = DCONJG(f(i, j)) - - End do ! j - End do ! i - - do i = ninact + nact + 1, ninact + nact + nsec - do j = i, ninact + nact + nsec - - f(i, j) = DCMPLX(oner(i, j), onei(i, j)) - - do k = 1, ninact + nelec - - f(i, j) = f(i, j) + DCMPLX(int2r_f1(i, j, k, k), int2i_f1(i, j, k, k)) - f(i, j) = f(i, j) - DCMPLX(int2r_f2(i, k, k, j), int2i_f2(i, k, k, j)) - -! write(*,*)f(i,j) - End do ! k - - f(j, i) = DCONJG(f(i, j)) - - End do ! j - End do ! i - - write (*, *) ' ' - write (*, *) 'OFF DIAGONAL ELEMENTS OF FOCK MATRIX WHICH IS LARGER THAN 1.0d-06 ' - write (*, *) ' ' - do i = 1, ninact + nact + nsec - do j = i, ninact + nact + nsec - if ((i /= j) .and. (ABS(f(i, j)) > 1.0d-6)) then -! if(i/=j)then - write (*, '(2I4,2E20.10)') i, j, f(i, j) - end if - end do - end do - write (*, *) ' ' - write (*, *) 'THESE DIAGONAL ELEMENTS SHOULD BE CORESPOND TO HF SPINOR ENERGY ' - write (*, *) ' ' - write (*, *) ' NO. Spinor Energy(Re) Spinor Energy(Im) '& - &, 'Spinor Energy (HF) ERROR' - do i = 1, ninact + nact + nsec - write (*, '(I4,4E20.10)') i, f(i, i), orbmo(i), orbmo(i) - dble(f(i, i)) - end do - - write (*, *) 'fockhf end' - - end SUBROUTINE fockhf1 diff --git a/src/fockivo.f90 b/src/fockivo.f90 deleted file mode 100644 index b4f8ad88..00000000 --- a/src/fockivo.f90 +++ /dev/null @@ -1,229 +0,0 @@ -! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= -! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= - - SUBROUTINE fockivo(nhomo) ! TO MAKE FOCK MATRIX for IVO - -! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= -! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= - - use four_caspt2_module - - Implicit NONE - - integer, intent(in) :: nhomo - - integer :: ii, jj, kk, ll - integer :: j, i, k, l, i0, j0 - integer :: nint, n, nsym, isym, nv, numh - - real*8 :: i2r, i2i, dr, di, nsign, thresd - complex*16 :: cmplxint, dens - logical ::cutoff - - complex*16, allocatable :: fsym(:, :), fdmmy(:, :) - complex*16, allocatable :: coeff(:, :, :), readmo(:, :, :) - real*8, allocatable :: wsym(:) - integer, allocatable :: mosym(:) - -! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= -! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= - -!! NOW MAKE FOCK MATRIX FOR IVO -!! fij = hij + SIGUMA_k (ij|kk)-(ik|kj)} i, j run over virtual spinors k runs occupied spinors except HOMO - - f = 0.0d+00 - - write (*, *) 'enter building fock matrix for IVO' - -! Allocate(fdmmy(nsec,nsec)) -! fdmmy = 0.0d+00 -! do i = 1, nsec -! i0 = i + ninact + nact -! fdmmy(i,i) = orbmo(i0) -! do j = i, nsec -! j0 = j + ninact + nact -! -! do k = ninact+nelec-1, ninact+nelec -! Call intmo2(i0,j0,k,k,cmplxint) -! fdmmy(i,j) = fdmmy(i,j) - 0.5d+00*cmplxint -! Call intmo2(i0,k,k,j0,cmplxint) -! fdmmy(i,j) = fdmmy(i,j) + 0.5d+00*cmplxint -! enddo -! -! enddo -! enddo - - if (nhomo == 0) then - numh = 0 - do i = 1, ninact + nact - if (ABS(orbmo(i) - orbmo(nelec + ninact)) < 1.0d-01) then - numh = numh + 1 - end if - end do - else - numh = nhomo - end if - -! if(mod(nelec,2)==0) then -! numh = numh -! else -! numh = numh-1 -! endif - - write (*, *) 'number of degeneracy of HOMO is', numh, DBLE(numh), 1.0d+00/DBLE(numh) - - do i = 1, nsec - i0 = i + ninact + nact - f(i, i) = orbmo(i0) - do j = i, nsec - j0 = j + ninact + nact - do k = ninact + nact - numh + 1, ninact + nact - - if (k > ninact + nact - 2 .and. mod(nelec, 2) == 1) then - - f(i, j) = f(i, j) & - & - 0.5d+00*DCMPLX(int2r_f1(i0, j0, k, k), int2i_f1(i0, j0, k, k))/DBLE(numh) - f(i, j) = f(i, j) & - & + 0.5d+00*DCMPLX(int2r_f2(i0, k, k, j0), int2i_f2(i0, k, k, j0))/DBLE(numh) - - else - f(i, j) = f(i, j) - DCMPLX(int2r_f1(i0, j0, k, k), int2i_f1(i0, j0, k, k))/DBLE(numh) - f(i, j) = f(i, j) + DCMPLX(int2r_f2(i0, k, k, j0), int2i_f2(i0, k, k, j0))/DBLE(numh) - end if - - end do - - end do - end do - -! do i = 1, nsec -! do j = i, nsec -! if(ABS(fdmmy(i,j)-f(i,j))>1.0d-05) then -! write(*,*)i,j,fdmmy(i,j),f(i,j),fdmmy(i,j)-f(i,j) -! endif -! enddo -! enddo - - do i = 1, nsec - do j = i, nsec - f(j, i) = DCONJG(f(i, j)) - end do - end do - - allocate (readmo(nbas*2, nbas*2, 2)) - allocate (itrfmo(nbas*2, nbas, 2)) - itrfmo = 0.0d+00 - - open (15, file='r4dorbcoeff', status='old', form='unformatted') - read (15, err=10) readmo - close (15) - - itrfmo(1:nbas*2, 1:nbas, 1:2) = readmo(1:nbas*2, nbas + 1:nbas*2, 1:2) - - Do isym = 1, nsymrpa, 2 - nv = 0 - Do i = 1, nsec - i0 = i + ninact + nact - if (irpmo(i0) == isym) then - nv = nv + 1 - end if - end do - - Allocate (mosym(nv)) - Allocate (fsym(nv, nv)) - fsym = 0.0d+00 - nv = 0 - Do i = 1, nsec - i0 = i + ninact + nact - if (irpmo(i0) == isym) then - nv = nv + 1 - mosym(nv) = i - end if - end do - - Do i = 1, nv - i0 = mosym(i) - Do j = i, nv - j0 = mosym(j) - fsym(i, j) = f(i0, j0) - fsym(j, i) = DCONJG(f(i0, j0)) -! write(*,*)fsym(i,j) - end do - end do - Allocate (wsym(nv)) - wsym = 0.0d+00 - cutoff = .FALSE. - thresd = 0.0d+00 - - call cdiag(fsym, nv, nv, wsym, thresd, cutoff) - - Allocate (coeff(nbas*2, nv, 2)) - - Do i = 1, nv - i0 = mosym(i) + ncore + ninact + nact - coeff(:, i, :) = itrfmo(:, i0, :) - End do - - coeff(:, :, 1) = MATMUL(coeff(:, :, 1), fsym(:, :)) - coeff(:, :, 2) = MATMUL(coeff(:, :, 2), fsym(:, :)) - - Do i = 1, nv - i0 = mosym(i) + ncore + ninact + nact - itrfmo(:, i0, :) = coeff(:, i, :) - End do - -! Kramers - pairs - - Do i = 1, nv - i0 = mosym(i) + ncore + ninact + nact + 1 - coeff(:, i, :) = itrfmo(:, i0, :) - End do - - coeff(:, :, 1) = MATMUL(coeff(:, :, 1), DCONJG(fsym(:, :))) - coeff(:, :, 2) = MATMUL(coeff(:, :, 2), DCONJG(fsym(:, :))) - - Do i = 1, nv - i0 = mosym(i) + ncore + ninact + nact + 1 - itrfmo(:, i0, :) = coeff(:, i, :) - End do - -! Kramers - pairs - - deallocate (coeff) - - Do i = 1, nv - i0 = mosym(i) - write (*, '(I4,F20.10)') i0, wsym(i) - end do - - Do i = 1, nv - i0 = mosym(i) - write (*, *) '' - write (*, *) 'new ', i0 + ninact + nact, 'th ms consists of ' - Do j = 1, nv - j0 = mosym(j) - if (ABS(fsym(j, i))**2 > 1.0d-03) then - write (*, '(I4," Weights ",F20.10)') j0 + ninact + nact, ABS(fsym(j, i))**2 - end if - end do - end do - deallocate (fsym) - deallocate (wsym) - deallocate (mosym) - end do - - readmo(1:nbas*2, nbas + 1:nbas*2, 1:2) = itrfmo(1:nbas*2, 1:nbas, 1:2) - - open (15, file='r4dorbcoeff_ivo', status='unknown', form='unformatted') - write (15) readmo - close (15) - goto 100 - -10 write (*, *) 'reading err of r4dorbcoeff' -! deallocate(fdmmy) - deallocate (readmo) - deallocate (itrfmo) - -100 write (*, *) 'fockivo end' - end - diff --git a/src/fockivo_ty.f90 b/src/fockivo_ty.f90 deleted file mode 100644 index 4818f049..00000000 --- a/src/fockivo_ty.f90 +++ /dev/null @@ -1,196 +0,0 @@ -! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= -! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= - - SUBROUTINE fockivo_ty(nhomo) ! TO MAKE FOCK MATRIX for IVO - -! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= -! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= - - use four_caspt2_module - - Implicit NONE - - integer, intent(in) :: nhomo - - integer :: ii, jj, kk, ll - integer :: j, i, k, l, i0, j0 - integer :: nint, n, nsym, isym, nv, numh - - real*8 :: i2r, i2i, dr, di, nsign, thresd - complex*16 :: cmplxint, dens - logical ::cutoff - - complex*16, allocatable :: fsym(:, :), fdmmy(:, :) - complex*16, allocatable :: coeff(:, :, :), readmo(:, :, :) - real*8, allocatable :: wsym(:) - integer, allocatable :: mosym(:) - -! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= -! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= - -!! NOW MAKE FOCK MATRIX FOR IVO -!! fij = hij + SIGUMA_k (ij|kk)-(ik|kj)} i, j run over virtual spinors k runs occupied spinors except HOMO - - f = 0.0d+00 - - write (*, *) 'enter building fock matrix for IVO' - - if (nhomo == 0) then - numh = 0 - do i = 1, ninact + nact - if (ABS(orbmo(i) - orbmo(nelec + ninact)) < 1.0d-01) then - numh = numh + 1 - end if - end do - else - numh = nhomo - end if - - write (*, *) 'number of degeneracy of HOMO is', numh, DBLE(numh), 1.0d+00/DBLE(numh) - - do i = 1, nsec - i0 = i + ninact + nact - f(i, i) = orbmo(i0) - do j = i, nsec - j0 = j + ninact + nact - do k = ninact + nact - numh + 1, ninact + nact - - if (k > ninact + nact - 2 .and. mod(nelec, 2) == 1) then - - f(i, j) = f(i, j) & - & - 0.5d+00*DCMPLX(int2r_f1(i0, j0, k, k), int2i_f1(i0, j0, k, k))/DBLE(numh) - f(i, j) = f(i, j) & - & + 0.5d+00*DCMPLX(int2r_f2(i0, k, k, j0), int2i_f2(i0, k, k, j0))/DBLE(numh) - - else - f(i, j) = f(i, j) - DCMPLX(int2r_f1(i0, j0, k, k), int2i_f1(i0, j0, k, k))/DBLE(numh) - f(i, j) = f(i, j) + DCMPLX(int2r_f2(i0, k, k, j0), int2i_f2(i0, k, k, j0))/DBLE(numh) - end if - - end do - - end do - end do - - do i = 1, nsec - do j = i, nsec - f(j, i) = DCONJG(f(i, j)) - end do - end do - - allocate (readmo(nbas*2, nbas*2, 2)) - allocate (itrfmo(nbas*2, nbas, 2)) - itrfmo = 0.0d+00 - - open (15, file='r4dorbcoeff', status='old', form='unformatted') - read (15, err=10) readmo - close (15) - - itrfmo(1:nbas*2, 1:nbas, 1:2) = readmo(1:nbas*2, nbas + 1:nbas*2, 1:2) - - Do isym = 1, nsymrpa, 2 - nv = 0 - Do i = 1, nsec - i0 = i + ninact + nact - if (irpmo(i0) == isym) then - nv = nv + 1 - end if - end do - - Allocate (mosym(nv)) - Allocate (fsym(nv, nv)) - fsym = 0.0d+00 - nv = 0 - Do i = 1, nsec - i0 = i + ninact + nact - if (irpmo(i0) == isym) then - nv = nv + 1 - mosym(nv) = i - end if - end do - ! Noda 2021/12/27 max(nv) = nsec. So the max dimention of fsym is nsec (fsym(nsec,nsec)) - Do i = 1, nv - i0 = mosym(i) - Do j = i, nv - j0 = mosym(j) - fsym(i, j) = f(i0, j0) - fsym(j, i) = DCONJG(f(i0, j0)) -! write(*,*)fsym(i,j) - end do - end do - Allocate (wsym(nv)) - wsym = 0.0d+00 - cutoff = .FALSE. - thresd = 0.0d+00 - - call cdiag(fsym, nv, nv, wsym, thresd, cutoff) - - Allocate (coeff(nbas*2, nv, 2)) - ! Noda 2021/12/27 max(nv) = nsec. max : (coeff(nbas*2,nsec,2)) - Do i = 1, nv - i0 = mosym(i) + ncore + ninact + nact - coeff(:, i, :) = itrfmo(:, i0, :) - End do - - coeff(:, :, 1) = MATMUL(coeff(:, :, 1), fsym(:, :)) - coeff(:, :, 2) = MATMUL(coeff(:, :, 2), fsym(:, :)) - - Do i = 1, nv - i0 = mosym(i) + ncore + ninact + nact - itrfmo(:, i0, :) = coeff(:, i, :) - End do - -! Kramers - pairs - - Do i = 1, nv - i0 = mosym(i) + ncore + ninact + nact + 1 - coeff(:, i, :) = itrfmo(:, i0, :) - End do - - coeff(:, :, 1) = MATMUL(coeff(:, :, 1), DCONJG(fsym(:, :))) - coeff(:, :, 2) = MATMUL(coeff(:, :, 2), DCONJG(fsym(:, :))) - - Do i = 1, nv - i0 = mosym(i) + ncore + ninact + nact + 1 - itrfmo(:, i0, :) = coeff(:, i, :) - End do - -! Kramers - pairs - - deallocate (coeff) - - Do i = 1, nv - i0 = mosym(i) - write (*, '(I4,F20.10)') i0, wsym(i) - end do - - Do i = 1, nv - i0 = mosym(i) - write (*, *) '' - write (*, *) 'new ', i0 + ninact + nact, 'th ms consists of ' - Do j = 1, nv - j0 = mosym(j) - if (ABS(fsym(j, i))**2 > 1.0d-03) then - write (*, '(I4," Weights ",F20.10)') j0 + ninact + nact, ABS(fsym(j, i))**2 - end if - end do - end do - deallocate (fsym) - deallocate (wsym) - deallocate (mosym) - end do - - readmo(1:nbas*2, nbas + 1:nbas*2, 1:2) = itrfmo(1:nbas*2, 1:nbas, 1:2) - - open (15, file='r4dorbcoeff_ivo', status='unknown', form='unformatted') - write (15) readmo - close (15) - goto 100 - -10 write (*, *) 'reading err of r4dorbcoeff' -! deallocate(fdmmy) - deallocate (readmo) - deallocate (itrfmo) - -100 write (*, *) 'fockivo_ty end' - end diff --git a/src/four_caspt2_module.f90 b/src/four_caspt2_module.f90 index a3d1f2a2..6b6b81d2 100644 --- a/src/four_caspt2_module.f90 +++ b/src/four_caspt2_module.f90 @@ -149,6 +149,6 @@ MODULE four_caspt2_module integer :: ierr, nprocs, rank character(50) :: mdcint_filename, mdcintnew, mdcint_debug, mdcint_int character(50) :: a1int, a2int, bint, c1int, c2int, c3int, d1int, d2int, d3int, eint, fint, gint, hint - integer, parameter :: normal_output = 3000, read_line_max = 1000 + integer, parameter :: normal_output = 3000, read_line_max = 1000, default_unit = 21 end MODULE four_caspt2_module diff --git a/src/hfc_casci.f90 b/src/hfc_casci.f90 deleted file mode 100644 index 9e2797b4..00000000 --- a/src/hfc_casci.f90 +++ /dev/null @@ -1,139 +0,0 @@ -! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= -! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= - - PROGRAM hfc_casci ! Hyperfine coupling constant calculation for perpendicular term at CASCI level - -! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= -! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= - - use four_caspt2_module - - Implicit NONE - integer :: ii, jj, iatom, iq, i, j, imo, jmo, nhomo, i0, j0 - logical :: test, cutoff -! real*8 :: - complex*16 :: dens, hfc(-1:1) - complex*16,allocatable :: ci(:) , hfcmo (:,:,:,:), mat(:,:) - - character*50 :: filename - -! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= -! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= -! - - write(*,*)'' - write(*,*)' Hyperfine coupling constant calculation for perpendicular term ' - write(*,*)' at CASCI level written by Abe in 2019' - write(*,*)'' - - open(5,file='active.inp',form='formatted',status='old') - read(5,'(I4)')ninact - read(5,'(I4)')nact - read(5,'(I4)')nsec - read(5,'(I4)')nelec - read(5,'(I4)')nroot - read(5,'(I4)')selectroot - close(5) - - nmo = ninact + nact + nsec - - write(*,*)'ninact =' ,ninact - write(*,*)'nact =' ,nact - write(*,*)'nsec =' ,nsec - write(*,*)'nelec =' ,nelec - write(*,*)'nroot =' ,nroot - write(*,*)'selectroot =' ,selectroot - write(*,*)'nmo =' ,nmo - - filename = 'r4dmoint1hfcpc' - - Allocate(hfcmo(nmo,nmo,-1:1,1:2)) - - open(unit=12,file=trim(filename), status='old', form='unformatted') - read(12) - do iatom=1,2 - do iq=-1,1 - read(12)((hfcmo(jmo,imo,iq,iatom),jmo=1,nmo),imo=1,nmo) - end do - end do - close(12) - - open(10,file='CIMAT1',form='unformatted',status='old') - - read(10) ndet - Allocate(idet(1:ndet)) - Allocate(mat(ndet,ndet)) - read(10) idet(1:ndet) - read(10) - read(10) mat(1:ndet,1:ndet) - close(10) - - Allocate(ci(ndet)) - ci = mat ( :, selectroot) - - Deallocate (mat) - - do j = 1, ndet - if((ABS(ci(j))**2) > 1.0d-02 ) then - i0 = idet(j) - write(*,*)(btest(i0,j0),j0=0,nact-1) - write(*,'(I4,2(3X,E14.7)," Weights ",E14.7)') & - & j, ci(j), ABS(ci(j))**2 - end if - end do - - - Allocate(cir(1:ndet,selectroot:selectroot)) - Allocate(cii(1:ndet,selectroot:selectroot)) - - cir(1:ndet,selectroot) = DBLE(ci(1:ndet)) - cii(1:ndet,selectroot) = DIMAG(ci(1:ndet)) - - deallocate(ci) - - - iroot = selectroot - hfc = 0.0d+00 - iatom = 1 - nhomo = nelec + ninact - write(*,*) 'nhomo,hfcmo(nhomo,nhomo,0,iatom) ',nhomo,hfcmo(nhomo,nhomo,0,iatom ) - write(*,*) 'nhomo,hfcmo(nhomo,nhomo+1,0,iatom) ',nhomo,hfcmo(nhomo,nhomo+1,0,iatom ) - write(*,*) 'nhomo,hfcmo(nhomo,nhomo+1,1,iatom) ',nhomo,hfcmo(nhomo,nhomo+1,1,iatom ) - write(*,*) 'nhomo,hfcmo(nhomo+1,nhomo,1,iatom) ',nhomo,hfcmo(nhomo+1,nhomo,1,iatom ) - write(*,*) 'nhomo,hfcmo(nhomo,nhomo+1,-1,iatom)',nhomo,hfcmo(nhomo,nhomo+1,-1,iatom ) - write(*,*) 'nhomo,hfcmo(nhomo+1,nhomo,-1,iatom) ',nhomo,hfcmo(nhomo+1,nhomo,-1,iatom ) - - iq = -1 - Do i = 1, nact - Do j = 1, nact - Call dim1_density_nondiag (i, j, dens) - ii = i + ninact - if(mod(j,2)==0) jj = j - 1 + ninact - if(mod(j,2)==1) jj = j + 1 + ninact -! write(*,*) 'ii,jj,dens,hfcmo(ii,jj,iq,iatom )',ii,jj,dens,hfcmo(ii,jj,iq,iatom ) - hfc(iq) = hfc(iq) + dens*hfcmo(ii,jj,iq,iatom ) - End do - End do - write(*,*)'hfc,iq', hfc(iq),iq - - iq = 0 - Do i = 1, nact - Do j = 1, nact - Call dim1_density_diag (i, j, dens) - ii = i + ninact - jj = j + ninact - write(*,*) 'ii,jj,dens,hfcmo(ii,jj,iq,iatom )',ii,jj,dens,hfcmo(ii,jj,iq,iatom ) - hfc(iq) = hfc(iq) + dens*hfcmo(ii,jj,iq,iatom ) - End do - End do - write(*,*)'hfc,iq', hfc(iq),iq - - deallocate (cir) - deallocate (cii) - deallocate (idet) - deallocate (hfcmo) - - END program hfc_casci - - - diff --git a/src/hfc_casci_per.f90 b/src/hfc_casci_per.f90 deleted file mode 100644 index 83f81b34..00000000 --- a/src/hfc_casci_per.f90 +++ /dev/null @@ -1,122 +0,0 @@ -! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= -! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= - - PROGRAM hfc_casci_per ! Hyperfine coupling constant calculation for perpendicular term at CASCI level - -! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= -! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= - - use four_caspt2_module - - Implicit NONE - integer :: ii, jj, iatom, iq, i, j, imo, jmo, i0, j0 - logical :: test, cutoff -! real*8 :: - complex*16 :: dens, hfc - complex*16,allocatable :: ci(:) , hfcmo (:,:,:,:), mat(:,:) - - character*50 :: filename - -! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= -! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= -! - - write(*,*)'' - write(*,*)' Hyperfine coupling constant calculation for perpendicular term ' - write(*,*)' at CASCI level written by Abe in 2019' - write(*,*)'' - - open(5,file='active.inp',form='formatted',status='old') - read(5,'(I4)')ninact - read(5,'(I4)')nact - read(5,'(I4)')nsec - read(5,'(I4)')nelec - read(5,'(I4)')nroot - read(5,'(I4)')selectroot - close(5) - - nmo = ninact + nact + nsec - - write(*,*)'ninact =' ,ninact - write(*,*)'nact =' ,nact - write(*,*)'nsec =' ,nsec - write(*,*)'nelec =' ,nelec - write(*,*)'nroot =' ,nroot - write(*,*)'selectroot =' ,selectroot - write(*,*)'nmo =' ,nmo - - filename = 'r4dmoint1hfcpc' - - Allocate(hfcmo(nmo,nmo,-1:1,1:2)) - - open(unit=12,file=trim(filename), status='old', form='unformatted') - read(12) - do iatom=1,2 - do iq=-1,1 - read(12)((hfcmo(jmo,imo,iq,iatom),jmo=1,nmo),imo=1,nmo) - end do - end do - close(12) - - open(10,file='CIMAT1',form='unformatted',status='old') - - read(10) ndet - Allocate(idet(1:ndet)) - Allocate(mat(ndet,ndet)) - read(10) idet(1:ndet) - read(10) - read(10) mat(1:ndet,1:ndet) - close(10) - - Allocate(ci(ndet)) - ci = mat ( :, selectroot) - - Deallocate (mat) - - do j = 1, ndet - if((ABS(ci(j))**2) > 1.0d-02 ) then - i0 = idet(j) - write(*,*)(btest(i0,j0),j0=0,nact-1) - write(*,'(I4,2(3X,E14.7)," Weights ",E14.7)') & - & j, ci(j), ABS(ci(j))**2 - end if - end do - - - Allocate(cir(1:ndet,selectroot:selectroot)) - Allocate(cii(1:ndet,selectroot:selectroot)) - - cir(1:ndet,selectroot) = DBLE(ci(1:ndet)) - cii(1:ndet,selectroot) = DIMAG(ci(1:ndet)) - - deallocate(ci) - - - iroot = selectroot - hfc = 0.0d+00 - iq = -1 - iatom = 1 - - Do i = 1, nact - Do j = 1, nact - Call dim1_density_nondiag (i, j, dens) - ii = i + ninact - if(mod(j,2)==0) jj = j - 1 + ninact - if(mod(j,2)==1) jj = j + 1 + ninact - write(*,*) 'ii,jj,dens,hfcmo(ii,jj,iq,iatom )',ii,jj,dens,hfcmo(ii,jj,iq,iatom ) - hfc = hfc + dens*hfcmo(ii,jj,iq,iatom ) - End do - End do - - write(*,*)'hfc', hfc - - deallocate (cir) - deallocate (cii) - deallocate (idet) - deallocate (hfcmo ) - - - END program hfc_casci_per - - - diff --git a/src/intmo.f90 b/src/intmo.f90 deleted file mode 100644 index 91bc61bd..00000000 --- a/src/intmo.f90 +++ /dev/null @@ -1,76 +0,0 @@ -! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= -! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= - - SUBROUTINE intmo1(i, j, int1) - -! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= -! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= - - use four_caspt2_module - - Implicit NONE - integer, intent(in) :: i, j - complex*16, intent(out) :: int1 - - integer :: sym1, sym2 - -! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= -! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= - - int1 = 0.0d+00 - sym1 = irpamo(i) - sym2 = irpamo(j) - -! If(sym1 == sym2) then - int1 = CMPLX(oner(i, j), onei(i, j), 16) -! End if - - End subroutine intmo1 - -! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= -! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= - - SUBROUTINE intmo2(i, j, k, l, int2) - -! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= -! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= - - use four_caspt2_module - - Implicit NONE - integer, intent(in) :: i, j, k, l - - complex*16, intent(out) :: int2 - - integer :: sym1, sym2, sym3, sym4 - integer :: nint - - real*8 :: i2r, i2i, nsign - -! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= -! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= - - int2 = 0.0d+00 - sym1 = irpamo(i) - sym2 = irpamo(j) - sym3 = irpamo(k) - sym4 = irpamo(l) - - ! If(MULTB(sym1,sym2) == MULTB(sym3,sym4)) then - - if (i == 15 .and. j == 3 .and. k == 4 .and. l == 4) write (*, *) 'int number', ABS(indtwr(i, j, k, l)) - - nint = ABS(indtwr(i, j, k, l)) - nsign = SIGN(1, indtwr(i, j, k, l)) - i2r = int2r(nint)*nsign - nsign = SIGN(1, indtwi(i, j, k, l)) - i2i = int2i(nint)*nsign - - int2 = CMPLX(i2r, i2i, 16) - -!Iwamuro modify -! write(*,'(3E15.5)')int2 - -! Endif - - End subroutine intmo2 diff --git a/src/intmo_ty.f90 b/src/intmo_ty.f90 deleted file mode 100644 index 9eb3e5a4..00000000 --- a/src/intmo_ty.f90 +++ /dev/null @@ -1,70 +0,0 @@ - -! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= -! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= - -SUBROUTINE intmo1_ty(i, j, int1) - -! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= -! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= - - use four_caspt2_module - - Implicit NONE - integer, intent(in) :: i, j - complex*16, intent(out) :: int1 - - integer :: sym1, sym2 - -! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= -! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= - - sym1 = irpamo(i) - sym2 = irpamo(j) - - If (MULTB_D(sym1, sym2) == 1) then - int1 = CMPLX(oner(i, j), onei(i, j), 16) - End if - -End subroutine intmo1_ty - -! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= -! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= - -SUBROUTINE intmo2_ty(i, j, k, l, int2) - -! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= -! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= - - use four_caspt2_module - - Implicit NONE - integer, intent(in) :: i, j, k, l - - complex*16, intent(out) :: int2 - - integer :: sym1, sym2, sym3, sym4, syma, symb, symc - real*8 :: i2r, i2i - -! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= -! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= - - sym1 = irpamo(i) - sym2 = irpamo(j) - sym3 = irpamo(k) - sym4 = irpamo(l) - syma = MULTB_D(sym1, sym2) - symb = MULTB_D(sym3, sym4) - symc = MULTB_S(syma, symb) - - If (symc == 1) then - - i2r = inttwr(i, j, k, l) - i2i = inttwi(i, j, k, l) - - int2 = CMPLX(i2r, i2i, 16) - - else - int2 = 0.0d+00 - End if - -End subroutine intmo2_ty diff --git a/src/intra.f90 b/src/intra.f90 index d1a0bc54..9ad8720b 100644 --- a/src/intra.f90 +++ b/src/intra.f90 @@ -6,6 +6,7 @@ SUBROUTINE intra_1(spi, spj, spk, spl, fname) ! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= ! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= + use module_file_manager use four_caspt2_module Implicit NONE @@ -14,8 +15,10 @@ SUBROUTINE intra_1(spi, spj, spk, spl, fname) #endif integer, intent(in) :: spi, spj, spk, spl character(50), intent(in) :: fname + logical :: is_end_of_file - integer, allocatable :: indsym(:, :, :), nsym(:, :) + integer :: unit + integer, allocatable :: indsym(:, :, :), nsym(:, :) complex*16, allocatable :: traint2(:, :, :, :) real*8 :: thresd @@ -26,7 +29,7 @@ SUBROUTINE intra_1(spi, spj, spk, spl, fname) integer :: nmx, ini(3), end(3), isp, isym, imo thresd = 1.0d-15 - + unit = default_unit ini(1) = 1 end(1) = ninact ini(2) = ninact + 1 @@ -73,17 +76,12 @@ SUBROUTINE intra_1(spi, spj, spk, spl, fname) ! ! !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - open (1, file=trim(fname), status='old', form='unformatted') ! no symmetry about spi,spj,spk,spl + call open_unformatted_file(unit=unit, file=trim(fname), status='old', optional_action='read') do - read (1, iostat=iostat) i, j, k, l, cint2 - ! Exit the loop if the end of the file is reached - if (iostat < 0) then - if (rank == 0) print *, 'End of '//trim(fname) + read (unit, iostat=iostat) i, j, k, l, cint2 + call check_iostat(iostat=iostat, file=trim(fname), end_of_file_reached=is_end_of_file) + if (is_end_of_file) then exit - elseif (iostat > 0) then - ! If iostat is greater than 0, error detected in the input file, so exit the program - print *, "Error : Error in reading file ", trim(fname) - stop end if isym = irpmo(l) @@ -100,10 +98,8 @@ SUBROUTINE intra_1(spi, spj, spk, spl, fname) l1 = indsym(spl, isym, lnew) traint2(i, j, k, l1) = traint2(i, j, k, l1) + cint2*f(l, l1) End do - end do - - close (1) + close (unit) #ifdef HAVE_MPI call MPI_Allreduce(MPI_IN_PLACE, traint2(ii, ji, ki, li), (ie - ii + 1)*(je - ji + 1)*(ke - ki + 1)*(le - li + 1), & @@ -115,9 +111,9 @@ SUBROUTINE intra_1(spi, spj, spk, spl, fname) ! !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - open (1, file=trim(fname), status='replace', form='unformatted') - call write_traint2_to_disk(ii, ie, ji, je, ki, ke, li, le, traint2(ii:ie, ji:je, ki:ke, li:le), thresd) - close (1) + call open_unformatted_file(unit=unit, file=trim(fname), status='old', optional_action='write') + call write_traint2_to_disk(ii, ie, ji, je, ki, ke, li, le, traint2(ii:ie, ji:je, ki:ke, li:le), thresd, unit) + close (unit) traint2 = 0.0d+00 @@ -126,17 +122,12 @@ SUBROUTINE intra_1(spi, spj, spk, spl, fname) ! ! !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - open (1, file=trim(fname), status='old', form='unformatted') + call open_unformatted_file(unit=unit, file=trim(fname), status='old', optional_action='read') do - read (1, iostat=iostat) i, j, k, l, cint2 - ! Exit the loop if the end of the file is reached - if (iostat < 0) then - if (rank == 0) print *, 'End of '//trim(fname) + read (unit, iostat=iostat) i, j, k, l, cint2 + call check_iostat(iostat=iostat, file=trim(fname), end_of_file_reached=is_end_of_file) + if (is_end_of_file) then exit - elseif (iostat > 0) then - ! If iostat is greater than 0, error detected in the input file, so exit the program - print *, "Error : Error in reading file ", trim(fname) - stop end if isym = irpmo(k) @@ -144,9 +135,9 @@ SUBROUTINE intra_1(spi, spj, spk, spl, fname) k1 = indsym(spk, isym, knew) traint2(i, j, k1, l) = traint2(i, j, k1, l) + cint2*DCONJG(f(k, k1)) End do - end do - close (1) + close (unit) + #ifdef HAVE_MPI call MPI_Allreduce(MPI_IN_PLACE, traint2(ii, ji, ki, li), (ie - ii + 1)*(je - ji + 1)*(ke - ki + 1)*(le - li + 1), & MPI_COMPLEX16, MPI_SUM, MPI_COMM_WORLD, ierr) @@ -157,10 +148,9 @@ SUBROUTINE intra_1(spi, spj, spk, spl, fname) ! !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - open (1, file=trim(fname), status='replace', form='unformatted') - call write_traint2_to_disk(ii, ie, ji, je, ki, ke, li, le, traint2(ii:ie, ji:je, ki:ke, li:le), thresd) - close (1) - + call open_unformatted_file(unit=unit, file=trim(fname), status='old', optional_action='write') + call write_traint2_to_disk(ii, ie, ji, je, ki, ke, li, le, traint2(ii:ie, ji:je, ki:ke, li:le), thresd, unit) + close (unit) traint2 = 0.0d+00 !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~! @@ -168,17 +158,12 @@ SUBROUTINE intra_1(spi, spj, spk, spl, fname) ! ! !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - open (1, file=trim(fname), status='old', form='unformatted') + call open_unformatted_file(unit=unit, file=trim(fname), status='old', optional_action='read') do - read (1, iostat=iostat) i, j, k, l, cint2 - ! Exit the loop if the end of the file is reached - if (iostat < 0) then - if (rank == 0) print *, 'End of '//trim(fname) + read (unit, iostat=iostat) i, j, k, l, cint2 + call check_iostat(iostat=iostat, file=trim(fname), end_of_file_reached=is_end_of_file) + if (is_end_of_file) then exit - elseif (iostat > 0) then - ! If iostat is greater than 0, error detected in the input file, so exit the program - print *, "Error : Error in reading file ", trim(fname) - stop end if isym = irpmo(j) @@ -186,10 +171,9 @@ SUBROUTINE intra_1(spi, spj, spk, spl, fname) j1 = indsym(spj, isym, jnew) traint2(i, j1, k, l) = traint2(i, j1, k, l) + cint2*f(j, j1) End do - end do + close (unit) - close (1) #ifdef HAVE_MPI call MPI_Allreduce(MPI_IN_PLACE, traint2(ii, ji, ki, li), (ie - ii + 1)*(je - ji + 1)*(ke - ki + 1)*(le - li + 1), & MPI_COMPLEX16, MPI_SUM, MPI_COMM_WORLD, ierr) @@ -200,10 +184,9 @@ SUBROUTINE intra_1(spi, spj, spk, spl, fname) ! !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - open (1, file=trim(fname), status='replace', form='unformatted') - call write_traint2_to_disk(ii, ie, ji, je, ki, ke, li, le, traint2(ii:ie, ji:je, ki:ke, li:le), thresd) - close (1) - + call open_unformatted_file(unit=unit, file=trim(fname), status='old', optional_action='write') + call write_traint2_to_disk(ii, ie, ji, je, ki, ke, li, le, traint2(ii:ie, ji:je, ki:ke, li:le), thresd, unit) + close (unit) traint2 = 0.0d+00 !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~! @@ -211,17 +194,12 @@ SUBROUTINE intra_1(spi, spj, spk, spl, fname) ! ! !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - open (1, file=trim(fname), status='old', form='unformatted') + call open_unformatted_file(unit=unit, file=trim(fname), status='old', optional_action='read') do - read (1, iostat=iostat) i, j, k, l, cint2 - ! Exit the loop if the end of the file is reached - if (iostat < 0) then - if (rank == 0) print *, 'End of '//trim(fname) + read (unit, iostat=iostat) i, j, k, l, cint2 + call check_iostat(iostat=iostat, file=trim(fname), end_of_file_reached=is_end_of_file) + if (is_end_of_file) then exit - elseif (iostat > 0) then - ! If iostat is greater than 0, error detected in the input file, so exit the program - print *, "Error : Error in reading file ", trim(fname) - stop end if isym = irpmo(i) @@ -229,9 +207,9 @@ SUBROUTINE intra_1(spi, spj, spk, spl, fname) i1 = indsym(spi, isym, inew) traint2(i1, j, k, l) = traint2(i1, j, k, l) + cint2*DCONJG(f(i, i1)) End do - end do - close (1) + close (unit) + #ifdef HAVE_MPI call MPI_Allreduce(MPI_IN_PLACE, traint2(ii, ji, ki, li), (ie - ii + 1)*(je - ji + 1)*(ke - ki + 1)*(le - li + 1), & MPI_COMPLEX16, MPI_SUM, MPI_COMM_WORLD, ierr) @@ -242,10 +220,9 @@ SUBROUTINE intra_1(spi, spj, spk, spl, fname) ! !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - open (1, file=trim(fname), status='replace', form='unformatted') - call write_traint2_to_disk_fourth(ii, ie, ji, je, ki, ke, li, le, traint2(ii:ie, ji:je, ki:ke, li:le), thresd) - close (1) - + call open_unformatted_file(unit=unit, file=trim(fname), status='old', optional_action='write') + call write_traint2_to_disk_fourth(ii, ie, ji, je, ki, ke, li, le, traint2(ii:ie, ji:je, ki:ke, li:le), thresd, unit) + close (unit) deallocate (traint2); Call memminus(KIND(traint2), SIZE(traint2), 2) deallocate (indsym); Call memminus(KIND(indsym), SIZE(indsym), 1) @@ -261,6 +238,7 @@ SUBROUTINE intra_2(spi, spj, spk, spl, fname) ! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= ! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= + use module_file_manager use four_caspt2_module Implicit NONE @@ -269,8 +247,10 @@ SUBROUTINE intra_2(spi, spj, spk, spl, fname) #endif integer, intent(in) :: spi, spj, spk, spl character(50), intent(in) :: fname + logical :: is_end_of_file - integer, allocatable :: indsym(:, :, :), nsym(:, :) + integer :: unit = 20 + integer, allocatable :: indsym(:, :, :), nsym(:, :) complex*16, allocatable :: traint2(:, :, :, :) real*8 :: thresd @@ -282,6 +262,7 @@ SUBROUTINE intra_2(spi, spj, spk, spl, fname) integer :: nmx, ini(3), end(3), isp, isym, imo, save, iostat thresd = 1.0d-15 + unit = default_unit if (.not. (spi == spk .and. spj == spl)) then print *, 'error intra_2', spi, spj, spk, spl @@ -331,17 +312,12 @@ SUBROUTINE intra_2(spi, spj, spk, spl, fname) ! ! !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - open (1, file=trim(fname), status='old', form='unformatted') + call open_unformatted_file(unit=unit, file=trim(fname), status='old', optional_action='read') do - read (1, iostat=iostat) i, j, k, l, cint2 - ! Exit the loop if the end of the file is reached - if (iostat < 0) then - if (rank == 0) print *, 'End of '//trim(fname) + read (unit, iostat=iostat) i, j, k, l, cint2 + call check_iostat(iostat=iostat, file=trim(fname), end_of_file_reached=is_end_of_file) + if (is_end_of_file) then exit - elseif (iostat > 0) then - ! If iostat is greater than 0, error detected in the input file, so exit the program - print *, "Error : Error in reading file ", trim(fname) - stop end if isym = irpmo(l) @@ -397,10 +373,8 @@ SUBROUTINE intra_2(spi, spj, spk, spl, fname) l1 = indsym(spl, isym, lnew) traint2(i, j, k, l1) = traint2(i, j, k, l1) + cint2*f(l, l1) End do - end do - - close (1) + close(unit) #ifdef HAVE_MPI call MPI_Allreduce(MPI_IN_PLACE, traint2(ii, ji, ki, li), (ie - ii + 1)*(je - ji + 1)*(ke - ki + 1)*(le - li + 1), & @@ -412,10 +386,9 @@ SUBROUTINE intra_2(spi, spj, spk, spl, fname) ! !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - open (1, file=trim(fname), status='replace', form='unformatted') - call write_traint2_to_disk(ii, ie, ji, je, ki, ke, li, le, traint2(ii:ie, ji:je, ki:ke, li:le), thresd) - close (1) - + call open_unformatted_file(unit=unit, file=trim(fname), status='old', optional_action='write') + call write_traint2_to_disk(ii, ie, ji, je, ki, ke, li, le, traint2(ii:ie, ji:je, ki:ke, li:le), thresd, unit) + close(unit) traint2 = 0.0d+00 !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~! @@ -423,18 +396,13 @@ SUBROUTINE intra_2(spi, spj, spk, spl, fname) ! ! !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - open (1, file=trim(fname), status='old', form='unformatted') + call open_unformatted_file(unit=unit, file=trim(fname), status='old', optional_action='read') do - read (1, iostat=iostat) i, j, k, l, cint2 - ! Exit the loop if the end of the file is reached - if (iostat < 0) then - if (rank == 0) print *, 'End of '//trim(fname) + read (unit, iostat=iostat) i, j, k, l, cint2 + call check_iostat(iostat=iostat, file=trim(fname), end_of_file_reached=is_end_of_file) + if (is_end_of_file) then exit - elseif (iostat > 0) then - ! If iostat is greater than 0, error detected in the input file, so exit the program - print *, "Error : Error in reading file ", trim(fname) - stop end if isym = irpmo(k) @@ -444,8 +412,8 @@ SUBROUTINE intra_2(spi, spj, spk, spl, fname) traint2(i, j, k1, l) = traint2(i, j, k1, l) + cint2*DCONJG(f(k, k1)) End do end do + close(unit) - close (1) #ifdef HAVE_MPI call MPI_Allreduce(MPI_IN_PLACE, traint2(ii, ji, ki, li), (ie - ii + 1)*(je - ji + 1)*(ke - ki + 1)*(le - li + 1), & MPI_COMPLEX16, MPI_SUM, MPI_COMM_WORLD, ierr) @@ -456,10 +424,9 @@ SUBROUTINE intra_2(spi, spj, spk, spl, fname) ! !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - open (1, file=trim(fname), status='replace', form='unformatted') - call write_traint2_to_disk(ii, ie, ji, je, ki, ke, li, le, traint2(ii:ie, ji:je, ki:ke, li:le), thresd) - close (1) - + call open_unformatted_file(unit=unit, file=trim(fname), status='old', optional_action='write') + call write_traint2_to_disk(ii, ie, ji, je, ki, ke, li, le, traint2(ii:ie, ji:je, ki:ke, li:le), thresd, unit) + close (unit) traint2 = 0.0d+00 !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~! @@ -467,17 +434,12 @@ SUBROUTINE intra_2(spi, spj, spk, spl, fname) ! ! !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - open (1, file=trim(fname), status='old', form='unformatted') + call open_unformatted_file(unit=unit, file=trim(fname), status='old', optional_action='read') do - read (1, iostat=iostat) i, j, k, l, cint2 -! Exit the loop if the end of the file is reached - if (iostat < 0) then - if (rank == 0) print *, 'End of '//trim(fname) + read (unit, iostat=iostat) i, j, k, l, cint2 + call check_iostat(iostat=iostat, file=trim(fname), end_of_file_reached=is_end_of_file) + if (is_end_of_file) then exit - elseif (iostat > 0) then - ! If iostat is greater than 0, error detected in the input file, so exit the program - print *, "Error : Error in reading file ", trim(fname) - stop end if isym = irpmo(j) @@ -486,10 +448,9 @@ SUBROUTINE intra_2(spi, spj, spk, spl, fname) j1 = indsym(spj, isym, jnew) traint2(i, j1, k, l) = traint2(i, j1, k, l) + cint2*f(j, j1) End do - end do + close(unit) - close (1) #ifdef HAVE_MPI call MPI_Allreduce(MPI_IN_PLACE, traint2(ii, ji, ki, li), (ie - ii + 1)*(je - ji + 1)*(ke - ki + 1)*(le - li + 1), & MPI_COMPLEX16, MPI_SUM, MPI_COMM_WORLD, ierr) @@ -500,10 +461,9 @@ SUBROUTINE intra_2(spi, spj, spk, spl, fname) ! !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - open (1, file=trim(fname), status='replace', form='unformatted') - call write_traint2_to_disk(ii, ie, ji, je, ki, ke, li, le, traint2(ii:ie, ji:je, ki:ke, li:le), thresd) - close (1) - + call open_unformatted_file(unit=unit, file=trim(fname), status='old', optional_action='write') + call write_traint2_to_disk(ii, ie, ji, je, ki, ke, li, le, traint2(ii:ie, ji:je, ki:ke, li:le), thresd, unit) + close (unit) traint2 = 0.0d+00 !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~! @@ -511,18 +471,12 @@ SUBROUTINE intra_2(spi, spj, spk, spl, fname) ! ! !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - open (1, file=trim(fname), status='old', form='unformatted') + call open_unformatted_file(unit=unit, file=trim(fname), status='old', optional_action='read') do - read (1, iostat=iostat) i, j, k, l, cint2 - - ! Exit the loop if the end of the file is reached - if (iostat < 0) then - if (rank == 0) print *, 'End of '//trim(fname) + read (unit, iostat=iostat) i, j, k, l, cint2 + call check_iostat(iostat=iostat, file=trim(fname), end_of_file_reached=is_end_of_file) + if (is_end_of_file) then exit - elseif (iostat > 0) then - ! If iostat is greater than 0, error detected in the input file, so exit the program - print *, "Error : Error in reading file ", trim(fname) - stop end if isym = irpmo(i) @@ -531,10 +485,9 @@ SUBROUTINE intra_2(spi, spj, spk, spl, fname) i1 = indsym(spi, isym, inew) traint2(i1, j, k, l) = traint2(i1, j, k, l) + cint2*DCONJG(f(i, i1)) End do - end do + close(unit) - close (1) #ifdef HAVE_MPI call MPI_Allreduce(MPI_IN_PLACE, traint2(ii, ji, ki, li), (ie - ii + 1)*(je - ji + 1)*(ke - ki + 1)*(le - li + 1), & MPI_COMPLEX16, MPI_SUM, MPI_COMM_WORLD, ierr) @@ -545,10 +498,9 @@ SUBROUTINE intra_2(spi, spj, spk, spl, fname) ! !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - open (1, file=trim(fname), status='replace', form='unformatted') - call write_traint2_to_disk_fourth(ii, ie, ji, je, ki, ke, li, le, traint2(ii:ie, ji:je, ki:ke, li:le), thresd) - close (1) - + call open_unformatted_file(unit=unit, file=trim(fname), status='old', optional_action='write') + call write_traint2_to_disk_fourth(ii, ie, ji, je, ki, ke, li, le, traint2(ii:ie, ji:je, ki:ke, li:le), thresd, unit) + close (unit) deallocate (traint2); Call memminus(KIND(traint2), SIZE(traint2), 2) deallocate (indsym); Call memminus(KIND(indsym), SIZE(indsym), 1) deallocate (nsym); Call memminus(KIND(nsym), SIZE(nsym), 1) @@ -563,6 +515,7 @@ SUBROUTINE intra_3(spi, spj, spk, spl, fname) ! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= ! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= + use module_file_manager use four_caspt2_module Implicit NONE @@ -571,7 +524,9 @@ SUBROUTINE intra_3(spi, spj, spk, spl, fname) #endif integer, intent(in) :: spi, spj, spk, spl character(50), intent(in) :: fname + logical :: is_end_of_file + integer :: unit = 20 integer, allocatable :: indsym(:, :, :), nsym(:, :) complex*16, allocatable :: traint2(:, :, :, :) @@ -585,6 +540,7 @@ SUBROUTINE intra_3(spi, spj, spk, spl, fname) integer :: nmx, ini(3), end(3), isp, isym, imo, iostat thresd = 1.0d-15 + unit = default_unit if (.not. (spk == spl)) then print *, 'error intra_3', spi, spj, spk, spl @@ -636,18 +592,12 @@ SUBROUTINE intra_3(spi, spj, spk, spl, fname) ! ! !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - open (1, file=trim(fname), status='old', form='unformatted') + call open_unformatted_file(unit=unit, file=trim(fname), status='old', optional_action='read') do - read (1, iostat=iostat) i, j, k, l, cint2 - - ! Exit the loop if the end of the file is reached - if (iostat < 0) then - if (rank == 0) print *, 'End of '//trim(fname) + read (unit, iostat=iostat) i, j, k, l, cint2 + call check_iostat(iostat=iostat, file=trim(fname), end_of_file_reached=is_end_of_file) + if (is_end_of_file) then exit - elseif (iostat > 0) then - ! If iostat is greater than 0, error detected in the input file, so exit the program - print *, "Error : Error in reading file ", trim(fname) - stop end if ! save initial indices i,j,k,l to initial_i,initial_j,initial_k,initial_l, respectively. @@ -696,10 +646,9 @@ SUBROUTINE intra_3(spi, spj, spk, spl, fname) l1 = indsym(spl, isym, lnew) traint2(i, j, k, l1) = traint2(i, j, k, l1) + cint2*f(l, l1) End do - end do + close(unit) - close (1) #ifdef HAVE_MPI call MPI_Allreduce(MPI_IN_PLACE, traint2(ii, ji, ki, li), (ie - ii + 1)*(je - ji + 1)*(ke - ki + 1)*(le - li + 1), & MPI_COMPLEX16, MPI_SUM, MPI_COMM_WORLD, ierr) @@ -710,10 +659,9 @@ SUBROUTINE intra_3(spi, spj, spk, spl, fname) ! !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - open (1, file=trim(fname), status='replace', form='unformatted') - call write_traint2_to_disk(ii, ie, ji, je, ki, ke, li, le, traint2(ii:ie, ji:je, ki:ke, li:le), thresd) - close (1) - + call open_unformatted_file(unit=unit, file=trim(fname), status='old', optional_action='write') + call write_traint2_to_disk(ii, ie, ji, je, ki, ke, li, le, traint2(ii:ie, ji:je, ki:ke, li:le), thresd, unit) + close(unit) traint2 = 0.0d+00 !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~! @@ -721,19 +669,12 @@ SUBROUTINE intra_3(spi, spj, spk, spl, fname) ! ! !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - if (rank == 0) print *, 'Read intergals and second index transformation' - open (1, file=trim(fname), status='old', form='unformatted') + call open_unformatted_file(unit=unit, file=trim(fname), status='old', optional_action='read') do - read (1, iostat=iostat) i, j, k, l, cint2 - - ! Exit the loop if the end of the file is reached - if (iostat < 0) then - if (rank == 0) print *, 'End of '//trim(fname) + read (unit, iostat=iostat) i, j, k, l, cint2 + call check_iostat(iostat=iostat, file=trim(fname), end_of_file_reached=is_end_of_file) + if (is_end_of_file) then exit - elseif (iostat > 0) then - ! If iostat is greater than 0, error detected in the input file, so exit the program - print *, "Error : Error in reading file ", trim(fname) - stop end if isym = irpamo(k) @@ -742,10 +683,9 @@ SUBROUTINE intra_3(spi, spj, spk, spl, fname) k1 = indsym(spk, isym, knew) traint2(i, j, k1, l) = traint2(i, j, k1, l) + cint2*DCONJG(f(k, k1)) End do - end do + close(unit) - close (1) #ifdef HAVE_MPI call MPI_Allreduce(MPI_IN_PLACE, traint2(ii, ji, ki, li), (ie - ii + 1)*(je - ji + 1)*(ke - ki + 1)*(le - li + 1), & MPI_COMPLEX16, MPI_SUM, MPI_COMM_WORLD, ierr) @@ -755,10 +695,10 @@ SUBROUTINE intra_3(spi, spj, spk, spl, fname) ! Storing integrals to disk ! !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - open (1, file=trim(fname), status='replace', form='unformatted') - call write_traint2_to_disk(ii, ie, ji, je, ki, ke, li, le, traint2(ii:ie, ji:je, ki:ke, li:le), thresd) - close (1) + call open_unformatted_file(unit=unit, file=trim(fname), status='old', optional_action='write') + call write_traint2_to_disk(ii, ie, ji, je, ki, ke, li, le, traint2(ii:ie, ji:je, ki:ke, li:le), thresd, unit) + close(unit) traint2 = 0.0d+00 !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~! @@ -766,18 +706,12 @@ SUBROUTINE intra_3(spi, spj, spk, spl, fname) ! ! !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - open (1, file=trim(fname), status='old', form='unformatted') + call open_unformatted_file(unit=unit, file=trim(fname), status='old', optional_action='read') do - read (1, iostat=iostat) i, j, k, l, cint2 - - ! Exit the loop if the end of the file is reached - if (iostat < 0) then - if (rank == 0) print *, 'End of '//trim(fname) + read (unit, iostat=iostat) i, j, k, l, cint2 + call check_iostat(iostat=iostat, file=trim(fname), end_of_file_reached=is_end_of_file) + if (is_end_of_file) then exit - elseif (iostat > 0) then - ! If iostat is greater than 0, error detected in the input file, so exit the program - print *, "Error : Error in reading file ", trim(fname) - stop end if isym = irpamo(j) @@ -786,10 +720,9 @@ SUBROUTINE intra_3(spi, spj, spk, spl, fname) j1 = indsym(spj, isym, jnew) traint2(i, j1, k, l) = traint2(i, j1, k, l) + cint2*f(j, j1) End do - end do + close(unit) - close (1) #ifdef HAVE_MPI call MPI_Allreduce(MPI_IN_PLACE, traint2(ii, ji, ki, li), (ie - ii + 1)*(je - ji + 1)*(ke - ki + 1)*(le - li + 1), & MPI_COMPLEX16, MPI_SUM, MPI_COMM_WORLD, ierr) @@ -800,10 +733,9 @@ SUBROUTINE intra_3(spi, spj, spk, spl, fname) ! !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - open (1, file=trim(fname), status='replace', form='unformatted') - call write_traint2_to_disk(ii, ie, ji, je, ki, ke, li, le, traint2(ii:ie, ji:je, ki:ke, li:le), thresd) - close (1) - + call open_unformatted_file(unit=unit, file=trim(fname), status='old', optional_action='write') + call write_traint2_to_disk(ii, ie, ji, je, ki, ke, li, le, traint2(ii:ie, ji:je, ki:ke, li:le), thresd, unit) + close(unit) traint2 = 0.0d+00 !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~! @@ -811,18 +743,12 @@ SUBROUTINE intra_3(spi, spj, spk, spl, fname) ! ! !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - open (1, file=trim(fname), status='old', form='unformatted') + call open_unformatted_file(unit=unit, file=trim(fname), status='old', optional_action='read') do - read (1, iostat=iostat) i, j, k, l, cint2 - - ! Exit the loop if the end of the file is reached - if (iostat < 0) then - if (rank == 0) print *, 'End of '//trim(fname) + read (unit, iostat=iostat) i, j, k, l, cint2 + call check_iostat(iostat=iostat, file=trim(fname), end_of_file_reached=is_end_of_file) + if (is_end_of_file) then exit - elseif (iostat > 0) then - ! If iostat is greater than 0, error detected in the input file, so exit the program - print *, "Error : Error in reading file ", trim(fname) - stop end if isym = irpamo(i) @@ -831,10 +757,9 @@ SUBROUTINE intra_3(spi, spj, spk, spl, fname) i1 = indsym(spi, isym, inew) traint2(i1, j, k, l) = traint2(i1, j, k, l) + cint2*DCONJG(f(i, i1)) End do - end do + close(unit) - close (1) #ifdef HAVE_MPI call MPI_Allreduce(MPI_IN_PLACE, traint2(ii, ji, ki, li), (ie - ii + 1)*(je - ji + 1)*(ke - ki + 1)*(le - li + 1), & MPI_COMPLEX16, MPI_SUM, MPI_COMM_WORLD, ierr) @@ -845,9 +770,9 @@ SUBROUTINE intra_3(spi, spj, spk, spl, fname) ! !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - open (1, file=trim(fname), status='replace', form='unformatted') - call write_traint2_to_disk_fourth(ii, ie, ji, je, ki, ke, li, le, traint2(ii:ie, ji:je, ki:ke, li:le), thresd) - close (1) + call open_unformatted_file(unit=unit, file=trim(fname), status='old', optional_action='write') + call write_traint2_to_disk_fourth(ii, ie, ji, je, ki, ke, li, le, traint2(ii:ie, ji:je, ki:ke, li:le), thresd, unit) + close(unit) if (rank == 0) print *, 'read and write file properly. filename : ', trim(fname) deallocate (traint2); Call memminus(KIND(traint2), SIZE(traint2), 2) @@ -856,7 +781,7 @@ SUBROUTINE intra_3(spi, spj, spk, spl, fname) end subroutine intra_3 -subroutine write_traint2_to_disk_fourth(ii, ie, ji, je, ki, ke, li, le, traint2, thresd) +subroutine write_traint2_to_disk_fourth(ii, ie, ji, je, ki, ke, li, le, traint2, thresd, unit) !============================================================================================== ! This is a writing subroutine for two-electron integrals ! after the fourth integral transformation. @@ -870,7 +795,7 @@ subroutine write_traint2_to_disk_fourth(ii, ie, ji, je, ki, ke, li, le, traint2, use four_caspt2_module, only: nprocs, rank implicit none integer :: n_cnt, i, j, k, l - integer, intent(in) :: ii, ie, ji, je, ki, ke, li, le + integer, intent(in) :: ii, ie, ji, je, ki, ke, li, le, unit real(8) :: thresd complex*16, intent(in) :: traint2(ii:ie, ji:je, ki:ke, li:le) integer :: i_tra, j_tra, k_tra, l_tra @@ -903,7 +828,7 @@ subroutine write_traint2_to_disk_fourth(ii, ie, ji, je, ki, ke, li, le, traint2, !=================================================================================================== if (ABS(traint2(i + i_tra, j + j_tra, k + k_tra, l + l_tra)) > thresd) then if (mod(n_cnt, nprocs) == rank) then ! Averaging the size of the subspace 2-integral file per a MPI process - write (1) i, j, k, l, traint2(i + i_tra, j + j_tra, k + k_tra, l + l_tra) + write (unit) i, j, k, l, traint2(i + i_tra, j + j_tra, k + k_tra, l + l_tra) end if n_cnt = n_cnt + 1 end if @@ -941,11 +866,11 @@ subroutine where_subspace_is(ini, end) end subroutine where_subspace_is end subroutine write_traint2_to_disk_fourth -subroutine write_traint2_to_disk(ii, ie, ji, je, ki, ke, li, le, traint2, thresd) +subroutine write_traint2_to_disk(ii, ie, ji, je, ki, ke, li, le, traint2, thresd, unit) use four_caspt2_module, only: nprocs, rank implicit none integer :: n_cnt, i, j, k, l - integer, intent(in) :: ii, ie, ji, je, ki, ke, li, le + integer, intent(in) :: ii, ie, ji, je, ki, ke, li, le, unit real(8) :: thresd complex*16, intent(in) :: traint2(ii:ie, ji:je, ki:ke, li:le) ! 4重ループを1重ループに変換する方法 @@ -966,7 +891,7 @@ subroutine write_traint2_to_disk(ii, ie, ji, je, ki, ke, li, le, traint2, thresd Do i = ii, ie if (ABS(traint2(i, j, k, l)) > thresd) then if (mod(n_cnt, nprocs) == rank) then ! Averaging the size of the subspace 2-integral file per a MPI process - write (1) i, j, k, l, traint2(i, j, k, l) + write (unit) i, j, k, l, traint2(i, j, k, l) end if ! if traint2(i,j,k,l)>thresd, all MPI process need to count up n_cnt!!! n_cnt = n_cnt + 1 diff --git a/src/matrixinv.f90 b/src/matrixinv.f90 deleted file mode 100644 index fde085f5..00000000 --- a/src/matrixinv.f90 +++ /dev/null @@ -1,31 +0,0 @@ -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -Subroutine matinv -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - implicit none - - real*8 :: a(x, x), c, dum - integer :: x, y, z, w - -!------------------------------------------ - - do z = 1, x - c = a(w, w) - a(w, w) = 1 - - do y = 1, x - a(w, z) = a(w, z)/c - end do - - do y = 1, x - if (y /= w) then - dum = a(y, w) - a(y, w) = 0 - do z = 1, x - a(y, z) = a(y, z) - dum*a(w, z) - end do - end if - end do - end do - -end subroutine matinv diff --git a/src/module_file_manager.f90 b/src/module_file_manager.f90 new file mode 100644 index 00000000..9843ad4b --- /dev/null +++ b/src/module_file_manager.f90 @@ -0,0 +1,121 @@ +module module_file_manager +!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=! +! module_file_manager +! Copyright (c) by the authors of rel-caspt2. +! Author K.Noda +! +! This is a utility module that manages the file unit number. +!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=! + use read_input_module, only: lowercase + implicit none + +contains + + subroutine check_iostat(iostat, file, end_of_file_reached) + implicit none + integer, intent(in) :: iostat + character(len=*), intent(in) :: file + logical, intent(out) :: end_of_file_reached + if (iostat == 0) then + end_of_file_reached = .false. + else if (iostat < 0) then + print *, "END OF FILE: ", file + end_of_file_reached = .true. + else + print *, "ERROR: Error occured while reading a file. file: ", file, " iostat: ", iostat + print *, "EXIT PROGRAM" + stop + end if + end subroutine check_iostat + + subroutine search_unused_file_unit(file_unit_number) + implicit none + integer, intent(inout) :: file_unit_number + logical :: opened + ! file_unit_number must be >= 21 + file_unit_number = 21 + ! Search for unused file unit + do + inquire (file_unit_number, opened=opened) + if (.not. opened) exit ! file_unit_number is unused, so we can use it + file_unit_number = file_unit_number + 1 ! Increment file_unit_number if the previous one is used + end do + end subroutine search_unused_file_unit + + subroutine check_file_open(file, iostat, unit) + implicit none + character(len=*), intent(in) :: file + integer, intent(in) :: iostat, unit + if (iostat .ne. 0) then + print *, 'ERROR: Failed to open ', file, ': iostat = ', iostat, ' unit = ', unit + print *, 'Exiting...' + stop + end if + end subroutine check_file_open + + subroutine open_file(unit, form, file, status, action) + implicit none + character(len=*), intent(in) :: form, file, status, action + integer, intent(inout) :: unit + character(:), allocatable :: file_status + integer :: iostat + call search_unused_file_unit(unit) + allocate(file_status,source = trim(status)) + call lowercase(file_status) + if (file_status /= 'old' .and. file_status /= 'new' .and. file_status /= 'replace') then + print *, 'ERROR: file_status must be old, new or replace. file_status = ', file_status + print *, 'Exiting...' + stop + end if + open (unit, form=form, file=file, status=status, iostat=iostat, action=action) + call check_file_open(file, iostat, unit) + end subroutine open_file + subroutine check_action_type(action, file) + implicit none + character(len=*), intent(in) :: action, file + if (action /= 'read' .and. action /= 'write' .and. action /= 'readwrite') then + print *, 'ERROR: action must be read, write or readwrite. action = ', action + print *, 'FILE NAME: ', file + print *, 'Exiting...' + stop + end if + end subroutine check_action_type + + subroutine open_unformatted_file(unit, file, status, optional_action) + implicit none + character(len=*), intent(in), optional :: optional_action + character(len=*), intent(in) :: file, status + integer, intent(inout) :: unit + character(:), allocatable :: actual_action, trimmed_action, form + + if (present(optional_action)) then + allocate (trimmed_action, source=trim(optional_action)) + call lowercase(trimmed_action) + call check_action_type(action=trimmed_action, file=file) + allocate (actual_action, source=trimmed_action) + else + allocate (actual_action, source='readwrite') + end if + allocate (form, source='unformatted') + call open_file(unit=unit, form=form, file=file, status=status, action=actual_action) + end subroutine open_unformatted_file + + subroutine open_formatted_file(unit, file, status, optional_action) + implicit none + character(len=*), intent(in), optional :: optional_action + character(len=*), intent(in) :: file, status + integer, intent(inout) :: unit + character(:), allocatable :: form, actual_action, trimmed_action + + if (present(optional_action)) then + allocate (trimmed_action, source=trim(optional_action)) + call lowercase(trimmed_action) + call check_action_type(action=trimmed_action, file=file) + allocate (actual_action, source=trimmed_action) + else + allocate (actual_action, source='readwrite') + end if + allocate (form, source='formatted') + call open_file(unit=unit, form=form, file=file, status=status, action=actual_action) + end subroutine open_formatted_file +end module module_file_manager diff --git a/src/nrintread.f90 b/src/nrintread.f90 deleted file mode 100644 index 4875958c..00000000 --- a/src/nrintread.f90 +++ /dev/null @@ -1,122 +0,0 @@ -! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= -! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= - -SUBROUTINE nrintread - -! This part is originally writen by Dr. T. Yanai as itrf code in program package UTChem. -! Here is modified for reading non-relativistic integrals to compute four-CASPT2 -! By M. Abe. -! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= -! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= - - use four_caspt2_module - - Implicit NONE -! real*8, intent(in) :: -! real*8, intent(in) :: - - integer :: ndim, intindx, ncount, redund, i, ii - integer :: nrint - integer :: val_integer - integer :: bitsize_integer - integer, Allocatable :: wrtidx(:, :), idx(:, :) - real*8, Allocatable :: val1(:) - character*50 :: filename - - bitsize_integer = KIND(val_integer)*8 - - filename = 'moint2.info.aaaa' - nrint = 11 - open (nrint, file=filename, status='old', access='sequential', form='formatted') - - read (nrint, *) ndim, intindx, ncount, redund - - close (nrint) - -! AT PRESENT RHF ORBITALS ARE ASSUMED! - - filename = 'moint2.aaaa' - open (nrint, file=trim(filename), & - status='old', access='sequential', form='unformatted') - - Allocate (wrtidx(intindx, ndim)) - Allocate (val1(ndim)) - Allocate (idx(4, ndim)) - - Do i = 1, ncount - - Read (nrint, ERR=40, END=50) wrtidx(1:intindx, 1:ndim) - Read (nrint, ERR=40, END=50) val1(1:ndim) - - Do ii = 1, ndim - - Select case (intindx) - - Case (1) - idx(1, ii) = IBITS(wrtidx(1, ii), bitsize_integer*3/4, bitsize_integer/4) - idx(2, ii) = IBITS(wrtidx(1, ii), bitsize_integer*2/4, bitsize_integer/4) - idx(3, ii) = IBITS(wrtidx(1, ii), bitsize_integer*1/4, bitsize_integer/4) - idx(4, ii) = IBITS(wrtidx(1, ii), bitsize_integer*0/4, bitsize_integer/4) - - Case (2) - idx(1, ii) = IBITS(wrtidx(1, ii), bitsize_integer*1/2, bitsize_integer/2) - idx(2, ii) = IBITS(wrtidx(1, ii), bitsize_integer*0/2, bitsize_integer/2) - idx(3, ii) = IBITS(wrtidx(2, ii), bitsize_integer*1/2, bitsize_integer/2) - idx(4, ii) = IBITS(wrtidx(2, ii), bitsize_integer*0/2, bitsize_integer/2) - - Case (4) - idx(1, ii) = wrtidx(1, ii) - idx(2, ii) = wrtidx(2, ii) - idx(3, ii) = wrtidx(3, ii) - idx(4, ii) = wrtidx(4, ii) - - Case default - write (*, *) "[INPUT ERROR] @Int2_idx : out of select ( 1 / 2 / 4 )" - stop - - end Select - - write (*, *) idx(1:intindx, ii) - write (*, *) val1(ii) - - End Do - - End do - - Read (nrint) wrtidx(:, 1:redund) - Read (nrint) val1(1:redund) - - Do ii = 1, redund - - Select case (intindx) - - Case (1) - idx(1, ii) = IBITS(wrtidx(1, ii), bitsize_integer*3/4, bitsize_integer/4) - idx(2, ii) = IBITS(wrtidx(1, ii), bitsize_integer*2/4, bitsize_integer/4) - idx(3, ii) = IBITS(wrtidx(1, ii), bitsize_integer*1/4, bitsize_integer/4) - idx(4, ii) = IBITS(wrtidx(1, ii), bitsize_integer*0/4, bitsize_integer/4) - - Case (2) - idx(1, ii) = IBITS(wrtidx(1, ii), bitsize_integer*1/2, bitsize_integer/2) - idx(2, ii) = IBITS(wrtidx(1, ii), bitsize_integer*0/2, bitsize_integer/2) - idx(3, ii) = IBITS(wrtidx(2, ii), bitsize_integer*1/2, bitsize_integer/2) - idx(4, ii) = IBITS(wrtidx(2, ii), bitsize_integer*0/2, bitsize_integer/2) - - Case (4) - idx(1, ii) = wrtidx(1, ii) - idx(2, ii) = wrtidx(2, ii) - idx(3, ii) = wrtidx(3, ii) - idx(4, ii) = wrtidx(4, ii) - - Case default - write (*, *) "[INPUT ERROR] @Int2_idx : out of select ( 1 / 2 / 4 )" - stop - - end Select - - End Do - -40 continue -50 continue - -end SUBROUTINE nrintread diff --git a/src/nrinttest.f90 b/src/nrinttest.f90 deleted file mode 100644 index a7149c32..00000000 --- a/src/nrinttest.f90 +++ /dev/null @@ -1,140 +0,0 @@ -! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= -! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= - -! SUBROUTINE nrintread - PROGRAM nrinttest - -! This part is originally writen by Dr. T. Yanai as itrf code in program package UTChem. -! Here is modified for reading non-relativistic integrals to compute four-CASPT2 -! By M. Abe. -! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= -! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= - - use four_caspt2_module - - Implicit NONE -! real*8, intent(in) :: -! real*8, intent(in) :: - - integer :: ndim, intindx, ncount, redund, i, ii - integer :: nrint, k - integer :: val_integer - integer :: bitsize_integer - integer, Allocatable :: wrtidx(:,:), idx(:,:) - real*8, Allocatable :: val(:) - character*50 :: filename - - write(*,*)' PROGRAM NRINTTEST' - bitsize_integer = KIND(val_integer)*8 - - filename='moint2.info.aaaa' - nrint = 11 - open (nrint, file=filename, status='old', access='sequential', form='formatted') - write(*,*)' open file info.aaaa OK' - read(nrint,*) ndim, intindx, ncount, redund - write(*,*)ndim, intindx, ncount, redund - - close(nrint) - -! AT PRESENT RHF ORBITALS ARE ASSUMED! - - filename ='moint2.aaaa' - open (nrint, file=trim(filename), & - status='old', access='sequential', form='unformatted') - write(*,*)' open file aaaa OK' - - If(ncount == 1) then - Allocate(wrtidx(1:intindx, 1:redund)) - Allocate(val(1:redund)) - Allocate(idx(4, 1:redund)) - Else - Allocate(wrtidx(1:intindx, 1:ndim)) - Allocate(val(1:ndim)) - Allocate(idx(4, 1:ndim)) - Endif - - wrtidx = 0 - val = 0.0d+00 - idx = 0 - - Do i = 1, ncount-1 - - Read(nrint,ERR=40,END=50) wrtidx(1:intindx,1:ndim) - Read(nrint,ERR=40,END=50) val(1:ndim) - - Do ii=1, ndim - - Select case(intindx) - - Case (1) - idx(1,ii) = IBITS(wrtidx(1,ii),bitsize_integer*3/4,bitsize_integer/4) - idx(2,ii) = IBITS(wrtidx(1,ii),bitsize_integer*2/4,bitsize_integer/4) - idx(3,ii) = IBITS(wrtidx(1,ii),bitsize_integer*1/4,bitsize_integer/4) - idx(4,ii) = IBITS(wrtidx(1,ii),bitsize_integer*0/4,bitsize_integer/4) - - Case (2) - idx(1,ii) = IBITS(wrtidx(1,ii),bitsize_integer*1/2,bitsize_integer/2) - idx(2,ii) = IBITS(wrtidx(1,ii),bitsize_integer*0/2,bitsize_integer/2) - idx(3,ii) = IBITS(wrtidx(2,ii),bitsize_integer*1/2,bitsize_integer/2) - idx(4,ii) = IBITS(wrtidx(2,ii),bitsize_integer*0/2,bitsize_integer/2) - - Case (4) - idx(1,ii) = wrtidx(1,ii) - idx(2,ii) = wrtidx(2,ii) - idx(3,ii) = wrtidx(3,ii) - idx(4,ii) = wrtidx(4,ii) - - Case default - write(*,*) "[INPUT ERROR] @Int2_idx : out of select ( 1 / 2 / 4 )" - stop - - end Select - - idx = idx - ncore - write(*,*) idx(1:4, i) - write(*,*) val(i) - - End Do - - End do - - Read(nrint) wrtidx(:,1:redund) - Read(nrint) val(1:redund) - - - Do ii=1,redund - - Select case(intindx) - - Case (1) - idx(1,ii) = IBITS(wrtidx(1,ii),bitsize_integer*3/4,bitsize_integer/4) - idx(2,ii) = IBITS(wrtidx(1,ii),bitsize_integer*2/4,bitsize_integer/4) - idx(3,ii) = IBITS(wrtidx(1,ii),bitsize_integer*1/4,bitsize_integer/4) - idx(4,ii) = IBITS(wrtidx(1,ii),bitsize_integer*0/4,bitsize_integer/4) - - Case (2) - idx(1,ii) = IBITS(wrtidx(1,ii),bitsize_integer*1/2,bitsize_integer/2) - idx(2,ii) = IBITS(wrtidx(1,ii),bitsize_integer*0/2,bitsize_integer/2) - idx(3,ii) = IBITS(wrtidx(2,ii),bitsize_integer*1/2,bitsize_integer/2) - idx(4,ii) = IBITS(wrtidx(2,ii),bitsize_integer*0/2,bitsize_integer/2) - - Case (4) - idx(1,ii) = wrtidx(1,ii) - idx(2,ii) = wrtidx(2,ii) - idx(3,ii) = wrtidx(3,ii) - idx(4,ii) = wrtidx(4,ii) - - Case default - write(*,*) "[INPUT ERROR] @Int2_idx : out of select ( 1 / 2 / 4 )" - stop - - end Select - write(*,*) idx(1:4, ii),val(ii) - - End Do - - -40 continue -50 continue - -end PROGRAM nrinttest diff --git a/src/pgsym_co.f90 b/src/pgsym_co.f90 deleted file mode 100644 index a36cf201..00000000 --- a/src/pgsym_co.f90 +++ /dev/null @@ -1,496 +0,0 @@ -! ================================================= - -SUBROUTINE c1sym_sd(DS) ! double-single multiplication - -! ================================================= - use four_caspt2_module - - Implicit NONE - Integer :: DS(1, 1), SD(1, 1), i, j, hnsym - - NSYMRP = 1 - NSYMRPA = 1 - REPNA(1) = 'a'; REPNA(2) = 'a' - - SD(1, 1) = 1 - DS(1, 1) = 1 - - MULTB_S = 1 - MULTB_D = 1 - MULTB_DS = 1 - irpmo = 1 - -end subroutine c1sym_sd - -! ================================================= - -SUBROUTINE c2sym_sd(DS) ! double-single multiplication - -! ================================================= - use four_caspt2_module - - Implicit NONE - Integer :: DS(2, 2), SD(2, 2), i, j, hnsym - - NSYMRP = 2 - REPNA(1) = '1e1/2'; REPNA(2) = '2e1/2' - REPNA(3) = 'a '; REPNA(4) = 'b ' - -!indices 1-2 when singles 1-2 -!indices 1-2 when doubles 3-4 - - SD(1, 1) = 1; SD(1, 2) = 2 - SD(2, 1) = 2; SD(2, 2) = 1 - - DS = SD - -end subroutine c2sym_sd - -! ================================================= - -SUBROUTINE c4sym_sd(DS) ! double-single multiplication - -! ================================================= - - use four_caspt2_module - - Implicit NONE - Integer :: SD(4, 4), DS(4, 4), i, j, hnsym - - NSYMRP = 4 - REPNA(1) = '1e1/2'; REPNA(2) = '2e1/2'; REPNA(4) = '1e3/2 '; REPNA(4) = '2e3/2'; - REPNA(5) = 'a '; REPNA(6) = 'b '; REPNA(6) = '1e '; REPNA(8) = '2e ' - -!indices 1-hnsym when singles 1-hnsym when doubles hnsym+1-nsymrp - - SD(1, 1) = 1; SD(1, 2) = 2; SD(1, 3) = 3; SD(1, 4) = 4 - SD(2, 1) = 3; SD(2, 2) = 4; SD(2, 3) = 1; SD(2, 4) = 2 - SD(3, 1) = 4; SD(3, 2) = 1; SD(3, 3) = 2; SD(3, 4) = 3 - SD(4, 1) = 2; SD(4, 2) = 3; SD(4, 3) = 4; SD(4, 4) = 1 - - Do i = 1, nsymrp - Do j = 1, nsymrp - DS(i, j) = SD(j, i) - End do - End do - -end subroutine c4sym_sd - -! ================================================= - -SUBROUTINE c6sym_sd(DS) ! double-single multiplication - -! ================================================= - - use four_caspt2_module - - Implicit NONE - Integer :: DS(6, 6), SD(6, 6), i, j, hnsym - - NSYMRP = 6 - REPNA(1) = '1e1/2'; REPNA(2) = '2e1/2'; REPNA(3) = '1e3/2'; REPNA(4) = '2e3/2'; REPNA(5) = '1e5/2'; REPNA(6) = '2e5/2' - REPNA(7) = 'a '; REPNA(8) = 'b '; REPNA(9) = '1e1 '; REPNA(10) = '2e1 '; REPNA(11) = '1e2 '; REPNA(12) = '2e2 ' - - SD(1, 1) = 1; SD(1, 2) = 2; SD(1, 3) = 3; SD(1, 4) = 4; SD(1, 5) = 5; SD(1, 6) = 6 - SD(2, 1) = 6; SD(2, 2) = 5; SD(2, 3) = 4; SD(2, 4) = 3; SD(2, 5) = 2; SD(2, 6) = 1 - SD(3, 1) = 2; SD(3, 2) = 3; SD(3, 3) = 6; SD(3, 4) = 1; SD(3, 5) = 4; SD(3, 6) = 5 - SD(4, 1) = 4; SD(4, 2) = 1; SD(4, 3) = 2; SD(4, 4) = 5; SD(4, 5) = 6; SD(4, 6) = 3 - SD(5, 1) = 5; SD(5, 2) = 4; SD(5, 3) = 1; SD(5, 4) = 6; SD(5, 5) = 3; SD(5, 6) = 2 - SD(6, 1) = 3; SD(6, 2) = 6; SD(6, 3) = 5; SD(6, 4) = 2; SD(6, 5) = 1; SD(6, 6) = 4 - - Do i = 1, nsymrp - Do j = 1, nsymrp - DS(i, j) = SD(j, i) - End do - End do - -end subroutine c6sym_sd - -! ================================================= - -SUBROUTINE c8sym_sd(DS) ! double-single multiplication - -! ================================================= - - use four_caspt2_module - - Implicit NONE - Integer :: DS(8, 8), SD(8, 8), i, j, hnsym - - NSYMRP = 8 - REPNA(1) = '1e1/2'; REPNA(2) = '2e1/2' - REPNA(3) = '1e3/2'; REPNA(4) = '2e3/2' - REPNA(5) = '1e5/2'; REPNA(6) = '2e5/2' - REPNA(7) = '1e7/2'; REPNA(8) = '2e7/2' - - REPNA(9) = 'a '; REPNA(10) = 'b ' - REPNA(11) = '1e1 '; REPNA(12) = '2e1 ' - REPNA(13) = '1e2 '; REPNA(14) = '2e2 ' - REPNA(15) = '1e3 '; REPNA(16) = '2e3 ' - - SD(1, 1) = 1; SD(1, 2) = 2; SD(1, 3) = 3; SD(1, 4) = 4 - SD(1, 5) = 5; SD(1, 6) = 6; SD(1, 7) = 7; SD(1, 8) = 8 - SD(2, 1) = 7; SD(2, 2) = 8; SD(2, 3) = 5; SD(2, 4) = 6 - SD(2, 5) = 3; SD(2, 6) = 4; SD(2, 7) = 1; SD(2, 8) = 2 - SD(3, 1) = 2; SD(3, 2) = 3; SD(3, 3) = 6; SD(3, 4) = 1 - SD(3, 5) = 4; SD(3, 6) = 7; SD(3, 7) = 8; SD(3, 8) = 5 - SD(4, 1) = 4; SD(4, 2) = 1; SD(4, 3) = 2; SD(4, 4) = 5 - SD(4, 5) = 8; SD(4, 6) = 3; SD(4, 7) = 6; SD(4, 8) = 7 - SD(5, 1) = 3; SD(5, 2) = 6; SD(5, 3) = 6; SD(5, 4) = 2 - SD(5, 5) = 1; SD(5, 6) = 8; SD(5, 7) = 5; SD(5, 8) = 4 - SD(6, 1) = 5; SD(6, 2) = 4; SD(6, 3) = 1; SD(6, 4) = 8 - SD(6, 5) = 7; SD(6, 6) = 2; SD(6, 7) = 3; SD(6, 8) = 6 - SD(7, 1) = 8; SD(7, 2) = 5; SD(7, 3) = 4; SD(7, 4) = 7 - SD(7, 5) = 6; SD(7, 6) = 1; SD(7, 7) = 2; SD(7, 8) = 3 - SD(8, 1) = 6; SD(8, 2) = 7; SD(8, 3) = 8; SD(8, 4) = 3 - SD(8, 5) = 2; SD(8, 6) = 5; SD(8, 7) = 4; SD(8, 8) = 1 - - Do i = 1, nsymrp - Do j = 1, nsymrp - DS(i, j) = SD(j, i) - End do - End do - -end subroutine c8sym_sd - -! ================================================= - -SUBROUTINE c2hsym_sd(DS) ! double-single multiplication - -! ================================================= - use four_caspt2_module - - Implicit NONE - Integer :: DS(4, 4), SD(4, 4), i, j, hnsym - - NSYMRP = 4 - REPNA(1) = '1e1/2g'; REPNA(2) = '2e1/2g'; REPNA(3) = '1e1/2u'; REPNA(4) = '2e1/2u' - REPNA(5) = 'ag '; REPNA(6) = 'bg '; REPNA(7) = 'au '; REPNA(8) = 'bu ' - -!indices 1-4 when singles 1-4 -!indices 1-4 when doubles 5-8 - - SD(1, 1) = 1; SD(1, 2) = 2 - SD(2, 1) = 2; SD(2, 2) = 1 - - hnsym = Int(nsymrp/2) - Do i = 1, hnsym - Do j = 1, hnsym - SD(i, j + hnsym) = SD(i, j) + hnsym - End do - End do - - Do i = 1, hnsym - Do j = 1, hnsym - SD(i + hnsym, j) = SD(i, j + hnsym) - End do - End do - - Do i = 1, hnsym - Do j = 1, hnsym - SD(i + hnsym, j + hnsym) = SD(i, j) - End do - End do - - Do i = 1, nsymrp - Do j = 1, nsymrp - DS(i, j) = SD(j, i) - End do - End do - -end subroutine c2hsym_sd - -! ================================================= - -SUBROUTINE c4hsym_sd(DS) ! double-single multiplication - -! ================================================= - use four_caspt2_module - - Implicit NONE - Integer :: DS(8, 8), SD(8, 8), i, j, hnsym - - NSYMRP = 8 - REPNA(1) = '1e1/2g'; REPNA(2) = '2e1/2g'; REPNA(3) = '1e3/2g'; REPNA(4) = '2e3/2g' - REPNA(5) = '1e1/2u'; REPNA(6) = '2e1/2u'; REPNA(7) = '1e3/2u'; REPNA(8) = '2e3/2u' - REPNA(9) = 'ag '; REPNA(10) = 'bg '; REPNA(11) = '1eg '; REPNA(12) = '2eg ' - REPNA(13) = 'au '; REPNA(14) = 'bu '; REPNA(15) = '1eu '; REPNA(16) = '2eu ' - -!indices 1-8 when singles 1-8 -!indices 1-8 when doubles 9-16 - - SD(1, 1) = 1; SD(1, 2) = 2; SD(1, 3) = 3; SD(1, 4) = 4 - SD(2, 1) = 3; SD(2, 2) = 4; SD(2, 3) = 1; SD(2, 4) = 2 - SD(3, 1) = 4; SD(3, 2) = 1; SD(3, 3) = 2; SD(3, 4) = 3 - SD(4, 1) = 2; SD(4, 2) = 3; SD(4, 3) = 4; SD(4, 4) = 1 - - hnsym = Int(nsymrp/2) - Do i = 1, hnsym - Do j = 1, hnsym - SD(i, j + hnsym) = SD(i, j) + hnsym - End do - End do - - Do i = 1, hnsym - Do j = 1, hnsym - SD(i + hnsym, j) = SD(i, j + hnsym) - End do - End do - - Do i = 1, hnsym - Do j = 1, hnsym - SD(i + hnsym, j + hnsym) = SD(i, j) - End do - End do - - Do i = 1, nsymrp - Do j = 1, nsymrp - DS(i, j) = SD(j, i) - End do - End do - -end subroutine c4hsym_sd - -! ================================================= - -SUBROUTINE c6hsym_sd(DS) ! double-single multiplication - -! ================================================= - use four_caspt2_module - - Implicit NONE - Integer :: DS(12, 12), SD(12, 12), i, j, hnsym - - NSYMRP = 12 - REPNA(1) = '1e1/2g'; REPNA(2) = '2e1/2g'; REPNA(3) = '1e3/2g'; REPNA(4) = '2e3/2g'; REPNA(5) = '1e5/2g'; REPNA(6) = '2e5/2g' - REPNA(7) = '1e1/2u'; REPNA(8) = '2e1/2u'; REPNA(9) = '1e3/2u'; REPNA(10) = '2e3/2u'; REPNA(11) = '1e5/2u'; REPNA(12) = '2e5/2u' - REPNA(13) = 'ag '; REPNA(14) = 'bg '; REPNA(15) = '1e1g '; REPNA(16) = '2e1g '; REPNA(17) = '1e2g '; REPNA(18) = '2e2g ' - REPNA(19) = 'au '; REPNA(20) = 'bu '; REPNA(21) = '1e1u '; REPNA(22) = '2e1u '; REPNA(23) = '1e2u '; REPNA(24) = '2e2u ' - -!indices 1-hnsym when singles 1-hnsym when doubles hnsym+1-nsymrp - - SD(1, 1) = 1; SD(1, 2) = 2; SD(1, 3) = 3; SD(1, 4) = 4; SD(1, 5) = 5; SD(1, 6) = 6 - SD(2, 1) = 5; SD(2, 2) = 6; SD(2, 3) = 4; SD(2, 4) = 3; SD(2, 5) = 2; SD(2, 6) = 1 - SD(3, 1) = 2; SD(3, 2) = 3; SD(3, 3) = 6; SD(3, 4) = 1; SD(3, 5) = 4; SD(3, 6) = 5 - SD(4, 1) = 4; SD(4, 2) = 1; SD(4, 3) = 2; SD(4, 4) = 5; SD(4, 5) = 6; SD(4, 6) = 3 - SD(5, 1) = 5; SD(5, 2) = 4; SD(5, 3) = 1; SD(5, 4) = 6; SD(5, 5) = 3; SD(5, 6) = 2 - SD(6, 1) = 3; SD(6, 2) = 6; SD(6, 3) = 5; SD(6, 4) = 2; SD(6, 5) = 1; SD(6, 6) = 4 - - hnsym = Int(nsymrp/2) - Do i = 1, hnsym - Do j = 1, hnsym - SD(i, j + hnsym) = SD(i, j) + hnsym - End do - End do - - Do i = 1, hnsym - Do j = 1, hnsym - SD(i + hnsym, j) = SD(i, j + hnsym) - End do - End do - - Do i = 1, hnsym - Do j = 1, hnsym - SD(i + hnsym, j + hnsym) = SD(i, j) - End do - End do - - Do i = 1, nsymrp - Do j = 1, nsymrp - DS(i, j) = SD(j, i) - End do - End do - -end subroutine c6hsym_sd - -! ================================================= - -SUBROUTINE c8hsym_sd(DS) ! double-single multiplication - -! ================================================= - use four_caspt2_module - - Implicit NONE - Integer :: DS(16, 16), SD(16, 16), i, j, hnsym - - write (*, *) 'pass c8hsym' - - NSYMRP = 16 - REPNA(1) = '1e1/2g'; REPNA(2) = '2e1/2g'; REPNA(3) = '1e3/2g'; REPNA(4) = '2e3/2g' - REPNA(5) = '1e5/2g'; REPNA(6) = '2e5/2g'; REPNA(7) = '1e7/2g'; REPNA(8) = '2e7/2g' - REPNA(9) = '1e1/2u'; REPNA(10) = '2e1/2u'; REPNA(11) = '1e3/2u'; REPNA(12) = '2e3/2u' - REPNA(13) = '1e5/2u'; REPNA(14) = '2e5/2u'; REPNA(15) = '1e7/2u'; REPNA(16) = '2e7/2u' - - REPNA(17) = 'ag '; REPNA(18) = 'bg '; REPNA(19) = '1e1g '; REPNA(20) = '2e1g ' - REPNA(21) = '1e2g '; REPNA(22) = '2e2g '; REPNA(23) = '1e3g '; REPNA(24) = '2e3g ' - REPNA(25) = 'au '; REPNA(26) = 'bu '; REPNA(27) = '1e1u '; REPNA(28) = '2e1u ' - REPNA(29) = '1e2u '; REPNA(30) = '2e2u '; REPNA(31) = '1e3u '; REPNA(32) = '2e3u ' - -!indices 1-hnsym when singles 1-hnsym when doubles hnsym+1-nsymrp - - SD(1, 1) = 1; SD(1, 2) = 2; SD(1, 3) = 3; SD(1, 4) = 4; SD(1, 5) = 5; SD(1, 6) = 6; SD(1, 7) = 7; SD(1, 8) = 8 - SD(2, 1) = 7; SD(2, 2) = 8; SD(2, 3) = 5; SD(2, 4) = 6; SD(2, 5) = 3; SD(2, 6) = 4; SD(2, 7) = 1; SD(2, 8) = 2 - SD(3, 1) = 2; SD(3, 2) = 3; SD(3, 3) = 6; SD(3, 4) = 1; SD(3, 5) = 4; SD(3, 6) = 7; SD(3, 7) = 8; SD(3, 8) = 5 - SD(4, 1) = 4; SD(4, 2) = 1; SD(4, 3) = 2; SD(4, 4) = 5; SD(4, 5) = 8; SD(4, 6) = 3; SD(4, 7) = 6; SD(4, 8) = 7 - SD(5, 1) = 3; SD(5, 2) = 6; SD(5, 3) = 7; SD(5, 4) = 2; SD(5, 5) = 1; SD(5, 6) = 8; SD(5, 7) = 5; SD(5, 8) = 4 - SD(6, 1) = 5; SD(6, 2) = 4; SD(6, 3) = 1; SD(6, 4) = 8; SD(6, 5) = 7; SD(6, 6) = 2; SD(6, 7) = 3; SD(6, 8) = 6 - SD(7, 1) = 8; SD(7, 2) = 5; SD(7, 3) = 4; SD(7, 4) = 7; SD(7, 5) = 6; SD(7, 6) = 5; SD(7, 7) = 2; SD(7, 8) = 3 - SD(8, 1) = 6; SD(8, 2) = 7; SD(8, 3) = 8; SD(8, 4) = 3; SD(8, 5) = 2; SD(8, 6) = 1; SD(8, 7) = 4; SD(8, 8) = 1 - - hnsym = nsymrp/2 - Do i = 1, hnsym - Do j = 1, hnsym - SD(i, j + hnsym) = SD(i, j) + hnsym - End do - End do - - Do i = 1, hnsym - Do j = 1, hnsym - SD(i + hnsym, j) = SD(i, j + hnsym) - End do - End do - - Do i = 1, hnsym - Do j = 1, hnsym - SD(i + hnsym, j + hnsym) = SD(i, j) - End do - End do - - write (*, *) 'MULTB_SD c8hsym' - Do i = 1, nsymrp - write (*, '(50I3)') (SD(i, j), j=1, nsymrp) - End do - - Do i = 1, nsymrp - Do j = 1, nsymrp - DS(i, j) = SD(j, i) - End do - End do - - write (*, *) 'MULTB_DS c8hsym' - Do i = 1, nsymrp - write (*, '(50I3)') (DS(i, j), j=1, nsymrp) - End do - -end subroutine c8hsym_sd - -! ================================================= - -SUBROUTINE c32hsym_sd(DS) ! double-single multiplication - -! ================================================= - use four_caspt2_module - - Implicit NONE - Integer :: DS(32, 32), SD(32, 32), i, j, hnsym, mrconee, i0, j0 - -! NSYMRP=32 - REPNA(1) = '1e1/2g'; REPNA(2) = '2e1/2g'; REPNA(3) = '1e3/2g'; REPNA(4) = '2e3/2g' - REPNA(5) = '1e5/2g'; REPNA(6) = '2e5/2g'; REPNA(7) = '1e7/2g'; REPNA(8) = '2e7/2g' - REPNA(9) = '1e9/2g'; REPNA(10) = '2e9/2g'; REPNA(11) = '1e11/2g'; REPNA(12) = '2e11/2g' - REPNA(13) = '1e13/2g'; REPNA(14) = '2e13/2g'; REPNA(15) = '1e15/2g'; REPNA(16) = '2e15/2g' - REPNA(17) = '1e1/2u'; REPNA(18) = '2e1/2u'; REPNA(19) = '1e3/2u'; REPNA(20) = '2e3/2u' - REPNA(21) = '1e5/2u'; REPNA(22) = '2e5/2u'; REPNA(23) = '1e7/2u'; REPNA(24) = '2e7/2u' - REPNA(25) = '1e9/2u'; REPNA(26) = '2e9/2u'; REPNA(27) = '1e11/2u'; REPNA(28) = '2e11/2u' - REPNA(29) = '1e13/2u'; REPNA(30) = '2e13/2u'; REPNA(31) = '1e15/2u'; REPNA(32) = '2e15/2u' - - REPNA(33) = 'ag '; REPNA(34) = 'bg '; REPNA(35) = '1e1g '; REPNA(36) = '2e1g ' - REPNA(37) = '1e2g '; REPNA(38) = '2e2g '; REPNA(39) = '1e3g '; REPNA(40) = '2e3g ' - REPNA(41) = '1e4g '; REPNA(42) = '2e4g '; REPNA(43) = '1e5g '; REPNA(44) = '2e5g ' - REPNA(45) = '1e6g '; REPNA(46) = '2e6g '; REPNA(47) = '1e7g '; REPNA(48) = '2e7g ' - REPNA(49) = 'au '; REPNA(50) = 'bu '; REPNA(51) = '1e1u '; REPNA(52) = '2e1u ' - REPNA(53) = '1e2u '; REPNA(54) = '2e2u '; REPNA(55) = '1e3u '; REPNA(56) = '2e3u ' - REPNA(57) = '1e4u '; REPNA(58) = '2e4u '; REPNA(59) = '1e5u '; REPNA(60) = '2e5u ' - REPNA(61) = '1e7u '; REPNA(62) = '2e7u '; REPNA(63) = '1e9u '; REPNA(64) = '2e9u ' - -! write(*,*) 'MULTB' - -! Do i0 = 1, 2*nsymrpa -! write(*,'(400I3)') (MULTB(i0, j0) ,j0 = 1, 2*nsymrpa) -! End do - - Do i = 1, nsymrpa/2 - Do j = 1, nsymrpa/2 - SD(i, j) = MULTB(i + nsymrpa, j) - End do - End do - - hnsym = nsymrpa/2 - Do i = 1, hnsym - Do j = 1, hnsym - SD(i, j + hnsym) = SD(i, j) + hnsym - End do - End do - - Do i = 1, hnsym - Do j = 1, hnsym - SD(i + hnsym, j) = SD(i, j + hnsym) - End do - End do - - Do i = 1, hnsym - Do j = 1, hnsym - SD(i + hnsym, j + hnsym) = SD(i, j) - End do - End do - - write (*, *) 'MULTB_SD c32hsym' - Do i = 1, nsymrpa - write (*, '(50I3)') (SD(i, j), j=1, nsymrpa) - End do - - Do i = 1, nsymrpa - Do j = 1, nsymrpa - DS(i, j) = SD(j, i) - End do - End do - - write (*, *) 'MULTB_DS c32hsym' - Do i = 1, nsymrpa - write (*, '(50I3)') (DS(i, j), j=1, nsymrpa) - End do - -end subroutine c32hsym_sd - -! ================================================= - -SUBROUTINE c32sym_sd(DS) - -! ================================================= - - use four_caspt2_module - - Implicit NONE - Integer :: DS(32, 32), SD(32, 32), i, j, hnsym - - REPNA(1) = '1e1/2'; REPNA(2) = '2e1/2'; REPNA(3) = '1e3/2'; REPNA(4) = '2e3/2' - REPNA(5) = '1e5/2'; REPNA(6) = '2e5/2'; REPNA(7) = '1e7/2'; REPNA(8) = '2e7/2' - REPNA(9) = '1e9/2'; REPNA(10) = '2e9/2'; REPNA(11) = '1e11/2'; REPNA(12) = '2e11/2' - REPNA(13) = '1e13/2'; REPNA(14) = '2e13/2'; REPNA(15) = '1e15/2'; REPNA(16) = '2e15/2' - REPNA(17) = '1e1/2'; REPNA(18) = '2e1/2'; REPNA(19) = '1e3/2'; REPNA(20) = '2e3/2' - REPNA(21) = '1e5/2'; REPNA(22) = '2e5/2'; REPNA(23) = '1e7/2'; REPNA(24) = '2e7/2' - REPNA(25) = '1e9/2'; REPNA(26) = '2e9/2'; REPNA(27) = '1e11/2'; REPNA(28) = '2e11/2' - REPNA(29) = '1e13/2'; REPNA(30) = '2e13/2'; REPNA(31) = '1e15/2'; REPNA(32) = '2e15/2' - - REPNA(33) = 'a '; REPNA(34) = 'b '; REPNA(35) = '1e1 '; REPNA(36) = '2e1 ' - REPNA(37) = '1e2 '; REPNA(38) = '2e2 '; REPNA(39) = '1e3 '; REPNA(40) = '2e3 ' - REPNA(41) = '1e4 '; REPNA(42) = '2e4 '; REPNA(43) = '1e5 '; REPNA(44) = '2e5 ' - REPNA(45) = '1e6 '; REPNA(46) = '2e6 '; REPNA(47) = '1e7 '; REPNA(48) = '2e7 ' - REPNA(49) = 'a '; REPNA(50) = 'b '; REPNA(51) = '1e1 '; REPNA(52) = '2e1 ' - REPNA(53) = '1e2 '; REPNA(54) = '2e2 '; REPNA(55) = '1e3 '; REPNA(56) = '2e3 ' - REPNA(57) = '1e4 '; REPNA(58) = '2e4 '; REPNA(59) = '1e5 '; REPNA(60) = '2e5 ' - REPNA(61) = '1e7 '; REPNA(62) = '2e7 '; REPNA(63) = '1e9 '; REPNA(64) = '2e9 ' - - Do i = 1, nsymrpa - Do j = 1, nsymrpa - SD(i, j) = MULTB(i + nsymrpa, j) - End do - End do - - Do i = 1, nsymrpa - Do j = 1, nsymrpa - DS(i, j) = SD(j, i) - End do - End do - -end subroutine c32sym_sd diff --git a/src/pgsym_ty.f90 b/src/pgsym_ty.f90 deleted file mode 100644 index a2dbc088..00000000 --- a/src/pgsym_ty.f90 +++ /dev/null @@ -1,460 +0,0 @@ -! ================================================= - -SUBROUTINE c1sym_sd(DS) ! double-single multiplication - -! ================================================= - use four_caspt2_module - - Implicit NONE - Integer :: DS(1, 1), SD(1, 1), i, j, hnsym - - NSYMRP = 1 - NSYMRPA = 1 - REPNA(1) = 'a'; REPNA(2) = 'a' - - SD(1, 1) = 1 - DS(1, 1) = 1 - - MULTB_S = 1 - MULTB_D = 1 - MULTB_DS = 1 - irpmo = 1 - -end subroutine c1sym_sd - -! ================================================= - -SUBROUTINE c2sym_sd(DS) ! double-single multiplication - -! ================================================= - use four_caspt2_module - - Implicit NONE - Integer :: DS(2, 2), SD(2, 2), i, j, hnsym - - NSYMRP = 2 - REPNA(1) = '1e1/2'; REPNA(2) = '2e1/2' - REPNA(3) = 'a '; REPNA(4) = 'b ' - -!indices 1-2 when singles 1-2 -!indices 1-2 when doubles 3-4 - - SD(1, 1) = 1; SD(1, 2) = 2 - SD(2, 1) = 2; SD(2, 2) = 1 - - DS = SD - -end subroutine c2sym_sd - -! ================================================= - -SUBROUTINE c4sym_sd(DS) ! double-single multiplication - -! ================================================= - - use four_caspt2_module - - Implicit NONE - Integer :: SD(4, 4), DS(4, 4), i, j, hnsym - - NSYMRP = 4 - REPNA(1) = '1e1/2'; REPNA(2) = '2e1/2'; REPNA(4) = '1e3/2 '; REPNA(4) = '2e3/2'; - REPNA(5) = 'a '; REPNA(6) = 'b '; REPNA(6) = '1e '; REPNA(8) = '2e ' - -!indices 1-hnsym when singles 1-hnsym when doubles hnsym+1-nsymrp - - SD(1, 1) = 1; SD(1, 2) = 2; SD(1, 3) = 3; SD(1, 4) = 4 - SD(2, 1) = 3; SD(2, 2) = 4; SD(2, 3) = 1; SD(2, 4) = 2 - SD(3, 1) = 4; SD(3, 2) = 1; SD(3, 3) = 2; SD(3, 4) = 3 - SD(4, 1) = 2; SD(4, 2) = 3; SD(4, 3) = 4; SD(4, 4) = 1 - - Do i = 1, nsymrp - Do j = 1, nsymrp - DS(i, j) = SD(j, i) - End do - End do - -end subroutine c4sym_sd - -! ================================================= - -SUBROUTINE c6sym_sd(DS) ! double-single multiplication - -! ================================================= - - use four_caspt2_module - - Implicit NONE - Integer :: DS(6, 6), SD(6, 6), i, j, hnsym - - NSYMRP = 6 - REPNA(1) = '1e1/2'; REPNA(2) = '2e1/2'; REPNA(3) = '1e3/2'; REPNA(4) = '2e3/2'; REPNA(5) = '1e5/2'; REPNA(6) = '2e5/2' - REPNA(7) = 'a '; REPNA(8) = 'b '; REPNA(9) = '1e1 '; REPNA(10) = '2e1 '; REPNA(11) = '1e2 '; REPNA(12) = '2e2 ' - - SD(1, 1) = 1; SD(1, 2) = 2; SD(1, 3) = 3; SD(1, 4) = 4; SD(1, 5) = 5; SD(1, 6) = 6 - SD(2, 1) = 6; SD(2, 2) = 5; SD(2, 3) = 4; SD(2, 4) = 3; SD(2, 5) = 2; SD(2, 6) = 1 - SD(3, 1) = 2; SD(3, 2) = 3; SD(3, 3) = 6; SD(3, 4) = 1; SD(3, 5) = 4; SD(3, 6) = 5 - SD(4, 1) = 4; SD(4, 2) = 1; SD(4, 3) = 2; SD(4, 4) = 5; SD(4, 5) = 6; SD(4, 6) = 3 - SD(5, 1) = 5; SD(5, 2) = 4; SD(5, 3) = 1; SD(5, 4) = 6; SD(5, 5) = 3; SD(5, 6) = 2 - SD(6, 1) = 3; SD(6, 2) = 6; SD(6, 3) = 5; SD(6, 4) = 2; SD(6, 5) = 1; SD(6, 6) = 4 - - Do i = 1, nsymrp - Do j = 1, nsymrp - DS(i, j) = SD(j, i) - End do - End do - -end subroutine c6sym_sd - -! ================================================= - -SUBROUTINE c8sym_sd(DS) ! double-single multiplication - -! ================================================= - - use four_caspt2_module - - Implicit NONE - Integer :: DS(8, 8), SD(8, 8), i, j, hnsym - - NSYMRP = 8 - REPNA(1) = '1e1/2'; REPNA(2) = '2e1/2' - REPNA(3) = '1e3/2'; REPNA(4) = '2e3/2' - REPNA(5) = '1e5/2'; REPNA(6) = '2e5/2' - REPNA(7) = '1e7/2'; REPNA(8) = '2e7/2' - - REPNA(9) = 'a '; REPNA(10) = 'b ' - REPNA(11) = '1e1 '; REPNA(12) = '2e1 ' - REPNA(13) = '1e2 '; REPNA(14) = '2e2 ' - REPNA(15) = '1e3 '; REPNA(16) = '2e3 ' - - SD(1, 1) = 1; SD(1, 2) = 2; SD(1, 3) = 3; SD(1, 4) = 4 - SD(1, 5) = 5; SD(1, 6) = 6; SD(1, 7) = 7; SD(1, 8) = 8 - SD(2, 1) = 7; SD(2, 2) = 8; SD(2, 3) = 5; SD(2, 4) = 6 - SD(2, 5) = 3; SD(2, 6) = 4; SD(2, 7) = 1; SD(2, 8) = 2 - SD(3, 1) = 2; SD(3, 2) = 3; SD(3, 3) = 6; SD(3, 4) = 1 - SD(3, 5) = 4; SD(3, 6) = 7; SD(3, 7) = 8; SD(3, 8) = 5 - SD(4, 1) = 4; SD(4, 2) = 1; SD(4, 3) = 2; SD(4, 4) = 5 - SD(4, 5) = 8; SD(4, 6) = 3; SD(4, 7) = 6; SD(4, 8) = 7 - SD(5, 1) = 3; SD(5, 2) = 6; SD(5, 3) = 6; SD(5, 4) = 2 - SD(5, 5) = 1; SD(5, 6) = 8; SD(5, 7) = 5; SD(5, 8) = 4 - SD(6, 1) = 5; SD(6, 2) = 4; SD(6, 3) = 1; SD(6, 4) = 8 - SD(6, 5) = 7; SD(6, 6) = 2; SD(6, 7) = 3; SD(6, 8) = 6 - SD(7, 1) = 8; SD(7, 2) = 5; SD(7, 3) = 4; SD(7, 4) = 7 - SD(7, 5) = 6; SD(7, 6) = 1; SD(7, 7) = 2; SD(7, 8) = 3 - SD(8, 1) = 6; SD(8, 2) = 7; SD(8, 3) = 8; SD(8, 4) = 3 - SD(8, 5) = 2; SD(8, 6) = 5; SD(8, 7) = 4; SD(8, 8) = 1 - - Do i = 1, nsymrp - Do j = 1, nsymrp - DS(i, j) = SD(j, i) - End do - End do - -end subroutine c8sym_sd - -! ================================================= - -SUBROUTINE c2hsym_sd(DS) ! double-single multiplication - -! ================================================= - use four_caspt2_module - - Implicit NONE - Integer :: DS(4, 4), SD(4, 4), i, j, hnsym - - NSYMRP = 4 - REPNA(1) = '1e1/2g'; REPNA(2) = '2e1/2g'; REPNA(3) = '1e1/2u'; REPNA(4) = '2e1/2u' - REPNA(5) = 'ag '; REPNA(6) = 'bg '; REPNA(7) = 'au '; REPNA(8) = 'bu ' - -!indices 1-4 when singles 1-4 -!indices 1-4 when doubles 5-8 - - SD(1, 1) = 1; SD(1, 2) = 2 - SD(2, 1) = 2; SD(2, 2) = 1 - - hnsym = Int(nsymrp/2) - Do i = 1, hnsym - Do j = 1, hnsym - SD(i, j + hnsym) = SD(i, j) + hnsym - End do - End do - - Do i = 1, hnsym - Do j = 1, hnsym - SD(i + hnsym, j) = SD(i, j + hnsym) - End do - End do - - Do i = 1, hnsym - Do j = 1, hnsym - SD(i + hnsym, j + hnsym) = SD(i, j) - End do - End do - - Do i = 1, nsymrp - Do j = 1, nsymrp - DS(i, j) = SD(j, i) - End do - End do - -end subroutine c2hsym_sd - -! ================================================= - -SUBROUTINE c4hsym_sd(DS) ! double-single multiplication - -! ================================================= - use four_caspt2_module - - Implicit NONE - Integer :: DS(8, 8), SD(8, 8), i, j, hnsym - - NSYMRP = 8 - REPNA(1) = '1e1/2g'; REPNA(2) = '2e1/2g'; REPNA(3) = '1e3/2g'; REPNA(4) = '2e3/2g' - REPNA(5) = '1e1/2u'; REPNA(6) = '2e1/2u'; REPNA(7) = '1e3/2u'; REPNA(8) = '2e3/2u' - REPNA(9) = 'ag '; REPNA(10) = 'bg '; REPNA(11) = '1eg '; REPNA(12) = '2eg ' - REPNA(13) = 'au '; REPNA(14) = 'bu '; REPNA(15) = '1eu '; REPNA(16) = '2eu ' - -!indices 1-8 when singles 1-8 -!indices 1-8 when doubles 9-16 - - SD(1, 1) = 1; SD(1, 2) = 2; SD(1, 3) = 3; SD(1, 4) = 4 - SD(2, 1) = 3; SD(2, 2) = 4; SD(2, 3) = 1; SD(2, 4) = 2 - SD(3, 1) = 4; SD(3, 2) = 1; SD(3, 3) = 2; SD(3, 4) = 3 - SD(4, 1) = 2; SD(4, 2) = 3; SD(4, 3) = 4; SD(4, 4) = 1 - - hnsym = Int(nsymrp/2) - Do i = 1, hnsym - Do j = 1, hnsym - SD(i, j + hnsym) = SD(i, j) + hnsym - End do - End do - - Do i = 1, hnsym - Do j = 1, hnsym - SD(i + hnsym, j) = SD(i, j + hnsym) - End do - End do - - Do i = 1, hnsym - Do j = 1, hnsym - SD(i + hnsym, j + hnsym) = SD(i, j) - End do - End do - - Do i = 1, nsymrp - Do j = 1, nsymrp - DS(i, j) = SD(j, i) - End do - End do - -end subroutine c4hsym_sd - -! ================================================= - -SUBROUTINE c6hsym_sd(DS) ! double-single multiplication - -! ================================================= - use four_caspt2_module - - Implicit NONE - Integer :: DS(12, 12), SD(12, 12), i, j, hnsym - - NSYMRP = 12 - REPNA(1) = '1e1/2g'; REPNA(2) = '2e1/2g'; REPNA(3) = '1e3/2g'; REPNA(4) = '2e3/2g'; REPNA(5) = '1e5/2g'; REPNA(6) = '2e5/2g' - REPNA(7) = '1e1/2u'; REPNA(8) = '2e1/2u'; REPNA(9) = '1e3/2u'; REPNA(10) = '2e3/2u'; REPNA(11) = '1e5/2u'; REPNA(12) = '2e5/2u' - REPNA(13) = 'ag '; REPNA(14) = 'bg '; REPNA(15) = '1e1g '; REPNA(16) = '2e1g '; REPNA(17) = '1e2g '; REPNA(18) = '2e2g ' - REPNA(19) = 'au '; REPNA(20) = 'bu '; REPNA(21) = '1e1u '; REPNA(22) = '2e1u '; REPNA(23) = '1e2u '; REPNA(24) = '2e2u ' - -!indices 1-hnsym when singles 1-hnsym when doubles hnsym+1-nsymrp - - SD(1, 1) = 1; SD(1, 2) = 2; SD(1, 3) = 3; SD(1, 4) = 4; SD(1, 5) = 5; SD(1, 6) = 6 - SD(2, 1) = 5; SD(2, 2) = 6; SD(2, 3) = 4; SD(2, 4) = 3; SD(2, 5) = 2; SD(2, 6) = 1 - SD(3, 1) = 2; SD(3, 2) = 3; SD(3, 3) = 6; SD(3, 4) = 1; SD(3, 5) = 4; SD(3, 6) = 5 - SD(4, 1) = 4; SD(4, 2) = 1; SD(4, 3) = 2; SD(4, 4) = 5; SD(4, 5) = 6; SD(4, 6) = 3 - SD(5, 1) = 5; SD(5, 2) = 4; SD(5, 3) = 1; SD(5, 4) = 6; SD(5, 5) = 3; SD(5, 6) = 2 - SD(6, 1) = 3; SD(6, 2) = 6; SD(6, 3) = 5; SD(6, 4) = 2; SD(6, 5) = 1; SD(6, 6) = 4 - - hnsym = Int(nsymrp/2) - Do i = 1, hnsym - Do j = 1, hnsym - SD(i, j + hnsym) = SD(i, j) + hnsym - End do - End do - - Do i = 1, hnsym - Do j = 1, hnsym - SD(i + hnsym, j) = SD(i, j + hnsym) - End do - End do - - Do i = 1, hnsym - Do j = 1, hnsym - SD(i + hnsym, j + hnsym) = SD(i, j) - End do - End do - - Do i = 1, nsymrp - Do j = 1, nsymrp - DS(i, j) = SD(j, i) - End do - End do - -end subroutine c6hsym_sd - -! ================================================= - -SUBROUTINE c8hsym_sd(DS) ! double-single multiplication - -! ================================================= - use four_caspt2_module - - Implicit NONE - Integer :: DS(16, 16), SD(16, 16), i, j, hnsym - - write (*, *) 'pass c8hsym' - - NSYMRP = 16 - REPNA(1) = '1e1/2g'; REPNA(2) = '2e1/2g'; REPNA(3) = '1e3/2g'; REPNA(4) = '2e3/2g' - REPNA(5) = '1e5/2g'; REPNA(6) = '2e5/2g'; REPNA(7) = '1e7/2g'; REPNA(8) = '2e7/2g' - REPNA(9) = '1e1/2u'; REPNA(10) = '2e1/2u'; REPNA(11) = '1e3/2u'; REPNA(12) = '2e3/2u' - REPNA(13) = '1e5/2u'; REPNA(14) = '2e5/2u'; REPNA(15) = '1e7/2u'; REPNA(16) = '2e7/2u' - - REPNA(17) = 'ag '; REPNA(18) = 'bg '; REPNA(19) = '1e1g '; REPNA(20) = '2e1g ' - REPNA(21) = '1e2g '; REPNA(22) = '2e2g '; REPNA(23) = '1e3g '; REPNA(24) = '2e3g ' - REPNA(25) = 'au '; REPNA(26) = 'bu '; REPNA(27) = '1e1u '; REPNA(28) = '2e1u ' - REPNA(29) = '1e2u '; REPNA(30) = '2e2u '; REPNA(31) = '1e3u '; REPNA(32) = '2e3u ' - -!indices 1-hnsym when singles 1-hnsym when doubles hnsym+1-nsymrp - - SD(1, 1) = 1; SD(1, 2) = 2; SD(1, 3) = 3; SD(1, 4) = 4; SD(1, 5) = 5; SD(1, 6) = 6; SD(1, 7) = 7; SD(1, 8) = 8 - SD(2, 1) = 7; SD(2, 2) = 8; SD(2, 3) = 5; SD(2, 4) = 6; SD(2, 5) = 3; SD(2, 6) = 4; SD(2, 7) = 1; SD(2, 8) = 2 - SD(3, 1) = 2; SD(3, 2) = 3; SD(3, 3) = 6; SD(3, 4) = 1; SD(3, 5) = 4; SD(3, 6) = 7; SD(3, 7) = 8; SD(3, 8) = 5 - SD(4, 1) = 4; SD(4, 2) = 1; SD(4, 3) = 2; SD(4, 4) = 5; SD(4, 5) = 8; SD(4, 6) = 3; SD(4, 7) = 6; SD(4, 8) = 7 - SD(5, 1) = 3; SD(5, 2) = 6; SD(5, 3) = 7; SD(5, 4) = 2; SD(5, 5) = 1; SD(5, 6) = 8; SD(5, 7) = 5; SD(5, 8) = 4 - SD(6, 1) = 5; SD(6, 2) = 4; SD(6, 3) = 1; SD(6, 4) = 8; SD(6, 5) = 7; SD(6, 6) = 2; SD(6, 7) = 3; SD(6, 8) = 6 - SD(7, 1) = 8; SD(7, 2) = 5; SD(7, 3) = 4; SD(7, 4) = 7; SD(7, 5) = 6; SD(7, 6) = 5; SD(7, 7) = 2; SD(7, 8) = 3 - SD(8, 1) = 6; SD(8, 2) = 7; SD(8, 3) = 8; SD(8, 4) = 3; SD(8, 5) = 2; SD(8, 6) = 1; SD(8, 7) = 4; SD(8, 8) = 1 - - hnsym = nsymrp/2 - Do i = 1, hnsym - Do j = 1, hnsym - SD(i, j + hnsym) = SD(i, j) + hnsym - End do - End do - - Do i = 1, hnsym - Do j = 1, hnsym - SD(i + hnsym, j) = SD(i, j + hnsym) - End do - End do - - Do i = 1, hnsym - Do j = 1, hnsym - SD(i + hnsym, j + hnsym) = SD(i, j) - End do - End do - - write (*, *) 'MULTB_SD c8hsym' - Do i = 1, nsymrp - write (*, '(50I3)') (SD(i, j), j=1, nsymrp) - End do - - Do i = 1, nsymrp - Do j = 1, nsymrp - DS(i, j) = SD(j, i) - End do - End do - - write (*, *) 'MULTB_DS c8hsym' - Do i = 1, nsymrp - write (*, '(50I3)') (DS(i, j), j=1, nsymrp) - End do - -end subroutine c8hsym_sd - -! ================================================= - -SUBROUTINE c32hsym_sd(DS) ! double-single multiplication - -! ================================================= - use four_caspt2_module - - Implicit NONE - Integer :: DS(32, 32), SD(32, 32), i, j, hnsym - - NSYMRP = 32 - REPNA(1) = '1e1/2g'; REPNA(2) = '2e1/2g'; REPNA(3) = '1e3/2g'; REPNA(4) = '2e3/2g' - REPNA(5) = '1e5/2g'; REPNA(6) = '2e5/2g'; REPNA(7) = '1e7/2g'; REPNA(8) = '2e7/2g' - REPNA(9) = '1e9/2g'; REPNA(10) = '2e9/2g'; REPNA(11) = '1e11/2g'; REPNA(12) = '2e11/2g' - REPNA(13) = '1e13/2g'; REPNA(14) = '2e13/2g'; REPNA(15) = '1e15/2g'; REPNA(16) = '2e15/2g' - REPNA(17) = '1e1/2u'; REPNA(18) = '2e1/2u'; REPNA(19) = '1e3/2u'; REPNA(20) = '2e3/2u' - REPNA(21) = '1e5/2u'; REPNA(22) = '2e5/2u'; REPNA(23) = '1e7/2u'; REPNA(24) = '2e7/2u' - REPNA(25) = '1e9/2u'; REPNA(26) = '2e9/2u'; REPNA(27) = '1e11/2u'; REPNA(28) = '2e11/2u' - REPNA(29) = '1e13/2u'; REPNA(30) = '2e13/2u'; REPNA(31) = '1e15/2u'; REPNA(32) = '2e15/2u' - - REPNA(33) = 'ag '; REPNA(34) = 'bg '; REPNA(35) = '1e1g '; REPNA(36) = '2e1g ' - REPNA(37) = '1e2g '; REPNA(38) = '2e2g '; REPNA(39) = '1e3g '; REPNA(40) = '2e3g ' - REPNA(41) = '1e4g '; REPNA(42) = '2e4g '; REPNA(43) = '1e5g '; REPNA(44) = '2e5g ' - REPNA(45) = '1e6g '; REPNA(46) = '2e6g '; REPNA(47) = '1e7g '; REPNA(48) = '2e7g ' - REPNA(49) = 'au '; REPNA(50) = 'bu '; REPNA(51) = '1e1u '; REPNA(52) = '2e1u ' - REPNA(53) = '1e2u '; REPNA(54) = '2e2u '; REPNA(55) = '1e3u '; REPNA(56) = '2e3u ' - REPNA(57) = '1e4u '; REPNA(58) = '2e4u '; REPNA(59) = '1e5u '; REPNA(60) = '2e5u ' - REPNA(61) = '1e7u '; REPNA(62) = '2e7u '; REPNA(63) = '1e9u '; REPNA(64) = '2e9u ' - -!indices 1-hnsym when singles 1-hnsym when doubles hnsym+1-nsymrp - - SD(1, 1) = 1; SD(1, 2) = 2; SD(1, 3) = 3; SD(1, 4) = 4; SD(1, 5) = 5; SD(1, 6) = 6; SD(1, 7) = 7; SD(1, 8) = 8; SD(1, 9) = 9; SD(1, 10) = 10; SD(1, 11) = 11; SD(1, 12) = 12; SD(1, 13) = 13; SD(1, 14) = 14; SD(1, 15) = 15; SD(1, 16) = 16 - SD(2, 1) = 3; SD(2, 2) = 1; SD(2, 3) = 5; SD(2, 4) = 2; SD(2, 5) = 7; SD(2, 6) = 4; SD(2, 7) = 9; SD(2, 8) = 6; SD(2, 9) = 11; SD(2, 10) = 8; SD(2, 11) = 13; SD(2, 12) = 10; SD(2, 13) = 15; SD(2, 14) = 12; SD(2, 15) = 16; SD(2, 16) = 14 - SD(3, 1) = 2; SD(3, 2) = 4; SD(3, 3) = 1; SD(3, 4) = 6; SD(3, 5) = 3; SD(3, 6) = 8; SD(3, 7) = 5; SD(3, 8) = 10; SD(3, 9) = 7; SD(3, 10) = 12; SD(3, 11) = 9; SD(3, 12) = 14; SD(3, 13) = 11; SD(3, 14) = 16; SD(3, 15) = 13; SD(3, 16) = 15 - SD(4, 1) = 5; SD(4, 2) = 3; SD(4, 3) = 7; SD(4, 4) = 1; SD(4, 5) = 9; SD(4, 6) = 2; SD(4, 7) = 11; SD(4, 8) = 4; SD(4, 9) = 13; SD(4, 10) = 6; SD(4, 11) = 15; SD(4, 12) = 8; SD(4, 13) = 16; SD(4, 14) = 10; SD(4, 15) = 14; SD(4, 16) = 12 - SD(5, 1) = 4; SD(5, 2) = 6; SD(5, 3) = 2; SD(5, 4) = 8; SD(5, 5) = 1; SD(5, 6) = 10; SD(5, 7) = 3; SD(5, 8) = 12; SD(5, 9) = 5; SD(5, 10) = 14; SD(5, 11) = 7; SD(5, 12) = 16; SD(5, 13) = 9; SD(5, 14) = 15; SD(5, 15) = 11; SD(5, 16) = 13 - SD(6, 1) = 7; SD(6, 2) = 5; SD(6, 3) = 9; SD(6, 4) = 3; SD(6, 5) = 11; SD(6, 6) = 1; SD(6, 7) = 13; SD(6, 8) = 2; SD(6, 9) = 15; SD(6, 10) = 4; SD(6, 11) = 16; SD(6, 12) = 6; SD(6, 13) = 14; SD(6, 14) = 8; SD(6, 15) = 12; SD(6, 16) = 10 - SD(7, 1) = 6; SD(7, 2) = 8; SD(7, 3) = 4; SD(7, 4) = 10; SD(7, 5) = 2; SD(7, 6) = 12; SD(7, 7) = 1; SD(7, 8) = 14; SD(7, 9) = 3; SD(7, 10) = 16; SD(7, 11) = 5; SD(7, 12) = 15; SD(7, 13) = 7; SD(7, 14) = 13; SD(7, 15) = 9; SD(7, 16) = 11 - SD(8, 1) = 9; SD(8, 2) = 7; SD(8, 3) = 11; SD(8, 4) = 5; SD(8, 5) = 13; SD(8, 6) = 3; SD(8, 7) = 15; SD(8, 8) = 1; SD(8, 9) = 16; SD(8, 10) = 2; SD(8, 11) = 14; SD(8, 12) = 4; SD(8, 13) = 12; SD(8, 14) = 6; SD(8, 15) = 10; SD(8, 16) = 8 - SD(9, 1) = 8; SD(9, 2) = 10; SD(9, 3) = 6; SD(9, 4) = 12; SD(9, 5) = 4; SD(9, 6) = 14; SD(9, 7) = 2; SD(9, 8) = 16; SD(9, 9) = 1; SD(9, 10) = 15; SD(9, 11) = 3; SD(9, 12) = 13; SD(9, 13) = 5; SD(9, 14) = 11; SD(9, 15) = 7; SD(9, 16) = 9 - SD(10, 1) = 11; SD(10, 2) = 9; SD(10, 3) = 13; SD(10, 4) = 7; SD(10, 5) = 15; SD(10, 6) = 5; SD(10, 7) = 16; SD(10, 8) = 3; SD(10, 9) = 14; SD(10, 10) = 1; SD(10, 11) = 12; SD(10, 12) = 2; SD(10, 13) = 10; SD(10, 14) = 4; SD(10, 15) = 8; SD(10, 16) = 6 - SD(11, 1) = 10; SD(11, 2) = 12; SD(11, 3) = 8; SD(11, 4) = 14; SD(11, 5) = 6; SD(11, 6) = 16; SD(11, 7) = 4; SD(11, 8) = 15; SD(11, 9) = 2; SD(11, 10) = 13; SD(11, 11) = 1; SD(11, 12) = 11; SD(11, 13) = 3; SD(11, 14) = 9; SD(11, 15) = 5; SD(11, 16) = 7 - SD(12, 1) = 13; SD(12, 2) = 11; SD(12, 3) = 15; SD(12, 4) = 9; SD(12, 5) = 16; SD(12, 6) = 7; SD(12, 7) = 14; SD(12, 8) = 5; SD(12, 9) = 12; SD(12, 10) = 3; SD(12, 11) = 10; SD(12, 12) = 1; SD(12, 13) = 8; SD(12, 14) = 2; SD(12, 15) = 6; SD(12, 16) = 4 - SD(13, 1) = 12; SD(13, 2) = 14; SD(13, 3) = 10; SD(13, 4) = 16; SD(13, 5) = 8; SD(13, 6) = 15; SD(13, 7) = 6; SD(13, 8) = 13; SD(13, 9) = 4; SD(13, 10) = 11; SD(13, 11) = 2; SD(13, 12) = 9; SD(13, 13) = 1; SD(13, 14) = 7; SD(13, 15) = 3; SD(13, 16) = 5 - SD(14, 1) = 15; SD(14, 2) = 13; SD(14, 3) = 16; SD(14, 4) = 11; SD(14, 5) = 14; SD(14, 6) = 9; SD(14, 7) = 12; SD(14, 8) = 7; SD(14, 9) = 10; SD(14, 10) = 5; SD(14, 11) = 8; SD(14, 12) = 3; SD(14, 13) = 6; SD(14, 14) = 1; SD(14, 15) = 4; SD(14, 16) = 2 - SD(15, 1) = 14; SD(15, 2) = 16; SD(15, 3) = 12; SD(15, 4) = 15; SD(15, 5) = 10; SD(15, 6) = 13; SD(15, 7) = 8; SD(15, 8) = 11; SD(15, 9) = 6; SD(15, 10) = 9; SD(15, 11) = 4; SD(15, 12) = 7; SD(15, 13) = 2; SD(15, 14) = 5; SD(15, 15) = 1; SD(15, 16) = 3 - SD(16, 1) = 16; SD(16, 2) = 15; SD(16, 3) = 14; SD(16, 4) = 13; SD(16, 5) = 12; SD(16, 6) = 11; SD(16, 7) = 10; SD(16, 8) = 9; SD(16, 9) = 8; SD(16, 10) = 7; SD(16, 11) = 6; SD(16, 12) = 5; SD(16, 13) = 4; SD(16, 14) = 3; SD(16, 15) = 2; SD(16, 16) = 1 - - hnsym = nsymrp/2 - Do i = 1, hnsym - Do j = 1, hnsym - SD(i, j + hnsym) = SD(i, j) + hnsym - End do - End do - - Do i = 1, hnsym - Do j = 1, hnsym - SD(i + hnsym, j) = SD(i, j + hnsym) - End do - End do - - Do i = 1, hnsym - Do j = 1, hnsym - SD(i + hnsym, j + hnsym) = SD(i, j) - End do - End do - - write (*, *) 'MULTB_SD c32hsym' - Do i = 1, nsymrp - write (*, '(50I3)') (SD(i, j), j=1, nsymrp) - End do - - Do i = 1, nsymrp - Do j = 1, nsymrp - DS(i, j) = SD(j, i) - End do - End do - - write (*, *) 'MULTB_DS c32hsym' - Do i = 1, nsymrp - write (*, '(50I3)') (DS(i, j), j=1, nsymrp) - End do - -end subroutine c32hsym_sd diff --git a/src/r4dcasci.f90 b/src/r4dcasci.f90 deleted file mode 100644 index d3df0773..00000000 --- a/src/r4dcasci.f90 +++ /dev/null @@ -1,290 +0,0 @@ -! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= -! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= - -PROGRAM r4dcasci ! DO CASCI CALC IN THIS PROGRAM! - -! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= -! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= - - use four_caspt2_module - - Implicit NONE - integer :: ii, jj, kk, ll, typetype, i0, j0 - integer :: j, i, k, l, nuniq - integer :: k0, l0, nint, n, dimn, n0, n1, nspace(3, 3) - integer :: totsym, inisym, endsym - -! integer :: val(8), initdate, date0, date1 -! real*8 :: totalsec, inittime, tsec0, tsec1, tsec - - logical :: test, cutoff - - real*8 :: i2r, i2i, dr, di, nsign, e0, e2, e2all - complex*16 :: cmplxint, dens, trace1, trace2, dens1, dens2 - - character*50 :: filename - -! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= -! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= - -! debug = .TRUE. - debug = .FALSE. - thres = 1.0d-15 -! thres = 0.0d+00 - -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! - integer :: ierr, nprocs, rank -#ifdef HAVE_MPI - call MPI_INIT(ierr) - call MPI_COMM_SIZE(MPI_COMM_WORLD, nprocs, ierr) - call MPI_COMM_rank(MPI_COMM_WORLD, rank, ierr) -#else - rank = 0; nprocs = 1; -#endif - write (*, *) '' - write (*, *) ' ENTER R4DCASCI PROGRAM written by M. Abe' - write (*, *) '' - - tmem = 0.0d+00 - - write (*, '("Current Memory is ",F10.2,"MB")') tmem/1024/1024 - - val = 0 - Call DATE_AND_TIME(VALUES=val) - Write (*, *) 'Year = ', val(1), 'Mon = ', val(2), 'Date = ', val(3) - Write (*, *) 'Hour = ', val(5), 'Min = ', val(6), 'Sec = ', val(7), '.', val(8) - - totalsec = val(8)*(1.0d-03) + val(7) + val(6)*(6.0d+01) + val(5)*(6.0d+01)**2 - initdate = val(3) - inittime = totalsec - - write (*, *) inittime - - Call timing(val(3), totalsec, date0, tsec) - - open (5, file='active.inp', form='formatted', status='old') - read (5, '(I4)') ninact - read (5, '(I4)') nact - read (5, '(I4)') nsec - read (5, '(I4)') nelec - read (5, '(I4)') nroot - read (5, '(I4)') selectroot - read (5, '(I4)') totsym - read (5, '(I4)') ncore - read (5, '(I4)') nbas - close (5) - - write (*, *) 'ninact =', ninact - write (*, *) 'nact =', nact - write (*, *) 'nsec =', nsec - write (*, *) 'nelec =', nelec - write (*, *) 'nroot =', nroot - write (*, *) 'selectroot =', selectroot - write (*, *) 'totsym =', totsym - write (*, *) 'ncore =', ncore - write (*, *) 'nbas =', nbas - -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - filename = 'MRCONEE' - - call readorb_enesym(filename) -! call readorb_enec1 (filename) - - call read1mo(filename) - - write (*, *) 'realc', realc, ECORE, ninact, nact, nsec, nmo - -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -!Iwamuro create new ikr for dirac - Call create_newmdcint - - filename = 'MDCINTNEW' - - Call readint2_casci_co(filename, nuniq) - -! Allocate(sp(1:nmo)) ; Call memplus(KIND(sp),SIZE(sp),1) -! sp( 1 : ninact ) = 1 -! sp( ninact+1 : ninact+nact ) = 2 -! sp( ninact+nact+1 : ninact+nact+nsec ) = 3 -! sp( ninact+nact+nsec: nmo ) = 4 -! write(*,*)'nmo =' ,nmo - - nmo = ninact + nact + nsec - -! write(*,*)'Iwamuro debug1' - -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -! write(*,*)'Iwamuro debug2' - - If (mod(nelec, 2) == 0) then - inisym = nsymrpa + 1 - endsym = 2*nsymrpa - Else - inisym = 1 - endsym = nsymrpa - End if - - write (*, '("Current Memory is ",F10.2,"MB")') tmem/1024/1024 - -! Do totsym = inisym, inisym -! Do totsym = inisym, endsym - -! totsym = 4 - - write (*, *) ' ' - write (*, *) '*******************************' - write (*, *) ' ' - write (*, *) 'IREP IS ', repna(totsym) - write (*, *) ' ' - write (*, *) '*******************************' - write (*, *) ' ' - - realcvec = .TRUE. - - Call casci(totsym) - -! goto 1000 - -! This is test for bug fix about realc part - - write (*, *) realc, 'realc' - write (*, *) realcvec, 'realcvec' - - test = .true. - - write (*, *) realc, 'realc' - write (*, *) realcvec, 'realcvec' - - realc = .FALSE. !!! realc =.TRUE. - realcvec = .FALSE. !!! realcvec =.TRUE. - - write (*, *) 'FOR TEST WE DO (F,F)' - write (*, *) realc, 'realc' - write (*, *) realcvec, 'realcvec' - -!!=============================================! -! ! - iroot = selectroot -! ! -!!=============================================! - - Call e0test_v2 - - write (*, '("Current Memory is ",F10.2,"MB")') tmem/1024/1024 - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~! -! BUILDING FOCK MATRIX ! -! fij = hij + SIGUMA[<0|Ekl|0>{(ij|kl)-(il|kj)} ! -! kl ! -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~! - -!! TEST TO CALCULATE FOCK MATRIX OF HF STATE fpq = hpq + SIGUMA_r[(pq|rr)-(pr|qr)] -!! THIS MUST BE DIAGONAL MATRIX AND DIAGONAL ELEMENTS CORESPONDS TO SPINOR ENERGIES. - - Allocate (f(nmo, nmo)); Call memplus(KIND(f), SIZE(f), 2) - - f(:, :) = 0.0d+00 - -! debug = .FALSE. - debug = .TRUE. - If (debug) then - Call fockhf1 - End if - -!Iwamuro modify -! write(*,'(20I10)') (j0,j0=1,nmo) -! Do i0 = 1, nmo -! write(*,'(20F10.3)') (real(f(i0,j0)),j0=1,nmo) -! End do - -!! NOW MAKE FOCK MATRIX FOR CASCI STATE -!! fij = hij + SIGUMA_kl[<0|Ekl|0>{(ij|kl)-(il|kj)} - - f(:, :) = 0.0d+00 - -!Iwamuro modify -! write(*,'(20I10)') (j0,j0=1,nmo) -! Do i0 = 1, nmo -! write(*,'(20F10.3)') (real(f(i0,j0)),j0=1,nmo) -! End do - - Call fockcasci - -! debug = .TRUE. - debug = .FALSE. - write (*, *) debug, 'debug' - -!Iwamuro modify -! write(*,'(20I10)') (j0,j0=1,nmo) -! Do i0 = 1, nmo -! write(*,'(20F10.3)') (real(f(i0,j0)),j0=1,nmo) -! End do - - if (debug) Call prtoutfock - - Allocate (eps(nmo)); Call memplus(KIND(eps), SIZE(eps), 1) - eps = 0.0d+00 - -!Iwamuro modify -! write(*,'(20I10)') (j0,j0=1,nmo) -! Do i0 = 1, nmo -! write(*,'(20F10.3)') (real(f(i0,j0)),j0=1,nmo) -! End do - - Call fockdiag - - Do i0 = 1, nmo - write (*, *) 'eps(', i0, ')=', eps(i0) - End do - -! write(*,'(20I10)') (j0,j0=1,nmo) -! Do i0 = 1, nmo -! write(*,'(20F10.3)') (f(i0,j0),j0=1,nmo) -! enddo - -! Do i0 = 1, nmo/2 -! if(ABS(eps(i0*2)-eps(i0*2-1)) > 1.0d-10) then -! write(*,*)i0*2-1,i0*2,eps(i0*2-1),eps(i0*2) -! Endif -! Enddo - - open (5, file='EPS', form='unformatted', status='unknown') - write (5) nmo - write (5) eps(1:nmo) - close (5) - - deallocate (sp); Call memplus(KIND(sp), SIZE(sp), 1) - deallocate (cir); Call memminus(KIND(cir), SIZE(cir), 1) - deallocate (cii); Call memminus(KIND(cii), SIZE(cii), 1) - deallocate (eigen); Call memminus(KIND(eigen), SIZE(eigen), 1) - deallocate (f); Call memminus(KIND(f), SIZE(f), 2) - deallocate (eps); Call memminus(KIND(eps), SIZE(eps), 1) - deallocate (idet); Call memminus(KIND(idet), SIZE(idet), 1) - - deallocate (orb); Call memminus(KIND(orb), SIZE(orb), 1) - deallocate (irpmo); Call memminus(KIND(irpmo), SIZE(irpmo), 1) - deallocate (irpamo); Call memminus(KIND(irpamo), SIZE(irpamo), 1) - deallocate (indmo); Call memminus(KIND(indmo), SIZE(indmo), 1) - deallocate (indmor); Call memminus(KIND(indmor), SIZE(indmor), 1) - deallocate (onei); Call memminus(KIND(onei), SIZE(onei), 1) - deallocate (int2i); Call memminus(KIND(int2i), SIZE(int2i), 1) - deallocate (indtwi); Call memminus(KIND(indtwi), SIZE(indtwi), 1) - deallocate (oner); Call memminus(KIND(oner), SIZE(oner), 1) - deallocate (int2r); Call memminus(KIND(int2r), SIZE(int2r), 1) - deallocate (indtwr); Call memminus(KIND(indtwr), SIZE(indtwr), 1) - deallocate (int2r_f1); Call memminus(KIND(int2r_f1), SIZE(int2r_f1), 1) - deallocate (int2i_f1); Call memminus(KIND(int2i_f1), SIZE(int2i_f1), 1) - deallocate (int2r_f2); Call memminus(KIND(int2r_f2), SIZE(int2r_f2), 1) - deallocate (int2i_f2); Call memminus(KIND(int2i_f2), SIZE(int2i_f2), 1) - - write (*, '("Current Memory is ",F10.2,"MB")') tmem/1024/1024 - - Call timing(val(3), totalsec, date0, tsec0) - write (*, *) 'End r4dcasci part' - -1000 continue -END program r4dcasci diff --git a/src/r4dcasci_co.f90 b/src/r4dcasci_co.f90 index 06177a02..5bd80c27 100644 --- a/src/r4dcasci_co.f90 +++ b/src/r4dcasci_co.f90 @@ -7,13 +7,14 @@ PROGRAM r4dcasci_co ! DO CASCI CALC IN THIS PROGRAM! ! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= use four_caspt2_module + use module_file_manager use read_input_module Implicit NONE #ifdef HAVE_MPI include 'mpif.h' #endif - integer :: i0, nuniq, inisym, endsym + integer :: i0, nuniq, inisym, endsym, eps_unit = default_unit, input_unit = default_unit logical :: test character*50 :: filename @@ -58,7 +59,10 @@ PROGRAM r4dcasci_co ! DO CASCI CALC IN THIS PROGRAM! print *, inittime end if - call read_input + + call open_formatted_file(unit=input_unit, file='active.inp', status="old", optional_action='read') + call read_input(input_unit) + close(input_unit) if (rank == 0) then print *, 'ninact =', ninact @@ -203,10 +207,10 @@ PROGRAM r4dcasci_co ! DO CASCI CALC IN THIS PROGRAM! end if if (rank == 0) then ! Only master ranks are allowed to create files used by CASPT2 except for MDCINTNEW. - open (5, file='EPS', form='unformatted', status='unknown') - write (5) nmo - write (5) eps(1:nmo) - close (5) + call open_unformatted_file(unit=eps_unit, file="EPS", status="replace", optional_action="write") + write (eps_unit) nmo + write (eps_unit) eps(1:nmo) + close (eps_unit) end if ! end if diff --git a/src/r4dcaspt2_tra.f90 b/src/r4dcaspt2_tra.f90 deleted file mode 100644 index 5b2d77c2..00000000 --- a/src/r4dcaspt2_tra.f90 +++ /dev/null @@ -1,383 +0,0 @@ -! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= -! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= - - PROGRAM r4dcaspt2_tra ! DO CASPT2 CALC WITH MO TRANSFORMATION - -! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= -! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= - - use four_caspt2_module - - Implicit NONE - integer :: ii, jj, kk, ll, typetype, i0 - integer :: j, i, k, l, nuniq - integer :: k0, l0, nint, n, dimn, n0, n1, nspace(3,3) - integer :: totsym, inisym, endsym, ieshift - - logical :: test, cutoff - - real*8 :: i2r, i2i, dr, di, nsign, e0, e2, e2all, weight0 - complex*16 :: cmplxint, dens, trace1, trace2 - complex*16,allocatable :: ci(:) - real*8,allocatable :: ecas(:) - - character*50 :: filename - -! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= -! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= - - -! debug = .TRUE. - debug = .FALSE. - thres = 1.0d-15 -! thres = 0.0d+00 - - -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! - - - write(*,*)'' - write(*,*)' ENTER R4DCASPT2 PROGRAM written by M. Abe' - write(*,*)'' - tmem = 0.0d+00 - - - val = 0 - Call DATE_AND_TIME (VALUES=val) - Write(*,*)'Year = ',val(1),'Mon = ',val(2),'Date = ',val(3) - Write(*,*)'Hour = ',val(5),'Min = ',val(6),'Sec = ',val(7),'.',val(8) - - totalsec = val(8)*(1.0d-03)+val(7)+val(6)*(6.0d+01)+val(5)*(6.0d+01)**2 - initdate = val(3) - inittime = totalsec - - write(*,*)inittime - - Call timing(val(3), totalsec, date0, tsec) - - eshift = 0.0d+00 - ieshift = 0 - - open(5,file='active.inp',form='formatted',status='old') - read(5,'(I4)')ninact - read(5,'(I4)')nact - read(5,'(I4)')nsec - read(5,'(I4)')nelec - read(5,'(I4)')nroot - read(5,'(I4)')selectroot - read(5,'(I4)')totsym - read(5,'(I4)')ncore - read(5,'(I4)')nbas -! read(5,'(I4)')ieshift - read(5,'(E8.2)')eshift - close(5) - -! eshift = 0.01 -! eshift = 1.0d-02*ieshift - - write(*,*)'ninact =' ,ninact - write(*,*)'nact =' ,nact - write(*,*)'nsec =' ,nsec - write(*,*)'nelec =' ,nelec - write(*,*)'nroot =' ,nroot - write(*,*)'selectroot =' ,selectroot - write(*,*)'totsym =' ,totsym - write(*,*)'ncore =' ,ncore - write(*,*)'nbas =' ,nbas - write(*,*)'eshift =',eshift - -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - write(*,*)' ENTER READ MRCONEE' - - filename = 'MRCONEE' - - call readorb_enesym (filename) -! call readorb_enec1 (filename) - - call read1mo (filename) - - write(*,*)'realc', realc, ECORE, ninact, nact, nsec,nmo - - write(*,*)' EXIT READ MRCONEE' - - -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - write(*,*)' ENTER READ MDCINT' - - filename = 'MDCINTNEW' - - Call readint2_ord (filename) - - write(*,'("Current Memory is ",F10.2,"MB")')tmem/1024/1024 - - -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - nmo = ninact + nact + nsec - write(*,*)'nmo =' ,nmo - - open(10,file='CIMAT',form='unformatted',status='old') - - read(10) ndet - Allocate(idet(1:ndet)) ; Call memplus(KIND(idet),SIZE(idet),1) - Allocate(ecas(1:ndet)) ; Call memplus(KIND(ecas),SIZE(ecas),1) - - read(10) idet(1:ndet) - read(10) ecas(1:ndet) - - close(10) - - Allocate(eigen(1:nroot)) ; Call memplus(KIND(eigen),SIZE(eigen),1) - eigen = 0.0d+00 - eigen(1:nroot) = ecas(1:nroot) + ecore - - Deallocate (ecas) - -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - write(*,*)' ENTER READ NEWCICOEFF' - - Allocate(ci(1:ndet)) - ci = 0.0d+00 - - open(10,file='NEWCICOEFF',form='unformatted',status='old') - - read(10) ci(1:ndet) - - close(10) - - Allocate(cir(1:ndet,selectroot:selectroot)) - Allocate(cii(1:ndet,selectroot:selectroot)) - - cir(1:ndet,selectroot) = DBLE(ci(1:ndet)) - cii(1:ndet,selectroot) = DIMAG(ci(1:ndet)) - -! Do i0 = 1, ndet -! write(*,'(2E20.10)')cir(i0,selectroot),cii(i0,selectroot) -! End do - -! Do i0 = 1, ndet -! write(*,'(2E20.10)')ci(i0) -! End do - - deallocate(ci) - -! write(*,*)cir(1:ndet,selectroot) -! write(*,*)cii(1:ndet,selectroot) - - write(*,*)' EXIT READ NEWCICOEFF' - -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - - open(10,file='EPS',form='unformatted',status='old') - - read(10) nmo - Allocate(eps(1:nmo)) ; Call memplus(KIND(eps),SIZE(eps),1) - eps = 0.0d+00 - read(10) eps(1:nmo) - - close(10) -! Do i = 1, nmo -! write(*,*)'eps(',i,')= ',eps(i) -! Enddo - - -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - - open(10,file='TRANSFOCK',form='unformatted',status='old') - - read(10) nmo - Allocate(f(nmo,nmo)) ; Call memplus(KIND(f),SIZE(f),2) - read(10) f - - close(10) - -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - write(*,*)' ' - write(*,*)'*******************************' - write(*,*)' ' - write(*,*)'IREP IS ',repna(totsym) - write(*,*)' ' - write(*,*)'*******************************' - write(*,*)' ' - - realcvec = .TRUE. - - -! This is test for bug fix about realc part - - write(*,*)realc,'realc' - write(*,*)realcvec,'realcvec' - - realc =.FALSE. !!! realc =.TRUE. - realcvec =.FALSE. !!! realcvec =.TRUE. - - write(*,*)'FOR TEST WE DO (F,F)' - write(*,*)realc,'realc' - write(*,*)realcvec,'realcvec' - -!!=============================================! -! ! - iroot = selectroot ! -! ! -!!=============================================! - -! write(*,*)'RECALCULATION OF CASCI ENERGY' -! -! Call e0test_v2 - - e2 = 0.0d+00 - - Call calce0(e0) - - e2all = 0.0d+00 - - date1 = initdate - tsec1 = totalsec - - - Call timing(date1, tsec1, date0, tsec0) - date1 = date0 - tsec1 = tsec0 - - Call intra_3(2,1,2,2,'A1int') - Call intra_3(2,1,1,1,'A2int') - sumc2local = 0.0d+00 - Call solvA_ord ( e0, e2) - e2all = e2all + e2 - write(*,*) e2all - - date1 = date0 - tsec1 = tsec0 - Call timing(date1, tsec1, date0, tsec0) - - - Call intra_2(2,1,2,1,'Bint ') - - sumc2local = 0.0d+00 - Call solvB_ord ( e0, e2) - e2all = e2all + e2 - write(*,*) e2all - - date1 = date0 - tsec1 = tsec0 - Call timing(date1, tsec1, date0, tsec0) - - - - - Call intra_3(3,2,2,2,'C1int') - Call intra_3(3,2,1,1,'C2int') - Call intra_1(3,1,1,2,'C3int') - sumc2local = 0.0d+00 - Call solvC_ord ( e0, e2) - e2all = e2all + e2 - write(*,*) e2all - - date1 = date0 - tsec1 = tsec0 - Call timing(date1, tsec1, date0, tsec0) - - - - Call intra_3(3,1,2,2,'D1int') - Call intra_1(3,2,2,1,'D2int') - Call intra_3(3,1,1,1,'D3int') - sumc2local = 0.0d+00 - Call solvD_ord ( e0, e2) - e2all = e2all + e2 - write(*,*) e2all - - date1 = date0 - tsec1 = tsec0 - Call timing(date1, tsec1, date0, tsec0) - - - - Call intra_1(3,1,2,1,'Eint') - - sumc2local = 0.0d+00 - Call solvE_ord ( e0, e2) - e2all = e2all + e2 - write(*,*) e2all - - date1 = date0 - tsec1 = tsec0 - Call timing(date1, tsec1, date0, tsec0) - - - Call intra_2(3,2,3,2,'Fint ') - - sumc2local = 0.0d+00 - Call solvF_ord ( e0, e2) - e2all = e2all + e2 - write(*,*) e2all - - date1 = date0 - tsec1 = tsec0 - Call timing(date1, tsec1, date0, tsec0) - - Call intra_1(3,1,3,2,'Gint ') - - - - sumc2local = 0.0d+00 - Call solvG_ord ( e0, e2) - e2all = e2all + e2 - write(*,*) e2all - - date1 = date0 - tsec1 = tsec0 - Call timing(date1, tsec1, date0, tsec0) - - - Call intra_2(3,1,3,1,'Hint ') - - sumc2local = 0.0d+00 - Call solvH_ord ( e0, e2) - e2all = e2all + e2 - write(*,*) e2all - - date1 = date0 - tsec1 = tsec0 - Call timing(date1, tsec1, date0, tsec0) - - write(*,'("c^2 ",F30.15)') sumc2 - weight0 = 1.0d+00/ (1.0d+00 + sumc2) - write(*,'("weight of 0th wave function is",F30.15)') weight0 - - write(*,'("Total second order energy is ",F30.15," a.u.")') e2all - eshift*sumc2 - write(*,'(" ")') - write(*,'("Total energy is ",F30.15," a.u.")') e2all+eigen(iroot) - eshift*sumc2 - - - deallocate (cir) ; Call memminus(KIND(cir) ,SIZE(cir) ,1) - deallocate (cii) ; Call memminus(KIND(cii) ,SIZE(cii) ,1) - deallocate (eigen) ; Call memminus(KIND(eigen),SIZE(eigen),1) - deallocate (eps) ; Call memminus(KIND(eps) ,SIZE(eps) ,1) - deallocate (idet) ; Call memminus(KIND(idet) ,SIZE(idet) ,1) - -! End do ! totsym - deallocate (sp ) ; Call memminus(KIND(sp ),SIZE(sp ),1) - deallocate (orb ) ; Call memminus(KIND(orb ),SIZE(orb ),1) - deallocate (irpmo ) ; Call memminus(KIND(irpmo ),SIZE(irpmo ),1) - deallocate (irpamo ) ; Call memminus(KIND(irpamo ),SIZE(irpamo ),1) - deallocate (indmo ) ; Call memminus(KIND(indmo ),SIZE(indmo ),1) - deallocate (indmor ) ; Call memminus(KIND(indmor ),SIZE(indmor ),1) - deallocate (oner ) ; Call memminus(KIND(oner ),SIZE(oner ),1) - deallocate (onei ) ; Call memminus(KIND(onei ),SIZE(onei ),1) - - Call timing(val(3), totalsec, date0, tsec0) - write(*,*)'End r4dcaspt2_tra' - - 1000 continue - END program r4dcaspt2_tra - - - diff --git a/src/r4dcaspt2_tra_co.f90 b/src/r4dcaspt2_tra_co.f90 index e8f411e1..1939debe 100644 --- a/src/r4dcaspt2_tra_co.f90 +++ b/src/r4dcaspt2_tra_co.f90 @@ -7,13 +7,14 @@ PROGRAM r4dcaspt2_tra_co ! DO CASPT2 CALC WITH MO TRANSFORMATION ! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= use four_caspt2_module + use module_file_manager use read_input_module, only: read_input Implicit NONE #ifdef HAVE_MPI include 'mpif.h' real(16) :: time0, time1 #endif - integer :: ieshift + integer :: ieshift, input_unit = default_unit, new_unit = default_unit real*8 :: e0, e2, e2all, weight0 complex*16, allocatable :: ci(:) real*8, allocatable :: ecas(:) @@ -65,7 +66,10 @@ PROGRAM r4dcaspt2_tra_co ! DO CASPT2 CALC WITH MO TRANSFORMATION eshift = 0.0d+00 ieshift = 0 - call read_input + call open_formatted_file(unit=input_unit, file='active.inp', status="old", optional_action='read') + call read_input(input_unit) + close(input_unit) + if (rank == 0) then print *, 'ninact =', ninact print *, 'nact =', nact @@ -115,19 +119,19 @@ PROGRAM r4dcaspt2_tra_co ! DO CASPT2 CALC WITH MO TRANSFORMATION nmo = ninact + nact + nsec if (rank == 0) print *, 'nmo =', nmo - open (10, file='CIMAT', form='unformatted', status='old') + call open_unformatted_file(unit=new_unit, file="CIMAT", status='old', optional_action="read") - read (10) ndet + read (new_unit) ndet Allocate (idet(1:ndet)); Call memplus(KIND(idet), SIZE(idet), 1) Allocate (ecas(1:ndet)); Call memplus(KIND(ecas), SIZE(ecas), 1) - read (10) idet(1:ndet) - read (10) ecas(1:ndet) + read (new_unit) idet(1:ndet) + read (new_unit) ecas(1:ndet) - read (10) idetr_array_len + read (new_unit) idetr_array_len allocate (idetr(1:idetr_array_len)); call memplus(kind(idet), size(idet), 1) - read (10) idetr(1:idetr_array_len) - close (10) + read (new_unit) idetr(1:idetr_array_len) + close (new_unit) Allocate (eigen(1:nroot)); Call memplus(KIND(eigen), SIZE(eigen), 1) eigen = 0.0d+00 @@ -142,11 +146,11 @@ PROGRAM r4dcaspt2_tra_co ! DO CASPT2 CALC WITH MO TRANSFORMATION Allocate (ci(1:ndet)) ci = 0.0d+00 - open (10, file='NEWCICOEFF', form='unformatted', status='old') + call open_unformatted_file(unit=new_unit, file="NEWCICOEFF", status='old', optional_action="read") - read (10) ci(1:ndet) + read (new_unit) ci(1:ndet) - close (10) + close (new_unit) Allocate (cir(1:ndet, selectroot:selectroot)) Allocate (cii(1:ndet, selectroot:selectroot)) @@ -160,24 +164,24 @@ PROGRAM r4dcaspt2_tra_co ! DO CASPT2 CALC WITH MO TRANSFORMATION !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - open (10, file='EPS', form='unformatted', status='old') + call open_unformatted_file(unit=new_unit, file="EPS", status='old', optional_action="read") - read (10) nmo + read (new_unit) nmo Allocate (eps(1:nmo)); Call memplus(KIND(eps), SIZE(eps), 1) eps = 0.0d+00 - read (10) eps(1:nmo) + read (new_unit) eps(1:nmo) - close (10) + close (new_unit) !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - open (10, file='TRANSFOCK', form='unformatted', status='old') + call open_unformatted_file(unit=new_unit, file="TRANSFOCK", status='old', optional_action="read") - read (10) nmo + read (new_unit) nmo Allocate (f(nmo, nmo)); Call memplus(KIND(f), SIZE(f), 2) - read (10) f + read (new_unit) f - close (10) + close (new_unit) !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! diff --git a/src/r4divo.f90 b/src/r4divo.f90 deleted file mode 100644 index b887d16d..00000000 --- a/src/r4divo.f90 +++ /dev/null @@ -1,207 +0,0 @@ -! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= -! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= - - PROGRAM r4divo ! DO IVO CALC ONLY FOR SMALL BASIS SETS - -! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= -! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= - - use four_caspt2_module - - Implicit NONE - integer :: ii, jj, kk, ll, typetype, i0, j0, nhomo - integer :: j, i, k, l, nuniq - integer :: k0, l0, nint, n, dimn, n0, n1, nspace(3,3) - integer :: totsym, inisym, endsym - -! integer :: val(8), initdate, date0, date1 -! real*8 :: totalsec, inittime, tsec0, tsec1, tsec - - logical :: test, cutoff - - real*8 :: i2r, i2i, dr, di, nsign, e0, e2, e2all - complex*16 :: cmplxint, dens, trace1, trace2, dens1, dens2 - - character*50 :: filename - -! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= -! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= - - -! debug = .TRUE. - debug = .FALSE. - thres = 1.0d-15 -! thres = 0.0d+00 - - -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! - - write(*,*)'' - write(*,*)' ENTER R4DIVO PROGRAM written by M. Abe test17 version 2012/10/15' - write(*,*)'' - - tmem = 0.0d+00 - - write(*,'("Current Memory is ",F10.2,"MB")')tmem/1024/1024 - - val = 0 - Call DATE_AND_TIME (VALUES=val) - Write(*,*)'Year = ',val(1),'Mon = ',val(2),'Date = ',val(3) - Write(*,*)'Hour = ',val(5),'Min = ',val(6),'Sec = ',val(7),'.',val(8) - - totalsec = val(8)*(1.0d-03)+val(7)+val(6)*(6.0d+01)+val(5)*(6.0d+01)**2 - initdate = val(3) - inittime = totalsec - - write(*,*)inittime - - Call timing(val(3), totalsec, date0, tsec) - - - open(5,file='active.inp',form='formatted',status='old') - - read(5,'(I4)')ninact - read(5,'(I4)')nact - read(5,'(I4)')nsec - read(5,'(I4)')nelec - read(5,'(I4)')nroot - read(5,'(I4)')selectroot - read(5,'(I4)')totsym - read(5,'(I4)')ncore - read(5,'(I4)')nbas - read(5,'(E8.2)')eshift - read(5,'(A6)')ptgrp - read(5,'(I4)')nhomo - close(5) - - write(*,*)'ninact =' ,ninact - write(*,*)'nact =' ,nact - write(*,*)'nsec =' ,nsec - write(*,*)'nelec =' ,nelec - write(*,*)'nroot =' ,nroot - write(*,*)'selectroot =' ,selectroot - write(*,*)'totsym =' ,totsym - write(*,*)'ncore =' ,ncore - write(*,*)'nbas =' ,nbas - write(*,*)'eshift =' ,eshift ! NO USE IN IVO BUT FOR CASCI AND CASPT2 IT IS USED - write(*,*)'ptgrp =' ,ptgrp - write(*,*)'nhomo =' ,nhomo - write(*,*)'close active.inp' - - -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - filename = 'MRCONEE' - - call readorb_enesym (filename) - call read1mo (filename) - - write(*,*)'realc', realc, ECORE, ninact, nact, nsec,nmo - - -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - filename = 'MDCINTNEW' - -! nmo = ninact + nact + nsec - - Call readint2_ivo (filename, nuniq) - -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - write(*,'("Current Memory is ",F10.2,"MB")')tmem/1024/1024 - - write(*,*)' ' - write(*,*)'*******************************' - write(*,*)' ' - write(*,*)'IREP IS ',repna(totsym) - write(*,*)' ' - write(*,*)'*******************************' - write(*,*)' ' - - realcvec = .TRUE. - - -! goto 1000 - - - -! This is test for bug fix about realc part - - write(*,*)realc,'realc' - write(*,*)realcvec,'realcvec' - - test = .true. - - write(*,*)realc,'realc' - write(*,*)realcvec,'realcvec' - - realc =.FALSE. !!! realc =.TRUE. - realcvec =.FALSE. !!! realcvec =.TRUE. - - write(*,*)'FOR TEST WE DO (F,F)' - write(*,*)realc,'realc' - write(*,*)realcvec,'realcvec' - -!!=============================================! -! ! - iroot = selectroot -! ! -!!=============================================! - -! Call e0test_v2 - -! write(*,'("Current Memory is ",F10.2,"MB")')tmem/1024/1024 - - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~! -! BUILDING FOCK MATRIX ! -! fij = hij + SIGUMA[<0|Ekl|0>{(ij|kl)-(il|kj)} ! -! kl ! -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~! - -!! TEST TO CALCULATE FOCK MATRIX OF HF STATE fpq = hpq + SIGUMA_r[(pq|rr)-(pr|qr)] -!! THIS MUST BE DIAGONAL MATRIX AND DIAGONAL ELEMENTS CORESPONDS TO SPINOR ENERGIES. - - Allocate(f(nsec,nsec)); Call memplus (KIND(f),SIZE(f),2) - - f(:,:) = 0.0d+00 - -!! NOW MAKE FOCK MATRIX FOR IVO (only virtual spinors - -!! fij = hij + SIGUMA_a(ij|aa)-(ia|aj)} - - f(:,:) = 0.0d+00 - - Call fockivo(nhomo) - - deallocate ( f ) ; Call memminus (KIND( f ),SIZE( f ),2) - - deallocate ( orb ); Call memminus (KIND( orb ),SIZE( orb ),1) - deallocate ( irpmo ); Call memminus (KIND( irpmo ),SIZE( irpmo ),1) - deallocate ( irpamo ); Call memminus (KIND( irpamo ),SIZE( irpamo ),1) - deallocate ( indmo ); Call memminus (KIND( indmo ),SIZE( indmo ),1) - deallocate (indmor ); Call memminus (KIND(indmor ),SIZE(indmor ),1) - deallocate (onei ); Call memminus (KIND(onei ),SIZE(onei ),1) -! deallocate (int2i ); Call memminus (KIND(int2i ),SIZE(int2i ),1) -! deallocate (indtwi ); Call memminus (KIND(indtwi ),SIZE(indtwi ),1) - deallocate ( oner ); Call memminus (KIND( oner ),SIZE( oner ),1) -! deallocate (int2r ); Call memminus (KIND(int2r ),SIZE(int2r ),1) -! deallocate (indtwr ); Call memminus (KIND(indtwr ),SIZE(indtwr ),1) - deallocate (int2r_f1); Call memminus (KIND(int2r_f1),SIZE(int2r_f1),1) - deallocate (int2i_f1); Call memminus (KIND(int2i_f1),SIZE(int2i_f1),1) - deallocate (int2r_f2); Call memminus (KIND(int2r_f2),SIZE(int2r_f2),1) - deallocate (int2i_f2); Call memminus (KIND(int2i_f2),SIZE(int2i_f2),1) - - write(*,'("Current Memory is ",F10.2,"MB")')tmem/1024/1024 - - - Call timing(val(3), totalsec, date0, tsec0) - write(*,*)'End r4divo part' - - 1000 continue - END program r4divo - - - diff --git a/src/rcutoff.f90 b/src/rcutoff.f90 deleted file mode 100644 index e42acf42..00000000 --- a/src/rcutoff.f90 +++ /dev/null @@ -1,42 +0,0 @@ -! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= -! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= - -SUBROUTINE rcutoff(sr, w, dimn, dimm, thres, ur, wnew) - ! diagonalization of real symmetric matrix - ! and remove linear dependency for any S matrix - -! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= -! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= - - use four_caspt2_module - - Implicit NONE - - integer, intent(in) :: dimn, dimm - real*8, intent(in) :: thres, sr(dimn, dimn), w(dimn) - real*8, intent(out) :: ur(dimn, dimm), wnew(dimm) - integer :: j0, j, i, i0, i1 - integer :: k0, l0, ii, jj, kk, ll - - write (*, *) 'New dimension becomes ', dimm - - j0 = 0 - do i0 = 1, dimn - if (w(i0) >= thres) then - j0 = j0 + 1 - ur(:, j0) = sr(:, i0) - wnew(j0) = w(i0) - end if - end do - -!test - - write (*, *) 'Eigenvalue and eigen vector becomes' - do i0 = 1, dimm - write (*, *) i0, 'th state' - write (*, *) wnew(i0) -! write(*,*) ur(:,i0) - end do - -1000 continue -end subroutine rcutoff diff --git a/src/read1mo.f90 b/src/read1mo.f90 deleted file mode 100644 index e353514d..00000000 --- a/src/read1mo.f90 +++ /dev/null @@ -1,75 +0,0 @@ -! ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ - - SUBROUTINE read1mo(filename) ! one-electron MO integrals in MRCONEE - -! ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ - - use four_caspt2_module - - Implicit NONE - - integer :: mrconee - character*50, intent(in) :: filename -! integer :: j0, j, i, i0, i1 -! integer :: k0, l0, ii, jj, kk, ll, nmom - integer :: j0, j, i, i0, i1 - integer :: k0, l0, ii, jj, kk, ll, nmom -! real*8, allocatable :: roner(:,:), ronei(:,:) - double precision, allocatable :: roner(:, :), ronei(:, :) - -! Write(UT_sys_ftmp) NMO,BREIT,ECORE -! Write(UT_sys_ftmp) NSYMRP,(REPN(IRP),IRP=1,NSYMRP) -! Write(UT_sys_ftmp) NSYMRPA,(REPNA(IRP),IRP=1,NSYMRPA*2) -! Write(UT_sys_ftmp) ((MULTB(I,J),I=1,2*NSYMRPA),J=1,2*NSYMRPA) -! Write(UT_sys_ftmp) (IRPMO(IMO),IRPAMO(IMO),ORBMO(IMO),IMO=1,NMO) -! Write(UT_sys_ftmp) ((ONER(IMO,JMO),ONEI(IMO,JMO),JMO=1,NMO),IMO=1,NMO) - - write (*, *) 'Enter read1mo' - - mrconee = 10 - - realc = .true. - - Allocate (roner(nmo, nmo)); Call memplus(KIND(roner), SIZE(roner), 1) - Allocate (ronei(nmo, nmo)); Call memplus(KIND(ronei), SIZE(ronei), 1) - - open (mrconee, file=trim(filename), status='old', form='unformatted', err=10) - rewind (mrconee) - read (mrconee, err=10) - read (mrconee, err=10) - read (mrconee, err=10) - read (mrconee, err=10) - read (mrconee, err=10) - read (mrconee, err=10) ((roner(i0, j0), ronei(i0, j0), j0=1, nmo), i0=1, nmo) - -! Iwamuro modify - do i0 = 1, nmo - do j0 = 1, nmo -! Wrpite(*,'(2I4,2X,2F8.4)') i0, j0, RONER(i0,j0),RONEI(i0,j0) - end do - end do - close (mrconee) - - nmom = ninact + nact + nsec - Allocate (oner(nmom, nmom)); Call memplus(KIND(oner), SIZE(oner), 1) - Allocate (onei(nmom, nmom)); Call memplus(KIND(onei), SIZE(onei), 1) - - do i0 = 1, nmom - do j0 = 1, nmom - oner(i0, j0) = roner(indmo(i0), indmo(j0)) - onei(i0, j0) = ronei(indmo(i0), indmo(j0)) - end do - end do - - deallocate (roner); Call memminus(KIND(roner), SIZE(roner), 1) - deallocate (ronei); Call memminus(KIND(ronei), SIZE(ronei), 1) - - write (*, *) realc, 'realc' - goto 1000 - -10 write (*, *) 'err 10 mo1' - go to 1000 -11 write (*, *) 'err 11 mo1' - go to 1000 - -1000 end subroutine read1mo diff --git a/src/read1mo_co.f90 b/src/read1mo_co.f90 index 792e71a1..d8bde1df 100644 --- a/src/read1mo_co.f90 +++ b/src/read1mo_co.f90 @@ -5,11 +5,13 @@ SUBROUTINE read1mo_co(filename) ! one-electron MO integrals in moint1 ! ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ use four_caspt2_module + use module_file_manager Implicit NONE integer :: mrconee, isp, nmom, iostat character*50, intent(in) :: filename + logical :: is_end_of_file integer :: j0, i0 double precision, allocatable :: roner(:, :, :), ronei(:, :, :) @@ -23,14 +25,7 @@ SUBROUTINE read1mo_co(filename) ! one-electron MO integrals in moint1 Allocate (roner(nmo, nmo, scfru)); Call memplus(KIND(roner), SIZE(roner), 1) Allocate (ronei(nmo, nmo, scfru)); Call memplus(KIND(ronei), SIZE(ronei), 1) - open (mrconee, file=trim(filename), status='old', form='unformatted', iostat=iostat) - - ! File status check - if (iostat /= 0) then - print *, 'ERROR: Error opening ', trim(filename), ', rank = ', rank - print *, "Stop the program" - stop - end if + call open_unformatted_file(unit=mrconee, file=trim(filename), status="old", optional_action="read") rewind (mrconee) read (mrconee, iostat=iostat) @@ -40,16 +35,7 @@ SUBROUTINE read1mo_co(filename) ! one-electron MO integrals in moint1 read (mrconee, iostat=iostat) read (mrconee, iostat=iostat) (((roner(i0, j0, isp), ronei(i0, j0, isp), j0=1, nmo), i0=1, nmo), isp=1, scfru) - ! File status check - if (iostat < 0) then - print *, 'WARNING: End of file detected in ', trim(filename), ', rank = ', rank - print *, "Continue the program, but we don't set oner,onei" - return - else if (iostat > 0) then - print *, 'ERROR: Error reading ', trim(filename), ', rank = ', rank - print *, "Stop the program" - stop - end if + call check_iostat(iostat=iostat, file=trim(filename), end_of_file_reached=is_end_of_file) ! Reverse the sign of ronei if DIRAC version is larger or equal to 21. if (dirac_version >= 21) then diff --git a/src/read_input_module.f90 b/src/read_input_module.f90 index f10082ca..28d07cd5 100644 --- a/src/read_input_module.f90 +++ b/src/read_input_module.f90 @@ -11,29 +11,30 @@ module read_input_module private public read_input, is_substring, ras_read, lowercase, uppercase logical is_end + integer, parameter :: intmax = 10**9, max_str_length = 100 interface is_in_range_number module procedure is_in_range_int, is_in_range_real end interface is_in_range_number contains - subroutine read_input + subroutine read_input(unit_num) !=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=! ! This subroutine is the entry point to read active.inp !=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=! use four_caspt2_module, only: is_ras1_configured, is_ras2_configured, is_ras3_configured implicit none + integer, intent(in) :: unit_num integer :: idx, iostat - character(100) :: string - character(11), allocatable :: essential_variable_names(:) + character(max_str_length) :: string + character(10), allocatable :: essential_variable_names(:) logical :: is_comment, is_config_sufficient, is_variable_filled(11) = & (/.false., .false., .false., .false., .false., .false., .false., .false., .false., .false., .false./) is_end = .false. - essential_variable_names = & - (/"ninact ", "nact ", "nsec ", "nroot ", "nelec ", & - & "selectroot", "totsym ", "ncore ", "nbas ", "ptgrp ", "diracver "/) + allocate (essential_variable_names(11)) + essential_variable_names = (/"ninact ", "nact ", "nsec ", "nroot ", "nelec ", & + "selectroot", "totsym ", "ncore ", "nbas ", "ptgrp ", "diracver "/) is_ras1_configured = .false.; is_ras2_configured = .false.; is_ras3_configured = .false. - open (5, file="active.inp", form="formatted") do while (.not. is_end) - read (5, "(a)", iostat=iostat) string + read (unit_num, "(a)", iostat=iostat) string if (iostat < 0) then if (rank == 0) print *, "ERROR: YOU NEED TO ADD 'end' in active.inp" stop @@ -43,7 +44,7 @@ subroutine read_input end if call is_comment_line(string, is_comment) if (is_comment) cycle ! Read the next line - call check_input_type(string, is_variable_filled) + call check_input_type(unit_num, string, is_variable_filled) end do is_config_sufficient = .true. do idx = 1, size(is_variable_filled, 1) @@ -57,63 +58,63 @@ subroutine read_input stop end if if (is_ras1_configured .or. is_ras2_configured .or. is_ras3_configured) call check_ras_is_valid - close (5) return ! END SUBROUTINE end subroutine read_input - subroutine check_input_type(string, is_filled) + subroutine check_input_type(unit_num, string, is_filled) !=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=! ! This subroutine recognize the type of input that follows from the next line ! and calls the subroutine that we must call !=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=! use four_caspt2_module implicit none + integer, intent(in) :: unit_num character(*), intent(inout) :: string - character(100) :: input + character(max_str_length) :: input logical :: is_comment logical, intent(inout) :: is_filled(:) call lowercase(string) select case (trim(string)) case ("ninact") - call read_an_integer(0, 10**9, ninact) + call read_an_integer(unit_num, 0, intmax, ninact) is_filled(1) = .true. case ("nact") - call read_an_integer(0, 10**9, nact) + call read_an_integer(unit_num, 0, intmax, nact) is_filled(2) = .true. case ("nsec") - call read_an_integer(0, 10**9, nsec) + call read_an_integer(unit_num, 0, intmax, nsec) is_filled(3) = .true. case ("nelec") - call read_an_integer(0, 10**9, nelec) + call read_an_integer(unit_num, 0, intmax, nelec) is_filled(4) = .true. case ("nroot") - call read_an_integer(0, 10**9, nroot) + call read_an_integer(unit_num, 0, intmax, nroot) is_filled(5) = .true. case ("selectroot") - call read_an_integer(0, 10**9, selectroot) + call read_an_integer(unit_num, 0, intmax, selectroot) is_filled(6) = .true. case ("totsym") - call read_an_integer(0, 10**9, totsym) + call read_an_integer(unit_num, 0, intmax, totsym) is_filled(7) = .true. case ("ncore") - call read_an_integer(0, 10**9, ncore) + call read_an_integer(unit_num, 0, intmax, ncore) is_filled(8) = .true. case ("nbas") - call read_an_integer(0, 10**9, nbas) + call read_an_integer(unit_num, 0, intmax, nbas) is_filled(9) = .true. case ("eshift") eshiftloop: do - read (5, '(A)') input + read (unit_num, '(A)') input call is_comment_line(input, is_comment) if (.not. is_comment) then read (input, *) eshift @@ -122,32 +123,32 @@ subroutine check_input_type(string, is_filled) end do eshiftloop case ("ptgrp") - call read_a_string(ptgrp) + call read_a_string(unit_num, ptgrp) is_filled(10) = .true. case ("diracver") - call read_an_integer(0, 10**9, dirac_version) + call read_an_integer(unit_num, 0, intmax, dirac_version) is_filled(11) = .true. case ("ras1") - call ras_read(ras1_list, 1) + call ras_read(unit_num, ras1_list, 1) ras1_size = size(ras1_list, 1) - call read_an_integer(0, ras1_size, ras1_max_hole) + call read_an_integer(unit_num, 0, ras1_size, ras1_max_hole) is_ras1_configured = .true. case ("ras2") - call ras_read(ras2_list, 2) + call ras_read(unit_num, ras2_list, 2) is_ras2_configured = .true. ras2_size = size(ras2_list, 1) case ("ras3") - call ras_read(ras3_list, 3) + call ras_read(unit_num, ras3_list, 3) ras3_size = size(ras3_list, 1) - call read_an_integer(0, ras3_size, ras3_max_elec) + call read_an_integer(unit_num, 0, ras3_size, ras3_max_elec) is_ras3_configured = .true. case ("calctype") - call read_a_string(calctype) + call read_a_string(unit_num, calctype) call uppercase(calctype) if (calctype /= "CASCI" .and. calctype /= "DMRG ") then if (rank == 0) print *, "ERROR: calctype must be CASCI or DMRG" @@ -155,7 +156,7 @@ subroutine check_input_type(string, is_filled) end if case ("minholeras1") - call read_an_integer(0, 10**9, min_hole_ras1) + call read_an_integer(unit_num, 0, intmax, min_hole_ras1) case ("end") is_end = .true. @@ -166,7 +167,7 @@ subroutine check_input_type(string, is_filled) end select end subroutine check_input_type - subroutine ras_read(ras_list, ras_num) + subroutine ras_read(unit_num, ras_list, ras_num) !=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=! ! This subroutine returns RAS[1,2,3] list from the user input ! (e.g.) INPUT : string = "1,2,4..10,13,17..20" @@ -176,18 +177,18 @@ subroutine ras_read(ras_list, ras_num) use module_sort_swap, only: heapSort implicit none integer, allocatable, intent(inout) :: ras_list(:) - integer, intent(in) :: ras_num - character(100) :: tmp_ras_chr + integer, intent(in) :: unit_num, ras_num + character(max_str_length) :: tmp_ras_chr character(:), allocatable :: ras_chr - integer, parameter :: max_str_length = 100 character(max_str_length) :: string integer :: tmp_ras(max_ras_spinor_num), idx_filled, iostat, idx ! Get the ras_num and store this to ras_chr write (tmp_ras_chr, *) ras_num - ras_chr = trim(adjustl(tmp_ras_chr)) + allocate (ras_chr, source=trim(adjustl(tmp_ras_chr))) + ! ras_chr = trim(adjustl(tmp_ras_chr)) - read (5, '(a)', iostat=iostat) string ! Read a line of active.inp + read (unit_num, '(a)', iostat=iostat) string ! Read a line of active.inp if (iostat /= 0) then if (rank == 0) print *, "ERROR: ras_read: iostat = ", iostat, ", string =", string stop ! ERROR, STOP THE PROGRAM @@ -199,19 +200,17 @@ subroutine ras_read(ras_list, ras_num) ! (e.g.) INPUT : string = "1,3,5..8,10", tmp_ras = [0,0,...,0], idx_filled = 0 ! OUTPUT : string = " , , , ", tmp_ras = [5,6,7,8,1,3,10,0,0,...,0], idx_filled = 7 !=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=! - call parse_input_string_to_int_list(string, tmp_ras, idx_filled, 0, 10**9) + call parse_input_string_to_int_list(string=string, list=tmp_ras, filled_num=idx_filled, & + allow_int_min=0, allow_int_max=intmax) ! Does the input string contain at least one varible? if (idx_filled <= 0) then - if (rank == 0) then - print *, "string:", string - print *, "ERROR: Error in input, can't read ras"//ras_chr//" value!!. Stop the program." - end if - stop ! ERROR, STOP THE PROGRAM + print *, "ERROR: string:", string, " rank:", rank + call write_error_and_stop_ras_read end if allocate (ras_list(idx_filled)) ras_list(:) = tmp_ras(1:idx_filled) - call heapSort(ras_list, .false.) ! Sort the ras_list in ascending order (lower to higher) + call heapSort(list=ras_list, is_reverse=.false.) ! Sort the ras_list in ascending order (lower to higher) !=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=! ! Check the specification of input is kramers pair? @@ -220,7 +219,7 @@ subroutine ras_read(ras_list, ras_num) ! The size of ras_list must be even. if (mod(size(ras_list), 2) /= 0) then if (rank == 0) print *, "ERROR: The number of ras_list is not even." - goto 10 ! Input Error. Stop program + call write_error_and_stop_ras_read end if ! ras_list(idx) (idx : odd) must be odd number and equal to ras_list(idx+1) (idx : even) @@ -231,19 +230,23 @@ subroutine ras_read(ras_list, ras_num) print *, "ERROR: ras_list(idx) (idx : odd) must be odd number." print *, "idx,ras_list(idx) :", idx, ras_list(idx) end if - goto 10 ! Input Error. Stop program + call write_error_and_stop_ras_read end if ! Check the ras_list(idx+1) (idx : even) is equal to ras_list(idx) + 1 (idx : odd)? if (ras_list(idx) + 1 /= ras_list(idx + 1)) then if (rank == 0) print *, "ERROR: The ras_list is not kramers pair." - goto 10 ! Input Error. Stop program + call write_error_and_stop_ras_read end if end do - goto 100 ! Read the numbers properly -10 if (rank == 0) print *, "ERROR: Error in input, can't read ras"//ras_chr//" value!!. Stop the program." - stop -100 return ! END SUBROUTINE NORMALLY + return ! END SUBROUTINE NORMALLY + + contains + subroutine write_error_and_stop_ras_read + implicit none + print *, "ERROR: Error in input, can't read ras"//ras_chr//" value!!. Stop the program. rank:", rank + stop + end subroutine write_error_and_stop_ras_read end subroutine ras_read subroutine parse_input_string_to_int_list(string, list, filled_num, allow_int_min, allow_int_max) @@ -309,7 +312,7 @@ subroutine parse_input_int(string, list, filled_num, allow_int_min, allow_int_ma if (.not. is_valid) then ! Right number is NOT a integer or invalid input. if (rank == 0) print *, invalid_input_message, string(idx:) - goto 10 ! Input Error. Stop program + call write_error_and_stop_parse_input_int end if !=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=! @@ -321,7 +324,7 @@ subroutine parse_input_int(string, list, filled_num, allow_int_min, allow_int_ma print *, "Error in the section in reading the number, iostat = ", iostat, & ", string = ", string(idx:) end if - goto 10 ! Input Error. Stop program + call write_error_and_stop_parse_input_int end if ! Check whether the read_int is in range [allow_int_min, allow_int_max] call is_in_range_number(read_int, allow_int_min, allow_int_max, is_valid) @@ -331,7 +334,7 @@ subroutine parse_input_int(string, list, filled_num, allow_int_min, allow_int_ma write (max_str, *) allow_int_max if (rank == 0) print *, "ERROR: read_int is out of range,", & "[", trim(adjustl(min_str)), ",", trim(adjustl(max_str)), "]" - goto 10 ! Input Error. Stop program + call write_error_and_stop_parse_input_int end if !=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=! @@ -347,7 +350,7 @@ subroutine parse_input_int(string, list, filled_num, allow_int_min, allow_int_ma if (size(list, 1) < filled_num) then ! Can't fill numbers because the size of the list if (rank == 0) print *, "Can't fill range numbers because of the size of the list. size:", size(list, 1) - goto 10 ! Input Error. Stop program + call write_error_and_stop_parse_input_int end if !=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=! @@ -367,9 +370,12 @@ subroutine parse_input_int(string, list, filled_num, allow_int_min, allow_int_ma end do - return ! NORMAL END -10 if (rank == 0) print *, "ERROR: Can't parse the input in parse_input_int, input:", string, " Stop the program." - stop + contains + subroutine write_error_and_stop_parse_input_int + implicit none + print *, "ERROR: Can't parse the input in parse_input_int, input:", string, " Stop the program. rank:", rank + stop + end subroutine write_error_and_stop_parse_input_int end subroutine parse_input_int subroutine parse_range_input_int(string, list, filled_num, allow_int_min, allow_int_max) @@ -395,7 +401,7 @@ subroutine parse_range_input_int(string, list, filled_num, allow_int_min, allow_ if (allow_int_max < allow_int_min) then if (rank == 0) print *, "ERROR: Allowed range of integer is invalid in parse_range_input_int.", & "MIN:", allow_int_min, "MAX:", allow_int_max - goto 10 ! Input Error. Stop program + call write_error_and_stop_parse_range_input_int end if !=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=! @@ -418,14 +424,14 @@ subroutine parse_range_input_int(string, list, filled_num, allow_int_min, allow_ ! Find the first index of the right num !=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=! rightnum_idx = verify(string(first_dot_index:), " ,.") ! Find the first index of the right num in string(first_dot_index:) - if (rightnum_idx == 0) goto 10 ! Right num is missing. Stop program + if (rightnum_idx == 0) call write_error_and_stop_parse_range_input_int rightnum_idx = rightnum_idx + first_dot_index - 1 ! Set the first index of the right num in string ! Check whether the first character of the right num is valid call is_substring(string(rightnum_idx:rightnum_idx), pattern, is_valid) if (.not. is_valid) then ! Right number is NOT a integer or invalid input. if (rank == 0) print *, invalid_input_message, string(rightnum_idx:) - goto 10 ! Input Error. Stop program + call write_error_and_stop_parse_range_input_int end if !=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=! @@ -436,7 +442,7 @@ subroutine parse_range_input_int(string, list, filled_num, allow_int_min, allow_ if (rank == 0) then print *, "Can't get rightnum. string:", string, "rightnum", rightnum end if - goto 10 ! Stop program (error) + call write_error_and_stop_parse_range_input_int end if ! Check whether the rightnum is in range [allow_int_min, allow_int_max] call is_in_range_number(rightnum, allow_int_min, allow_int_max, is_valid) @@ -446,7 +452,7 @@ subroutine parse_range_input_int(string, list, filled_num, allow_int_min, allow_ write (max_str, *) allow_int_max if (rank == 0) print *, "ERROR: rightnum is out of range,", & "[", trim(adjustl(min_str)), ",", trim(adjustl(max_str)), "]" - goto 10 ! Input Error. Stop program + call write_error_and_stop_parse_range_input_int end if write (right_str, *) rightnum rightnum_digit = len(trim(adjustl(right_str))) ! Get the digit of rightnum (e.g. -10 -> 3, 23 -> 2) @@ -460,7 +466,7 @@ subroutine parse_range_input_int(string, list, filled_num, allow_int_min, allow_ stat = verify(string(leftnum_idx:first_dot_index), " ,;") ! stat must be 1 or 2 if (stat > 2 .or. stat <= 0) then if (rank == 0) print *, "Can't get left num. substring:", string(leftnum_idx:first_dot_index) - goto 10 ! Input Error. Stop program + call write_error_and_stop_parse_range_input_int end if ! If stat is 2, we found the index of left num, so exit loop (e.g. string(leftnum_idx:first_dot_index) = ",10.") if (stat == 2) then @@ -473,7 +479,7 @@ subroutine parse_range_input_int(string, list, filled_num, allow_int_min, allow_ if (.not. is_valid) then ! Right number is NOT a integer or invalid input. if (rank == 0) print *, invalid_input_message, string(leftnum_idx:) - goto 10 ! Input Error. Stop program + call write_error_and_stop_parse_range_input_int end if !=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=! @@ -484,7 +490,7 @@ subroutine parse_range_input_int(string, list, filled_num, allow_int_min, allow_ if (rank == 0) then print *, "Can't get leftnum. string:", string, "leftnum", leftnum end if - goto 10 ! Stop program (error) + call write_error_and_stop_parse_range_input_int end if ! Check whether the rightnum is in range [allow_int_min, allow_int_max] call is_in_range_number(rightnum, allow_int_min, allow_int_max, is_valid) @@ -494,7 +500,7 @@ subroutine parse_range_input_int(string, list, filled_num, allow_int_min, allow_ write (max_str, *) allow_int_max if (rank == 0) print *, "ERROR: rightnum is out of range,", & "[", trim(adjustl(min_str)), ",", trim(adjustl(max_str)), "]" - goto 10 ! Input Error. Stop program + call write_error_and_stop_parse_range_input_int end if !=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=! @@ -508,13 +514,13 @@ subroutine parse_range_input_int(string, list, filled_num, allow_int_min, allow_ if (rightnum < leftnum) then ! rightnum must be larger than or equal to leftnum if (rank == 0) print *, "The specification of the range is invalid. left", leftnum, "right", rightnum - goto 10 ! Input Error. Stop program + call write_error_and_stop_parse_range_input_int end if ! Can fill numbers? if (size(list, 1) - filled_num < rightnum - leftnum + 1) then ! Can't fill numbers because the size of the list if (rank == 0) print *, "Can't fill range numbers because of the size of the list. size:", size(list, 1) - goto 10 ! Input Error. Stop program + call write_error_and_stop_parse_range_input_int end if !=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=! @@ -531,10 +537,12 @@ subroutine parse_range_input_int(string, list, filled_num, allow_int_min, allow_ first_dot_index = index(string, '..') end do - goto 100 ! End this subroutine -10 if (rank == 0) print *, "ERROR: Can't parse the input in parse_range_input_int, input:", string, " Stop the program." - stop ! Stop program (error) -100 continue ! Read the numbers properly + contains + subroutine write_error_and_stop_parse_range_input_int + implicit none + print *, "ERROR: Can't parse the input in parse_range_input_int, input:", string, " Stop the program. rank:", rank + stop + end subroutine write_error_and_stop_parse_range_input_int end subroutine parse_range_input_int subroutine is_substring(substring, string, is_substring_bool) @@ -625,49 +633,52 @@ subroutine create_valid_pattern(int_min, int_max, valid_pattern_string, invalid_ end if end subroutine create_valid_pattern - subroutine read_an_integer(allowed_min_int, allowed_max_int, result_int) + subroutine read_an_integer(unit_num, allowed_min_int, allowed_max_int, result_int) implicit none - integer, intent(in) :: allowed_min_int, allowed_max_int + integer, intent(in) :: unit_num, allowed_min_int, allowed_max_int integer, intent(inout) :: result_int character(:), allocatable :: pattern, invalid_input_message logical :: is_comment, is_subst - character(100) :: input + character(max_str_length) :: input call create_valid_pattern(allowed_min_int, allowed_max_int, pattern, invalid_input_message) do - read (5, '(a)') input + read (unit_num, '(a)') input call is_comment_line(input, is_comment) if (is_comment) cycle ! Go to the next line ! Is the input an integer and more than or equal to zero? call is_substring(input(1:1), pattern, is_subst) if (.not. is_subst) then - if (rank == 0) print *, invalid_input_message, input - if (rank == 0) print *, 'invalidinput' - goto 10 + if (rank == 0) then + print *, invalid_input_message, input + print *, 'invalidinput' + end if + call write_error_and_stop_read_an_integer end if read (input, *) result_int ! read an integer - exit ! EXIT LOOP + exit end do - return ! END SUBROUTINE -10 if (rank == 0) then - print *, "ERROR: Error in input, can't read a integer value!!. Stop the program." + contains + subroutine write_error_and_stop_read_an_integer + implicit none + print *, "ERROR: Error in input, can't read a integer value!!. Stop the program. rank:", rank print *, "input: ", input - end if - stop + stop + end subroutine write_error_and_stop_read_an_integer end subroutine read_an_integer - subroutine read_a_string(result_string) + subroutine read_a_string(unit_num, result_string) implicit none + integer, intent(in) :: unit_num character(*), intent(inout) :: result_string logical :: is_comment character(100) :: input do - read (5, '(a)') input + read (unit_num, '(a)') input call is_comment_line(input, is_comment) if (is_comment) cycle ! Go to the next line read (input, *) result_string ! read a string exit ! EXIT LOOP end do - return ! END SUBROUTINE end subroutine read_a_string subroutine is_comment_line(string, is_comment) @@ -750,7 +761,7 @@ subroutine check_ras_is_valid if (electron_filled(ras1_list(idx))) then ! ERROR: The same number of the electron have been selected if (rank == 0) print *, "ERROR: The number of selected more than once is", ras1_list(idx) - goto 10 ! Error in input. Stop the Program + call write_error_and_stop_check_ras_is_valid ! Error in input. Stop the Program end if electron_filled(ras1_list(idx)) = .true. ! Fill ras1_list(idx) end do @@ -760,7 +771,7 @@ subroutine check_ras_is_valid if (electron_filled(ras2_list(idx))) then ! ERROR: The same number of the electron have been selected if (rank == 0) print *, "ERROR: The number of selected more than once is", ras2_list(idx) - goto 10 ! Error in input. Stop the Program + call write_error_and_stop_check_ras_is_valid ! Error in input. Stop the Program end if electron_filled(ras2_list(idx)) = .true. ! Fill ras2_list(idx) end do @@ -770,7 +781,7 @@ subroutine check_ras_is_valid if (electron_filled(ras3_list(idx))) then ! ERROR: The same number of the electron have been selected if (rank == 0) print *, "ERROR: The number of selected more than once is", ras3_list(idx) - goto 10 ! Error in input. Stop the Program + call write_error_and_stop_check_ras_is_valid ! Error in input. Stop the Program end if electron_filled(ras3_list(idx)) = .true. ! Fill ras3_list(idx) end do @@ -787,9 +798,9 @@ subroutine check_ras_is_valid end if stop end if - - return ! END NORMALLY -10 if (rank == 0) then + contains + subroutine write_error_and_stop_check_ras_is_valid + implicit none print *, "ERROR: Your input is invalid because the same number of the electron have been selected " & //"in the RAS more than once!" print *, "YOUR INPUT" @@ -797,8 +808,8 @@ subroutine check_ras_is_valid print *, "RAS2 : ", ras2_list print *, "RAS3 : ", ras3_list print *, "Stop the program." - end if - stop + stop + end subroutine write_error_and_stop_check_ras_is_valid end subroutine check_ras_is_valid subroutine lowercase(string) diff --git a/src/readint2.f90 b/src/readint2.f90 deleted file mode 100644 index 9343cf2b..00000000 --- a/src/readint2.f90 +++ /dev/null @@ -1,235 +0,0 @@ -! ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ - - SUBROUTINE readint2 (filename, nuniq) ! 2 electorn integrals in MDCINT - -! ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ - - use four_caspt2_module - - Implicit NONE - - character*50,intent(in) :: filename - - character :: datex*10, timex*8 - - integer :: mdcint, nkr, idum, nuniq, nmom - integer :: nz, type - integer :: j0, i0, i1 - integer :: k0, l0, ii, jj, kk, ll, signind - integer :: i, j, k, l, ikr, jkr, lkr, kkr - integer :: SignIJ, SignKL, itr, jtr, ltr, ktr, inz, totalint - - integer, allocatable :: indk(:), indl(:), kr(:) - - real*8, allocatable :: rklr(:), rkli(:), int2rs(:), int2is(:) - - logical :: breit - - - Allocate(int2rs(0:nmo**4)); Call memplus(KIND(int2rs),SIZE(int2rs),1) - Allocate(int2is(0:nmo**4)); Call memplus(KIND(int2is),SIZE(int2is),1) - - Allocate(kr(-nmo/2:nmo/2)); Call memplus(KIND(kr),SIZE(kr),1) - Allocate(indtwr(nmo,nmo,nmo,nmo)); Call memplus(KIND(indtwr),SIZE(indtwr),1) - Allocate(indtwi(nmo,nmo,nmo,nmo)); Call memplus(KIND(indtwi),SIZE(indtwi),1) - - - kr = 0 - - Allocate(indk((nmo/2)**2)); Call memplus(KIND(indk),SIZE(indk),1) - Allocate(indl((nmo/2)**2)); Call memplus(KIND(indl),SIZE(indl),1) - Allocate(rklr((nmo/2)**2)); Call memplus(KIND(rklr),SIZE(rklr),1) - Allocate(rkli((nmo/2)**2)); Call memplus(KIND(rkli),SIZE(rkli),1) - - - write(*,'("Current Memory is ",F10.2,"MB")')tmem/1024/1024 - - nuniq = 0 - indk(:) = 0 - indl(:) = 0 - rklr(:) = 0.0d+00 - rkli(:) = 0.0d+00 - int2r(:) = 0.0d+00 - int2i(:) = 0.0d+00 - indtwr = 0 - indtwi = 0 - - -!########################################################### -! THIS PART IS TAKEN FROM GOSCIP MOLFDIR PROGRAM PACKAGE -!########################################################### - - totalint = 0 - mdcint=11 - open( mdcint, file=trim(filename),form ='unformatted', status='unknown', err=10) - -!old Read (mdcint,err=20,end=30) datex,timex,nkr, & -!old (idum,i0=1,4*nkr),(kr(i0),kr(-1*i0),i0=1,nkr) - Read (mdcint,err=20,end=30) datex,timex,nkr, & - (kr(i0),kr(-1*i0),i0=1,nkr) - - write(*,*) datex,timex - write(*,*) 'nkr',nkr,'kr(+),kr(-)', (kr(i0),kr(-1*i0),i0=1,nkr) - - 60 read (mdcint,ERR=40,END=50) ikr,jkr,nz, & - (indk(inz),indl(inz),inz=1,nz), & - (rklr(inz),rkli(inz),inz=1,nz) - - if (ikr==0) goto 50 - - totalint = totalint + nz - - i = kr(ikr) - itr = kr(-ikr) - j = kr(jkr) - jtr = kr(-jkr) - - nmom = ninact + nact + nsec - -! If(i > ninact+nact .and. itr > ninact+nact .and. & -! & j > ninact+nact .and. jtr > ninact+nact) goto 60 - - - SignIJ = SIGN(1,ikr) * SIGN(1,jkr) - - Do inz = 1, nz - - kkr = indk(inz) - k = kr(kkr) - ktr = kr(-kkr) - lkr = indl(inz) - l = kr(lkr) - ltr = kr(-lkr) - - If(i > ninact+nact .and. j > ninact+nact .and. & - & k > ninact+nact .and. l > ninact+nact) goto 70 - -! If(i > ninact+nact .and. j > ninact+nact .and. & -! & k > ninact+nact .and. l > ninact+nact) goto 70 - - SignKL = SIGN(1,kkr) * SIGN(1,lkr) - nuniq = nuniq + 1 - - -!=-> Original integral plus time-reversed partners - INDTWR(I,J,K,L) = NUNIQ - INDTWR(JTR,ITR,K,L) = NUNIQ * SignIJ - INDTWR(I,J,LTR,KTR) = NUNIQ * SignKL - INDTWR(JTR,ITR,LTR,KTR) = NUNIQ * SignIJ * SignKL - INDTWI(I,J,K,L) = NUNIQ - INDTWI(JTR,ITR,K,L) = NUNIQ * SignIJ - INDTWI(I,J,LTR,KTR) = NUNIQ * SignKL - INDTWI(JTR,ITR,LTR,KTR) = NUNIQ * SignIJ * SignKL -!=-> Complex conjugate plus time-reversed partners - INDTWR(J,I,L,K) = NUNIQ - INDTWR(ITR,JTR,L,K) = NUNIQ * SignIJ - INDTWR(J,I,KTR,LTR) = NUNIQ * SignKL - INDTWR(ITR,JTR,KTR,LTR) = NUNIQ * SignIJ * SignKL - INDTWI(J,I,L,K) = - NUNIQ - INDTWI(ITR,JTR,L,K) = - NUNIQ * SignIJ - INDTWI(J,I,KTR,LTR) = - NUNIQ * SignKL - INDTWI(ITR,JTR,KTR,LTR) = - NUNIQ * SignIJ * SignKL -!=-> Particle interchanged plus time-reversed partners - INDTWR(K,L,I,J) = NUNIQ - INDTWR(LTR,KTR,I,J) = NUNIQ * SignKL - INDTWR(K,L,JTR,ITR) = NUNIQ * SignIJ - INDTWR(LTR,KTR,JTR,ITR) = NUNIQ * SignIJ * SignKL - INDTWI(K,L,I,J) = NUNIQ - INDTWI(LTR,KTR,I,J) = NUNIQ * SignKL - INDTWI(K,L,JTR,ITR) = NUNIQ * SignIJ - INDTWI(LTR,KTR,JTR,ITR) = NUNIQ * SignIJ * SignKL -!=-> Particle interchanged and complex conjugated plus time-reversed partners - INDTWR(L,K,J,I) = NUNIQ - INDTWR(KTR,LTR,J,I) = NUNIQ * SignKL - INDTWR(L,K,ITR,JTR) = NUNIQ * SignIJ - INDTWR(KTR,LTR,ITR,JTR) = NUNIQ * SignIJ * SignKL - INDTWI(L,K,J,I) = - NUNIQ - INDTWI(KTR,LTR,J,I) = - NUNIQ * SignKL - INDTWI(L,K,ITR,JTR) = - NUNIQ * SignIJ - INDTWI(KTR,LTR,ITR,JTR) = - NUNIQ * SignIJ * SignKL - - int2rs(nuniq) = rklr(inz) - int2is(nuniq) = rkli(inz) - -! If(abs(rklr(inz))>1.0d-1) write(*,*)rklr(inz),rkli(inz), & -! & i, j, k, l - - if(abs(rkli(inz)) > thres) realc = .false. - -!! if((nuniq == 742).or.(nuniq == 2082)) then -!! write(*,*)int2r(nuniq) -!! write(*,*)int2i(nuniq) -!! write(*,5)I,J,K,L ,INDTWR(I,J,K,L) ,INDTWI(I,J,K,L) & -!! & ,JTR,ITR,K,L ,INDTWR(JTR,ITR,K,L) ,INDTWI(JTR,ITR,K,L) & -!! & ,I,J,LTR,KTR ,INDTWR(I,J,LTR,KTR) ,INDTWI(I,J,LTR,KTR) & -!! & ,JTR,ITR,LTR,KTR,INDTWR(JTR,ITR,LTR,KTR),INDTWI(JTR,ITR,LTR,KTR) -!! -!! write(*,5)J,I,L,K ,INDTWR(J,I,L,K) ,INDTWI(J,I,L,K) & -!! & ,ITR,JTR,L,K ,INDTWR(ITR,JTR,L,K) ,INDTWI(ITR,JTR,L,K) & -!! & ,J,I,KTR,LTR ,INDTWR(J,I,KTR,LTR) ,INDTWI(J,I,KTR,LTR) & -!! & ,ITR,JTR,KTR,LTR,INDTWR(ITR,JTR,KTR,LTR),INDTWI(ITR,JTR,KTR,LTR) -!! -!! write(*,5)K,L,I,J ,INDTWR(K,L,I,J) ,INDTWI(K,L,I,J) & -!! & ,LTR,KTR,I,J ,INDTWR(LTR,KTR,I,J) ,INDTWI(LTR,KTR,I,J) & -!! & ,K,L,JTR,ITR ,INDTWR(K,L,JTR,ITR) ,INDTWI(K,L,JTR,ITR) & -!! & ,LTR,KTR,JTR,ITR,INDTWR(LTR,KTR,JTR,ITR),INDTWI(LTR,KTR,JTR,ITR) -!! -!! write(*,5)L,K,J,I ,INDTWR(L,K,J,I) ,INDTWI(L,K,J,I) & -!! & ,KTR,LTR,J,I ,INDTWR(KTR,LTR,J,I) ,INDTWI(KTR,LTR,J,I) & -!! & ,L,K,ITR,JTR ,INDTWR(L,K,ITR,JTR) ,INDTWI(L,K,ITR,JTR) & -!! & ,KTR,LTR,ITR,JTR,INDTWR(KTR,LTR,ITR,JTR),INDTWI(KTR,LTR,ITR,JTR) -!! end if - - 5 FORMAT(4(4I3,2I6)) - - - 70 Enddo - - indk(:)=0 - indl(:)=0 - rklr = 0.0d+00 - rkli = 0.0d+00 - - Goto 60 - - - - - 10 write(*,*)'error for opening mdcint 10' - go to 100 - 20 write(*,*)'error for reading mdcint 20' - go to 100 - 30 write(*,*)'end mdcint 30' - go to 100 - 40 write(*,*)'error for reading mdcint 40' - go to 100 - 50 write(*,*)'end mdcint 50 normal' - go to 100 - - 100 continue - - close (mdcint) - write(*,*)nuniq,totalint - - Allocate(int2r(0:nuniq)); Call memplus(KIND(int2r),SIZE(int2r),1) - - int2r(0:nuniq) = int2rs(0:nuniq) - - Deallocate(int2rs); Call memminus(KIND(int2rs),SIZE(int2rs),1) - - Allocate(int2i(0:nuniq)); Call memplus(KIND(int2i),SIZE(int2i),1) - - int2i(0:nuniq) = int2is(0:nuniq) - - Deallocate(int2is); Call memminus(KIND(int2is),SIZE(int2is),1) - - - - deallocate (indk); Call memminus(KIND(indk),SIZE(indk),1) - deallocate (indl); Call memminus(KIND(indl),SIZE(indl),1) - deallocate (rklr); Call memminus(KIND(rklr),SIZE(rklr),1) - deallocate (rkli); Call memminus(KIND(rkli),SIZE(rkli),1) - deallocate (kr ); Call memminus(KIND(kr ),SIZE(kr ),1) - - end subroutine readint2 - diff --git a/src/readint2_casci_co.f90 b/src/readint2_casci_co.f90 index a0538cf8..741b0387 100644 --- a/src/readint2_casci_co.f90 +++ b/src/readint2_casci_co.f90 @@ -5,6 +5,7 @@ SUBROUTINE readint2_casci_co(filename, nuniq) ! 2 electorn integrals created by ! ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ use four_caspt2_module + use module_file_manager Implicit NONE #ifdef HAVE_MPI @@ -23,7 +24,7 @@ SUBROUTINE readint2_casci_co(filename, nuniq) ! 2 electorn integrals created by complex*16 :: cint2 integer, allocatable :: indk(:, :), indl(:, :), kr(:) real*8, allocatable :: rklr(:, :), rkli(:, :) - logical :: continue_read + logical :: continue_read, is_end_of_file integer :: idx, read_line_len, iostat read_line_len = read_line_max ! Set read_line_len as parameter "read_line_max" ! Iwamuro modify @@ -72,20 +73,14 @@ SUBROUTINE readint2_casci_co(filename, nuniq) ! 2 electorn integrals created by totalint = 0 mdcint = 11 - open (mdcint, file=trim(filename), form='unformatted', status='old') + call open_unformatted_file(unit=mdcint, file=trim(filename), status='old', optional_action='read') read (mdcint, iostat=iostat) datex, timex, nkr, & (kr(i0), kr(-1*i0), i0=1, nkr) - ! File status check - if (iostat < 0) then - ! End of file + call check_iostat(iostat=iostat, file=trim(filename), end_of_file_reached=is_end_of_file) + if (is_end_of_file) then continue_read = .false. - else if (iostat > 0) then - ! Error in reading file - print *, "ERROR: Error in reading ", trim(filename), " , rank = ", rank - print *, "Stop the program" - stop end if if (rank == 0) then @@ -96,16 +91,10 @@ SUBROUTINE readint2_casci_co(filename, nuniq) ! 2 electorn integrals created by do idx = 1, read_line_max read (mdcint, iostat=iostat) i(idx), j(idx), nz(idx), & (indk(idx, inz), indl(idx, inz), rklr(idx, inz), rkli(idx, inz), inz=1, nz(idx)) - ! File status check - if (iostat < 0) then - ! End of file + call check_iostat(iostat=iostat, file=trim(filename), end_of_file_reached=is_end_of_file) + if (is_end_of_file) then continue_read = .false. - exit ! Exit the read loop - else if (iostat > 0) then - ! Error in reading file - print *, "ERROR: Error in readinga ", trim(filename), " , rank = ", rank - print *, "Stop the program" - stop + exit end if end do diff --git a/src/readint2_ivo.f90 b/src/readint2_ivo.f90 deleted file mode 100644 index de135398..00000000 --- a/src/readint2_ivo.f90 +++ /dev/null @@ -1,372 +0,0 @@ -! ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ - - SUBROUTINE readint2_ivo (filename, nuniq) ! 2 electorn integrals in MDCINT - -! ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ - - use four_caspt2_module - - Implicit NONE - - character*50,intent(in) :: filename - - character :: datex*10, timex*8 - - integer :: mdcint, nkr, idum, nuniq, nmom, nmoc - integer :: nz, type - integer :: j0, i0, i1 - integer :: k0, l0, ii, jj, kk, ll, signind - integer :: i, j, k, l, ikr, jkr, lkr, kkr, jtr0, itr0 - integer :: SignIJ, SignKL, itr, jtr, ltr, ktr, inz, totalint, save, count - - complex*16 :: cint2 - - integer, allocatable :: indk(:), indl(:), kr(:) - real*8, allocatable :: rklr(:), rkli(:), int2rs(:), int2is(:) - - logical :: breit - - nmoc = ninact + nact - nmom = ninact + nact + nsec - - - Allocate(int2r_f1(ninact+nact+1:ninact+nact+nsec,ninact+nact+1:ninact+nact+nsec,nmoc,nmoc)) - Allocate(int2i_f1(ninact+nact+1:ninact+nact+nsec,ninact+nact+1:ninact+nact+nsec,nmoc,nmoc)) - Allocate(int2r_f2(ninact+nact+1:ninact+nact+nsec,nmoc,nmoc,ninact+nact+1:ninact+nact+nsec)) - Allocate(int2i_f2(ninact+nact+1:ninact+nact+nsec,nmoc,nmoc,ninact+nact+1:ninact+nact+nsec)) - Call memplus(KIND(int2r_f1),SIZE(int2r_f1),1) - Call memplus(KIND(int2i_f1),SIZE(int2i_f1),1) - Call memplus(KIND(int2r_f2),SIZE(int2r_f2),1) - Call memplus(KIND(int2i_f2),SIZE(int2i_f2),1) - - - Allocate(kr(-nmo/2:nmo/2)) ; Call memplus(KIND(kr) ,SIZE(kr) ,1) - -! Allocate(indtwr(nmoc,nmoc,nmoc,nmoc)); Call memplus(KIND(indtwr),SIZE(indtwr),1) -! Allocate(indtwi(nmoc,nmoc,nmoc,nmoc)); Call memplus(KIND(indtwi),SIZE(indtwi),1) - - - kr = 0 - - Allocate(indk((nmo/2)**2)); Call memplus(KIND(indk),SIZE(indk),1) - Allocate(indl((nmo/2)**2)); Call memplus(KIND(indl),SIZE(indl),1) - Allocate(rklr((nmo/2)**2)); Call memplus(KIND(rklr),SIZE(rklr),1) - Allocate(rkli((nmo/2)**2)); Call memplus(KIND(rkli),SIZE(rkli),1) - - - write(*,'("Current Memory is ",F10.2,"MB")')tmem/1024/1024 - - nuniq = 0 - indk(:) = 0 - indl(:) = 0 - rklr(:) = 0.0d+00 - rkli(:) = 0.0d+00 -! int2r(:) = 0.0d+00 -! int2i(:) = 0.0d+00 -! indtwr = 0 -! indtwi = 0 - int2r_f1 = 0.0d+00 - int2i_f1 = 0.0d+00 - int2r_f2 = 0.0d+00 - int2i_f2 = 0.0d+00 - kr = 0 - - totalint = 0 - mdcint=11 - open( mdcint, file=trim(filename),form ='unformatted', status='old', err=10) - - Read (mdcint,err=20,end=30) datex,timex,nkr, & - (kr(i0),kr(-1*i0),i0=1,nkr) -!old Read (mdcint,err=20,end=30) datex,timex,nkr, & -!old (idum,i0=1,4*nkr),(kr(i0),kr(-1*i0),i0=1,nkr) - - write(*,*) datex,timex - write(*,*) 'nkr',nkr,'kr(+),kr(-)', (kr(i0),kr(-1*i0),i0=1,nkr) - - 60 read (mdcint,ERR=40,END=50) ikr,jkr,nz, & - (indk(inz),indl(inz),inz=1,nz), & - (rklr(inz),rkli(inz),inz=1,nz) - -! write(*,*) ikr,jkr,nz - - if (ikr==0) goto 50 - - totalint = totalint + nz - - i = indmor(kr(ikr)) - itr = indmor(kr(-ikr)) - j = indmor(kr(jkr)) - jtr = indmor(kr(-jkr)) - - i0 = i - itr0 = itr - j0 = j - jtr0 = jtr - - - - Do inz = 1, nz - - i = i0 - itr = itr0 - j = j0 - jtr = jtr0 - - kkr = indk(inz) - k = indmor(kr(kkr)) - ktr = indmor(kr(-kkr)) - lkr = indl(inz) - l = indmor(kr(lkr)) - ltr = indmor(kr(-lkr)) - - -! write(*,*)sp(i),sp(j),sp(k),sp(l) -! if(sp(l) == 0) write(*,*)i,j,k,l,'0' - - If(i > nmoc .and. j > nmoc .and. k > nmoc .and. l > nmoc) goto 70 ! (33|33) is ignored - - if(sp(i)==3.and.sp(j)==3 .and. sp(k)< 3.and.sp(l)==sp(k)) then !(33|11) or (33|22) type -! write(*,'("type 2",4I4,2E20.10)')i,j,k,l,rklr(inz),rkli(inz) - - count = 0 - - 11 if(mod(i, 2) == 0) then - itr = i - 1 - else - itr = i + 1 - endif - - if(mod(j, 2) == 0) then - jtr = j - 1 - else - jtr = j + 1 - endif - - if(mod(k, 2) == 0) then - ktr = k - 1 - else - ktr = k + 1 - endif - - if(mod(l, 2) == 0) then - ltr = l - 1 - else - ltr = l + 1 - endif - - SignIJ = (-1.0d+00)**mod(i+j,2) - SignKL = (-1.0d+00)**mod(k+l,2) -! write(*,*)'sign',signIJ,signKL - - int2r_f1(i,j,k,l) = rklr(inz) - int2i_f1(i,j,k,l) = rkli(inz) - - int2r_f1(jtr,itr,k,l) = SignIJ*rklr(inz) - int2i_f1(jtr,itr,k,l) = SignIJ*rkli(inz) - - int2r_f1(i,j,ltr,ktr) = SignKL*rklr(inz) - int2i_f1(i,j,ltr,ktr) = SignKL*rkli(inz) - - int2r_f1(jtr,itr,ltr,ktr) = SignIJ*SignKL*rklr(inz) - int2i_f1(jtr,itr,ltr,ktr) = SignIJ*SignKL*rkli(inz) - - count = count + 1 - cint2 = DCMPLX(rklr(inz),rkli(inz)) - if(count ==1) then - Call takekr(i,j,k,l,cint2) ! Consider Kramers pair - rklr(inz) = DBLE(cint2) - rkli(inz) = DIMAG(cint2) - goto 11 - else - goto 70 - endif - - elseif(sp(k)==3.and.sp(l)==3 .and. sp(i)< 3.and.sp(i)==sp(j)) then !(11|33) or (22|33) type -! write(*,'("type 2",4I4,2E20.10)')i,j,k,l,rklr(inz),rkli(inz) - - count = 0 - - 21 if(mod(i, 2) == 0) then - itr = i - 1 - else - itr = i + 1 - endif - - if(mod(j, 2) == 0) then - jtr = j - 1 - else - jtr = j + 1 - endif - - if(mod(k, 2) == 0) then - ktr = k - 1 - else - ktr = k + 1 - endif - - if(mod(l, 2) == 0) then - ltr = l - 1 - else - ltr = l + 1 - endif - - SignIJ = (-1.0d+00)**mod(i+j,2) - SignKL = (-1.0d+00)**mod(k+l,2) -! write(*,*)'sign',signIJ,signKL - - int2r_f1(k,l,i,j) = rklr(inz) - int2i_f1(k,l,i,j) = rkli(inz) - - int2r_f1(k,l,jtr,itr) = SignIJ*rklr(inz) - int2i_f1(k,l,jtr,itr) = SignIJ*rkli(inz) - - int2r_f1(ltr,ktr,i,j) = SignKL*rklr(inz) - int2i_f1(ltr,ktr,i,j) = SignKL*rkli(inz) - - int2r_f1(ltr,ktr,jtr,itr) = SignIJ*SignKL*rklr(inz) - int2i_f1(ltr,ktr,jtr,itr) = SignIJ*SignKL*rkli(inz) - - count = count + 1 - cint2 = DCMPLX(rklr(inz),rkli(inz)) - if(count ==1) then - Call takekr(i,j,k,l,cint2) ! Consider Kramers pair - rklr(inz) = DBLE(cint2) - rkli(inz) = DIMAG(cint2) - goto 21 - else - goto 70 - endif - - elseif(max(sp(i),sp(j))==3.and.max(sp(k),sp(l))==3.and. & - & min(sp(i),sp(j))==min(sp(k),sp(l))) then !(31|31) or (32|32) series - - count = 0 - - 12 if(mod(i, 2) == 0) then - itr = i - 1 - else - itr = i + 1 - endif - - if(mod(j, 2) == 0) then - jtr = j - 1 - else - jtr = j + 1 - endif - - if(mod(k, 2) == 0) then - ktr = k - 1 - else - ktr = k + 1 - endif - - if(mod(l, 2) == 0) then - ltr = l - 1 - else - ltr = l + 1 - endif - - SignIJ = (-1.0d+00)**mod(i+j,2) - SignKL = (-1.0d+00)**mod(k+l,2) - - - if(i > j .and. k > l) then ! (31|31) or (32|32) ==> (31|13) or (32|23) - - int2r_f2(i,j,ltr,ktr) = signKL*rklr(inz) - int2i_f2(i,j,ltr,ktr) = signKL*rkli(inz) - -! write(*,*)i,j,ltr,ktr,int2r_f2(i,j,ltr,ktr),int2i_f2(i,j,ltr,ktr) - - elseif(i > j .and. k < l) then ! (31|13) or (32|23) ==> (31|13) or (32|23) - - int2r_f2(i,j,k,l) = rklr(inz) - int2i_f2(i,j,k,l) = rkli(inz) - -! write(*,*)i,j,k,l,int2r_f2(i,j,k,l),int2i_f2(i,j,k,l) - - elseif(i < j .and. k < l) then ! (13|13) or (23|23) ==> (31|13) or (32|23) - - int2r_f2(jtr,itr,k,l) = signIJ*rklr(inz) - int2i_f2(jtr,itr,k,l) = signIJ*rkli(inz) - -! write(*,*)jtr,itr,k,l,int2r_f2(jtr,itr,k,l),int2i_f2(jtr,itr,k,l) - - elseif(i < j .and. k > l) then ! (13|31) or (23|32) ==> (31|13) or (32|23) - - int2r_f2(jtr,itr,ltr,ktr) = signIJ*signKL*rklr(inz) - int2i_f2(jtr,itr,ltr,ktr) = signIJ*signKL*rkli(inz) - -! write(*,*)jtr,itr,ltr,ktr,int2r_f2(jtr,itr,ltr,ktr),int2i_f2(jtr,itr,ltr,ktr) - - endif - - count = count + 1 - cint2 = DCMPLX(rklr(inz),rkli(inz)) - if(count ==1 .or. count ==3) then - Call takekr(i,j,k,l,cint2) ! Consider Kramers pair - rklr(inz) = DBLE(cint2) - rkli(inz) = DIMAG(cint2) - goto 12 - elseif(count == 2 ) then ! variables exchange (AA|BB) => (BB|AA) - save = i - i = k - k = save - save = j - j = l - l = save - goto 12 - else - goto 70 - endif - endif - - 70 Enddo - - indk(:)=0 - indl(:)=0 - rklr = 0.0d+00 - rkli = 0.0d+00 - - Goto 60 - - - - - 10 write(*,*)'error for opening mdcint 10' - go to 100 - 20 write(*,*)'error for reading mdcint 20' - go to 100 - 30 write(*,*)'end mdcint 30' - go to 100 - 40 write(*,*)'error for reading mdcint 40' - go to 100 - 50 write(*,*)'end mdcint 50 normal' - go to 100 - - 100 continue - - close (mdcint) - write(*,*)nuniq,totalint - -! Allocate(int2r(0:nuniq)); Call memplus(KIND(int2r),SIZE(int2r),1) -! -! int2r(0:nuniq) = int2rs(0:nuniq) -! -! Deallocate(int2rs); Call memminus(KIND(int2rs),SIZE(int2rs),1) -! -! Allocate(int2i(0:nuniq)); Call memplus(KIND(int2i),SIZE(int2i),1) -! -! int2i(0:nuniq) = int2is(0:nuniq) -! -! Deallocate(int2is); Call memminus(KIND(int2is),SIZE(int2is),1) - - - - deallocate (indk); Call memminus(KIND(indk),SIZE(indk),1) - deallocate (indl); Call memminus(KIND(indl),SIZE(indl),1) - deallocate (rklr); Call memminus(KIND(rklr),SIZE(rklr),1) - deallocate (rkli); Call memminus(KIND(rkli),SIZE(rkli),1) - deallocate (kr ); Call memminus(KIND(kr ),SIZE(kr ),1) - - end subroutine readint2_ivo - diff --git a/src/readint2_ivo_ty.f90 b/src/readint2_ivo_ty.f90 deleted file mode 100644 index 2e57c261..00000000 --- a/src/readint2_ivo_ty.f90 +++ /dev/null @@ -1,338 +0,0 @@ -! ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ - - SUBROUTINE readint2_ivo_ty (filename, nuniq) ! 2 electorn integrals created by typart in utchem - -! ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ - - use four_caspt2_module - - Implicit NONE - - character*50,intent(in) :: filename - - character :: datex*10, timex*8 - - integer :: mdcint, nkr, idum, nuniq, nmom, nmoc - integer :: nz, type - integer :: j0, i0, i1 - integer :: k0, l0, ii, jj, kk, ll, signind - integer :: i, j, k, l, jtr0, itr0 - integer :: SignIJ, SignKL, itr, jtr, ltr, ktr, inz, totalint, save, count - - complex*16 :: cint2 - - integer, allocatable :: indk(:), indl(:) - real*8, allocatable :: rklr(:), rkli(:), int2rs(:), int2is(:) - - logical :: breit - - nmoc = ninact + nact - nmom = ninact + nact + nsec - - - Allocate(int2r_f1(ninact+nact+1:ninact+nact+nsec,ninact+nact+1:ninact+nact+nsec,nmoc,nmoc)) - Allocate(int2i_f1(ninact+nact+1:ninact+nact+nsec,ninact+nact+1:ninact+nact+nsec,nmoc,nmoc)) - Allocate(int2r_f2(ninact+nact+1:ninact+nact+nsec,nmoc,nmoc,ninact+nact+1:ninact+nact+nsec)) - Allocate(int2i_f2(ninact+nact+1:ninact+nact+nsec,nmoc,nmoc,ninact+nact+1:ninact+nact+nsec)) - Call memplus(KIND(int2r_f1),SIZE(int2r_f1),1) - Call memplus(KIND(int2i_f1),SIZE(int2i_f1),1) - Call memplus(KIND(int2r_f2),SIZE(int2r_f2),1) - Call memplus(KIND(int2i_f2),SIZE(int2i_f2),1) - - Allocate(indk((nmo/2)**2)); Call memplus(KIND(indk),SIZE(indk),1) - Allocate(indl((nmo/2)**2)); Call memplus(KIND(indl),SIZE(indl),1) - Allocate(rklr((nmo/2)**2)); Call memplus(KIND(rklr),SIZE(rklr),1) - Allocate(rkli((nmo/2)**2)); Call memplus(KIND(rkli),SIZE(rkli),1) - - - write(*,'("Current Memory is ",F10.2,"MB")')tmem/1024/1024 - - nuniq = 0 - ! Noda 2021/12/27 The initialization below this line may not be necessary for correct calculations. (Just Code reading) - indk(:) = 0 - indl(:) = 0 - rklr(:) = 0.0d+00 - rkli(:) = 0.0d+00 - int2r_f1 = 0.0d+00 - int2i_f1 = 0.0d+00 - int2r_f2 = 0.0d+00 - int2i_f2 = 0.0d+00 - ! End Noda 2021/12/27 The initialization before this line may not be necessary for correct calculations. (Just Code reading) - - totalint = 0 - mdcint=11 - open( mdcint, file=trim(filename),form ='unformatted', status='old', err=10) - - 60 read (mdcint,ERR=40,END=50) i,j,nz, & - (indk(inz),indl(inz),inz=1,nz), & - (rklr(inz),rkli(inz),inz=1,nz) - - if (i==0) goto 50 - - totalint = totalint + nz - - itr = i+(-1)**(mod(i,2)+1) - jtr = j+(-1)**(mod(j,2)+1) - - i0 = i - itr0 = itr - j0 = j - jtr0 = jtr - - Do inz = 1, nz - - i = i0 - itr = itr0 - j = j0 - jtr = jtr0 - - k = indk(inz) - ktr = k+(-1)**(mod(k,2)+1) - l = indl(inz) - ltr = l+(-1)**(mod(l,2)+1) - - If(i > nmoc .and. j > nmoc .and. k > nmoc .and. l > nmoc) goto 70 ! (33|33) is ignored - If(i==j .and. k > l) goto 70 - - if(sp(i)==3.and.sp(j)==3 .and. sp(k)< 3.and.sp(l)==sp(k)) then !(33|11) or (33|22) type - - count = 0 - - 11 if(mod(i, 2) == 0) then - itr = i - 1 - else - itr = i + 1 - endif - - if(mod(j, 2) == 0) then - jtr = j - 1 - else - jtr = j + 1 - endif - - if(mod(k, 2) == 0) then - ktr = k - 1 - else - ktr = k + 1 - endif - - if(mod(l, 2) == 0) then - ltr = l - 1 - else - ltr = l + 1 - endif - - SignIJ = (-1.0d+00)**mod(i+j,2) - SignKL = (-1.0d+00)**mod(k+l,2) - - int2r_f1(i,j,k,l) = rklr(inz) - int2i_f1(i,j,k,l) = rkli(inz) - - int2r_f1(jtr,itr,k,l) = SignIJ*rklr(inz) - int2i_f1(jtr,itr,k,l) = SignIJ*rkli(inz) - - int2r_f1(i,j,ltr,ktr) = SignKL*rklr(inz) - int2i_f1(i,j,ltr,ktr) = SignKL*rkli(inz) - - int2r_f1(jtr,itr,ltr,ktr) = SignIJ*SignKL*rklr(inz) - int2i_f1(jtr,itr,ltr,ktr) = SignIJ*SignKL*rkli(inz) - - count = count + 1 - cint2 = DCMPLX(rklr(inz),rkli(inz)) - if(count ==1) then - Call takekr(i,j,k,l,cint2) ! Consider Kramers pair - rklr(inz) = DBLE(cint2) - rkli(inz) = DIMAG(cint2) - goto 11 - else - goto 70 - endif - - elseif(sp(k)==3.and.sp(l)==3 .and. sp(i)< 3.and.sp(i)==sp(j)) then !(11|33) or (22|33) type -! write(*,'("type 2",4I4,2E20.10)')i,j,k,l,rklr(inz),rkli(inz) - - count = 0 - - 21 if(mod(i, 2) == 0) then - itr = i - 1 - else - itr = i + 1 - endif - - if(mod(j, 2) == 0) then - jtr = j - 1 - else - jtr = j + 1 - endif - - if(mod(k, 2) == 0) then - ktr = k - 1 - else - ktr = k + 1 - endif - - if(mod(l, 2) == 0) then - ltr = l - 1 - else - ltr = l + 1 - endif - - SignIJ = (-1.0d+00)**mod(i+j,2) - SignKL = (-1.0d+00)**mod(k+l,2) - - int2r_f1(k,l,i,j) = rklr(inz) - int2i_f1(k,l,i,j) = rkli(inz) - - int2r_f1(k,l,jtr,itr) = SignIJ*rklr(inz) - int2i_f1(k,l,jtr,itr) = SignIJ*rkli(inz) - - int2r_f1(ltr,ktr,i,j) = SignKL*rklr(inz) - int2i_f1(ltr,ktr,i,j) = SignKL*rkli(inz) - - int2r_f1(ltr,ktr,jtr,itr) = SignIJ*SignKL*rklr(inz) - int2i_f1(ltr,ktr,jtr,itr) = SignIJ*SignKL*rkli(inz) - - count = count + 1 - cint2 = DCMPLX(rklr(inz),rkli(inz)) - if(count ==1) then - Call takekr(i,j,k,l,cint2) ! Consider Kramers pair - rklr(inz) = DBLE(cint2) - rkli(inz) = DIMAG(cint2) - goto 21 - else - goto 70 - endif - - elseif(max(sp(i),sp(j))==3.and.max(sp(k),sp(l))==3.and. & - & min(sp(i),sp(j))==min(sp(k),sp(l))) then !(31|31) or (32|32) series - - count = 0 - - 12 if(mod(i, 2) == 0) then - itr = i - 1 - else - itr = i + 1 - endif - - if(mod(j, 2) == 0) then - jtr = j - 1 - else - jtr = j + 1 - endif - - if(mod(k, 2) == 0) then - ktr = k - 1 - else - ktr = k + 1 - endif - - if(mod(l, 2) == 0) then - ltr = l - 1 - else - ltr = l + 1 - endif - - SignIJ = (-1.0d+00)**mod(i+j,2) - SignKL = (-1.0d+00)**mod(k+l,2) - - - if(i > j .and. k > l) then ! (31|31) or (32|32) ==> (31|13) or (32|23) - - int2r_f2(i,j,ltr,ktr) = signKL*rklr(inz) - int2i_f2(i,j,ltr,ktr) = signKL*rkli(inz) - -! write(*,*)i,j,ltr,ktr,int2r_f2(i,j,ltr,ktr),int2i_f2(i,j,ltr,ktr) - - elseif(i > j .and. k < l) then ! (31|13) or (32|23) ==> (31|13) or (32|23) - - int2r_f2(i,j,k,l) = rklr(inz) - int2i_f2(i,j,k,l) = rkli(inz) - -! write(*,*)i,j,k,l,int2r_f2(i,j,k,l),int2i_f2(i,j,k,l) - - elseif(i < j .and. k < l) then ! (13|13) or (23|23) ==> (31|13) or (32|23) - - int2r_f2(jtr,itr,k,l) = signIJ*rklr(inz) - int2i_f2(jtr,itr,k,l) = signIJ*rkli(inz) - -! write(*,*)jtr,itr,k,l,int2r_f2(jtr,itr,k,l),int2i_f2(jtr,itr,k,l) - - elseif(i < j .and. k > l) then ! (13|31) or (23|32) ==> (31|13) or (32|23) - - int2r_f2(jtr,itr,ltr,ktr) = signIJ*signKL*rklr(inz) - int2i_f2(jtr,itr,ltr,ktr) = signIJ*signKL*rkli(inz) - -! write(*,*)jtr,itr,ltr,ktr,int2r_f2(jtr,itr,ltr,ktr),int2i_f2(jtr,itr,ltr,ktr) - - endif - - count = count + 1 - cint2 = DCMPLX(rklr(inz),rkli(inz)) - if(count ==1 .or. count ==3) then - Call takekr(i,j,k,l,cint2) ! Consider Kramers pair - rklr(inz) = DBLE(cint2) - rkli(inz) = DIMAG(cint2) - goto 12 - elseif(count == 2 ) then ! variables exchange (AA|BB) => (BB|AA) - save = i - i = k - k = save - save = j - j = l - l = save - goto 12 - else - goto 70 - endif - endif - - 70 Enddo - ! Noda 2021/12/27 The initialization below this line may not be necessary for correct calculations. (Just Code reading) - indk(:)=0 - indl(:)=0 - rklr = 0.0d+00 - rkli = 0.0d+00 - ! End Noda 2021/12/27 The initialization before this line may not be necessary for correct calculations. (Just Code reading) - - Goto 60 - - - - - 10 write(*,*)'error for opening mdcint 10' - go to 100 - 20 write(*,*)'error for reading mdcint 20' - go to 100 - 30 write(*,*)'end mdcint 30' - go to 100 - 40 write(*,*)'error for reading mdcint 40' - go to 100 - 50 write(*,*)'end mdcint 50 normal' - go to 100 - - 100 continue - - close (mdcint) - write(*,*)nuniq,totalint - -! Allocate(int2r(0:nuniq)); Call memplus(KIND(int2r),SIZE(int2r),1) -! -! int2r(0:nuniq) = int2rs(0:nuniq) -! -! Deallocate(int2rs); Call memminus(KIND(int2rs),SIZE(int2rs),1) -! -! Allocate(int2i(0:nuniq)); Call memplus(KIND(int2i),SIZE(int2i),1) -! -! int2i(0:nuniq) = int2is(0:nuniq) -! -! Deallocate(int2is); Call memminus(KIND(int2is),SIZE(int2is),1) - - - - deallocate (indk); Call memminus(KIND(indk),SIZE(indk),1) - deallocate (indl); Call memminus(KIND(indl),SIZE(indl),1) - deallocate (rklr); Call memminus(KIND(rklr),SIZE(rklr),1) - deallocate (rkli); Call memminus(KIND(rkli),SIZE(rkli),1) - - end subroutine readint2_ivo_ty - diff --git a/src/readint2_nr.f90 b/src/readint2_nr.f90 deleted file mode 100644 index daf64d8e..00000000 --- a/src/readint2_nr.f90 +++ /dev/null @@ -1,250 +0,0 @@ -! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= -! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= - - SUBROUTINE readint2_nr - -! This part is originally writen by Dr. T. Yanai as itrf code in program package UTChem. -! Here is modified for reading non-relativistic integrals to compute four-CASPT2 -! By M. Abe. -! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= -! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= - - use four_caspt2_module - - Implicit NONE - - integer :: ndim, intindx, ncount, redund, i, ii - integer :: nrint, tcount - integer :: val_integer - integer :: bitsize_integer - integer, Allocatable :: wrtidx(:,:), idx(:,:) - real*8, Allocatable :: val(:) - character*50 :: filename - - write(*,*)' ENTER readint2_nr' - bitsize_integer = KIND(val_integer)*8 - - filename='moint2.info.aaaa' - nrint = 11 - open (nrint, file=filename, status='old', access='sequential', form='formatted') - write(*,*)' open file info.aaaa OK' - read(nrint,*) ndim, intindx, ncount, redund - write(*,*)ndim, intindx, ncount, redund - - close(nrint) - -! AT PRESENT RHF ORBITALS ARE ASSUMED! - - filename ='moint2.aaaa' - open (nrint, file=trim(filename), & - status='old', access='sequential', form='unformatted') - write(*,*)' open file aaaa OK' - - If(ncount == 1) then - Allocate(wrtidx(1:intindx, 1:redund)) - Allocate(val(1:redund)) - Allocate(idx(4, 1:redund)) - Else - Allocate(wrtidx(1:intindx, 1:ndim)) - Allocate(val(1:ndim)) - Allocate(idx(4, 1:ndim)) - Endif - - wrtidx = 0 - val = 0.0d+00 - idx = 0 - tcount = 0 - - Allocate(indtwr(nmo,nmo,nmo,nmo)) - Allocate(indtwi(nmo,nmo,nmo,nmo)) - - indtwr = 0 - indtwi = 0 - - Do i = 1, ncount-1 - - Read(nrint,ERR=40,END=50) wrtidx(1:intindx,1:ndim) - Read(nrint,ERR=40,END=50) val(1:ndim) - - Do ii=1, ndim - - Select case(intindx) - - Case (1) - idx(1,ii) = IBITS(wrtidx(1,ii),bitsize_integer*3/4,bitsize_integer/4) - idx(2,ii) = IBITS(wrtidx(1,ii),bitsize_integer*2/4,bitsize_integer/4) - idx(3,ii) = IBITS(wrtidx(1,ii),bitsize_integer*1/4,bitsize_integer/4) - idx(4,ii) = IBITS(wrtidx(1,ii),bitsize_integer*0/4,bitsize_integer/4) - - Case (2) - idx(1,ii) = IBITS(wrtidx(1,ii),bitsize_integer*1/2,bitsize_integer/2) - idx(2,ii) = IBITS(wrtidx(1,ii),bitsize_integer*0/2,bitsize_integer/2) - idx(3,ii) = IBITS(wrtidx(2,ii),bitsize_integer*1/2,bitsize_integer/2) - idx(4,ii) = IBITS(wrtidx(2,ii),bitsize_integer*0/2,bitsize_integer/2) - - Case (4) - idx(1,ii) = wrtidx(1,ii) - idx(2,ii) = wrtidx(2,ii) - idx(3,ii) = wrtidx(3,ii) - idx(4,ii) = wrtidx(4,ii) - - Case default - write(*,*) "[INPUT ERROR] @Int2_idx : out of select ( 1 / 2 / 4 )" - stop - - end Select - - idx(:,ii) = 2*idx(:,ii) - ncore - - If ((idx(1,ii) > ninact+nact).and.(idx(2,ii) > ninact+nact).and. & - (idx(3,ii) > ninact+nact).and.(idx(4,ii) > ninact+nact)) then - Else - tcount = tcount + 1 - int2r(tcount) = val(ii) - - INDTWR(idx(1,ii) ,idx(2,ii) ,idx(3,ii) ,idx(4,ii) ) = tcount - INDTWR(idx(1,ii) ,idx(2,ii) ,idx(4,ii) ,idx(3,ii) ) = tcount - INDTWR(idx(2,ii) ,idx(1,ii) ,idx(3,ii) ,idx(4,ii) ) = tcount - INDTWR(idx(2,ii) ,idx(1,ii) ,idx(4,ii) ,idx(3,ii) ) = tcount - - INDTWR(idx(1,ii)-1,idx(2,ii)-1,idx(3,ii)-1,idx(4,ii)-1) = tcount - INDTWR(idx(2,ii)-1,idx(1,ii)-1,idx(3,ii)-1,idx(4,ii)-1) = tcount - INDTWR(idx(1,ii)-1,idx(2,ii)-1,idx(4,ii)-1,idx(3,ii)-1) = tcount - INDTWR(idx(2,ii)-1,idx(1,ii)-1,idx(4,ii)-1,idx(3,ii)-1) = tcount - - INDTWR(idx(1,ii)-1,idx(2,ii)-1,idx(3,ii) ,idx(4,ii) ) = tcount - INDTWR(idx(2,ii)-1,idx(1,ii)-1,idx(3,ii) ,idx(4,ii) ) = tcount - INDTWR(idx(1,ii)-1,idx(2,ii)-1,idx(4,ii) ,idx(3,ii) ) = tcount - INDTWR(idx(2,ii)-1,idx(1,ii)-1,idx(4,ii) ,idx(3,ii) ) = tcount - - INDTWR(idx(1,ii) ,idx(2,ii) ,idx(3,ii)-1,idx(4,ii)-1) = tcount - INDTWR(idx(2,ii) ,idx(1,ii) ,idx(3,ii)-1,idx(4,ii)-1) = tcount - INDTWR(idx(1,ii) ,idx(2,ii) ,idx(4,ii)-1,idx(3,ii)-1) = tcount - INDTWR(idx(2,ii) ,idx(1,ii) ,idx(4,ii)-1,idx(3,ii)-1) = tcount - - - - - INDTWR(idx(3,ii) ,idx(4,ii) ,idx(1,ii) ,idx(2,ii) ) = tcount - INDTWR(idx(4,ii) ,idx(3,ii) ,idx(1,ii) ,idx(2,ii) ) = tcount - INDTWR(idx(3,ii) ,idx(4,ii) ,idx(2,ii) ,idx(1,ii) ) = tcount - INDTWR(idx(4,ii) ,idx(3,ii) ,idx(2,ii) ,idx(1,ii) ) = tcount - - INDTWR(idx(3,ii)-1,idx(4,ii)-1,idx(1,ii)-1,idx(2,ii)-1) = tcount - INDTWR(idx(3,ii)-1,idx(4,ii)-1,idx(2,ii)-1,idx(1,ii)-1) = tcount - INDTWR(idx(4,ii)-1,idx(3,ii)-1,idx(1,ii)-1,idx(2,ii)-1) = tcount - INDTWR(idx(4,ii)-1,idx(3,ii)-1,idx(2,ii)-1,idx(1,ii)-1) = tcount - - INDTWR(idx(3,ii) ,idx(4,ii) ,idx(1,ii)-1,idx(2,ii)-1) = tcount - INDTWR(idx(3,ii) ,idx(4,ii) ,idx(2,ii)-1,idx(1,ii)-1) = tcount - INDTWR(idx(4,ii) ,idx(3,ii) ,idx(1,ii)-1,idx(2,ii)-1) = tcount - INDTWR(idx(4,ii) ,idx(3,ii) ,idx(2,ii)-1,idx(1,ii)-1) = tcount - - INDTWR(idx(3,ii)-1,idx(4,ii)-1,idx(1,ii) ,idx(2,ii) ) = tcount - INDTWR(idx(3,ii)-1,idx(4,ii)-1,idx(2,ii) ,idx(1,ii) ) = tcount - INDTWR(idx(4,ii)-1,idx(3,ii)-1,idx(1,ii) ,idx(2,ii) ) = tcount - INDTWR(idx(4,ii)-1,idx(3,ii)-1,idx(2,ii) ,idx(1,ii) ) = tcount - End if - - End Do - - End do - - Read(nrint) wrtidx(:,1:redund) - Read(nrint) val(1:redund) - - Close(nrint) - - Do ii=1, redund - - Select case(intindx) - - Case (1) - idx(1,ii) = IBITS(wrtidx(1,ii),bitsize_integer*3/4,bitsize_integer/4) - idx(2,ii) = IBITS(wrtidx(1,ii),bitsize_integer*2/4,bitsize_integer/4) - idx(3,ii) = IBITS(wrtidx(1,ii),bitsize_integer*1/4,bitsize_integer/4) - idx(4,ii) = IBITS(wrtidx(1,ii),bitsize_integer*0/4,bitsize_integer/4) - - Case (2) - idx(1,ii) = IBITS(wrtidx(1,ii),bitsize_integer*1/2,bitsize_integer/2) - idx(2,ii) = IBITS(wrtidx(1,ii),bitsize_integer*0/2,bitsize_integer/2) - idx(3,ii) = IBITS(wrtidx(2,ii),bitsize_integer*1/2,bitsize_integer/2) - idx(4,ii) = IBITS(wrtidx(2,ii),bitsize_integer*0/2,bitsize_integer/2) - - Case (4) - idx(1,ii) = wrtidx(1,ii) - idx(2,ii) = wrtidx(2,ii) - idx(3,ii) = wrtidx(3,ii) - idx(4,ii) = wrtidx(4,ii) - - Case default - write(*,*) "[INPUT ERROR] @Int2_idx : out of select ( 1 / 2 / 4 )" - stop - - end Select - - idx(:,ii) = 2*idx(:,ii) - ncore - If ((idx(1,ii) > ninact+nact).and.(idx(2,ii) > ninact+nact).and. & - (idx(3,ii) > ninact+nact).and.(idx(4,ii) > ninact+nact)) then - Else -! write(*,*)idx(1:4,ii) - tcount = tcount + 1 - int2r(tcount) = val(ii) - - INDTWR(idx(1,ii) ,idx(2,ii) ,idx(3,ii) ,idx(4,ii) ) = tcount - INDTWR(idx(1,ii) ,idx(2,ii) ,idx(4,ii) ,idx(3,ii) ) = tcount - INDTWR(idx(2,ii) ,idx(1,ii) ,idx(3,ii) ,idx(4,ii) ) = tcount - INDTWR(idx(2,ii) ,idx(1,ii) ,idx(4,ii) ,idx(3,ii) ) = tcount - - INDTWR(idx(1,ii)-1,idx(2,ii)-1,idx(3,ii)-1,idx(4,ii)-1) = tcount - INDTWR(idx(2,ii)-1,idx(1,ii)-1,idx(3,ii)-1,idx(4,ii)-1) = tcount - INDTWR(idx(1,ii)-1,idx(2,ii)-1,idx(4,ii)-1,idx(3,ii)-1) = tcount - INDTWR(idx(2,ii)-1,idx(1,ii)-1,idx(4,ii)-1,idx(3,ii)-1) = tcount - - INDTWR(idx(1,ii)-1,idx(2,ii)-1,idx(3,ii) ,idx(4,ii) ) = tcount - INDTWR(idx(2,ii)-1,idx(1,ii)-1,idx(3,ii) ,idx(4,ii) ) = tcount - INDTWR(idx(1,ii)-1,idx(2,ii)-1,idx(4,ii) ,idx(3,ii) ) = tcount - INDTWR(idx(2,ii)-1,idx(1,ii)-1,idx(4,ii) ,idx(3,ii) ) = tcount - - INDTWR(idx(1,ii) ,idx(2,ii) ,idx(3,ii)-1,idx(4,ii)-1) = tcount - INDTWR(idx(2,ii) ,idx(1,ii) ,idx(3,ii)-1,idx(4,ii)-1) = tcount - INDTWR(idx(1,ii) ,idx(2,ii) ,idx(4,ii)-1,idx(3,ii)-1) = tcount - INDTWR(idx(2,ii) ,idx(1,ii) ,idx(4,ii)-1,idx(3,ii)-1) = tcount - - - - INDTWR(idx(3,ii) ,idx(4,ii) ,idx(1,ii) ,idx(2,ii) ) = tcount - INDTWR(idx(4,ii) ,idx(3,ii) ,idx(1,ii) ,idx(2,ii) ) = tcount - INDTWR(idx(3,ii) ,idx(4,ii) ,idx(2,ii) ,idx(1,ii) ) = tcount - INDTWR(idx(4,ii) ,idx(3,ii) ,idx(2,ii) ,idx(1,ii) ) = tcount - - INDTWR(idx(3,ii)-1,idx(4,ii)-1,idx(1,ii)-1,idx(2,ii)-1) = tcount - INDTWR(idx(3,ii)-1,idx(4,ii)-1,idx(2,ii)-1,idx(1,ii)-1) = tcount - INDTWR(idx(4,ii)-1,idx(3,ii)-1,idx(1,ii)-1,idx(2,ii)-1) = tcount - INDTWR(idx(4,ii)-1,idx(3,ii)-1,idx(2,ii)-1,idx(1,ii)-1) = tcount - - INDTWR(idx(3,ii) ,idx(4,ii) ,idx(1,ii)-1,idx(2,ii)-1) = tcount - INDTWR(idx(3,ii) ,idx(4,ii) ,idx(2,ii)-1,idx(1,ii)-1) = tcount - INDTWR(idx(4,ii) ,idx(3,ii) ,idx(1,ii)-1,idx(2,ii)-1) = tcount - INDTWR(idx(4,ii) ,idx(3,ii) ,idx(2,ii)-1,idx(1,ii)-1) = tcount - - INDTWR(idx(3,ii)-1,idx(4,ii)-1,idx(1,ii) ,idx(2,ii) ) = tcount - INDTWR(idx(3,ii)-1,idx(4,ii)-1,idx(2,ii) ,idx(1,ii) ) = tcount - INDTWR(idx(4,ii)-1,idx(3,ii)-1,idx(1,ii) ,idx(2,ii) ) = tcount - INDTWR(idx(4,ii)-1,idx(3,ii)-1,idx(2,ii) ,idx(1,ii) ) = tcount - End if - - End Do -! write(*,*)int2r(1:tcount) -! write(*,*)indtwr - write(*,*)'tcount',tcount - - deallocate(idx) - deallocate(val) - deallocate(wrtidx) - - -40 continue -50 continue - -end SUBROUTINE readint2_nr diff --git a/src/readint2_ord.f90 b/src/readint2_ord.f90 deleted file mode 100644 index e82f73a0..00000000 --- a/src/readint2_ord.f90 +++ /dev/null @@ -1,689 +0,0 @@ -! ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ - - SUBROUTINE readint2_ord (filename) ! 2 electorn integrals in MDCINT - -! ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ - - use four_caspt2_module - - Implicit NONE - - character*50,intent(in) :: filename - - character :: datex*10, timex*8 - -! integer :: mdcint, nkr, idum, nmom, max1, max2, min1, min2 - integer :: nkr, idum - integer :: mdcint, nmom, max1, max2, min1, min2 -! integer :: nz, type - integer :: nz - integer :: type - integer :: j0, i0, i1 - integer :: k0, l0, ii, jj, kk, ll, signind -! integer :: i, j, k, l, ikr, jkr, lkr, kkr - integer :: ikr, jkr, kkr, lkr - integer :: i, j, k, l - integer :: SignIJ, SignKL, itr, jtr, ltr, ktr, inz, totalint - -! integer, allocatable :: indk(:), indl(:), kr(:) - integer, allocatable :: indk(:), indl(:), kr(:) - -! real*8, allocatable :: rklr(:), rkli(:) - double precision, allocatable :: rklr(:), rkli(:) - - logical :: breit - -!Iwamuro modify - realonly = .false. - - Allocate(kr(-nmo/2:nmo/2)); Call memplus(KIND(kr),SIZE(kr),1) - - kr = 0 - - Allocate(indk((nmo/2)**2)); Call memplus(KIND(indk),SIZE(indk),1) - Allocate(indl((nmo/2)**2)); Call memplus(KIND(indl),SIZE(indl),1) - Allocate(rklr((nmo/2)**2)); Call memplus(KIND(rklr),SIZE(rklr),1) - Allocate(rkli((nmo/2)**2)); Call memplus(KIND(rkli),SIZE(rkli),1) - -! Allocate(indk(nmo**2)); Call memplus(KIND(indk),SIZE(indk),1) -! Allocate(indl(nmo**2)); Call memplus(KIND(indl),SIZE(indl),1) -! Allocate(rklr(nmo**2)); Call memplus(KIND(rklr),SIZE(rklr),1) -! Allocate(rkli(nmo**2)); Call memplus(KIND(rkli),SIZE(rkli),1) - - write(*,'("Current Memory is ",F10.2,"MB")')tmem/1024/1024 - - indk(:) = 0 - indl(:) = 0 - rklr(:) = 0.0d+00 - rkli(:) = 0.0d+00 - - totalint = 0 - - open( 11, file='A1int',form ='unformatted', status='unknown') - open( 12, file='A2int',form ='unformatted', status='unknown') - open( 2 , file='Bint' ,form ='unformatted', status='unknown') - open( 31, file='C1int',form ='unformatted', status='unknown') - open( 32, file='C2int',form ='unformatted', status='unknown') - open( 33, file='C3int',form ='unformatted', status='unknown') - open( 4 , file='D1int',form ='unformatted', status='unknown') - open( 41, file='D2int',form ='unformatted', status='unknown') - open( 42, file='D3int',form ='unformatted', status='unknown') - open( 5 , file='Eint' ,form ='unformatted', status='unknown') - open( 9 , file='Fint' ,form ='unformatted', status='unknown') - open( 7 , file='Gint' ,form ='unformatted', status='unknown') - open( 8 , file='Hint' ,form ='unformatted', status='unknown') - - - mdcint=15 - -! Iwamuro modify - open( mdcint, file=trim(filename),form ='unformatted', status='old', err=10) - -!old Read (mdcint,err=20,end=30) datex,timex,nkr, & -!old (idum,i0=1,4*nkr),(kr(i0),kr(-1*i0),i0=1,nkr) - Read (mdcint,err=20,end=30) datex,timex,nkr, & - (kr(i0),kr(-1*i0),i0=1,nkr) - - write(*,*) datex,timex - write(*,*) 'nkr',nkr,'kr(+),kr(-)', (kr(i0),kr(-1*i0),i0=1,nkr) - - read (mdcint,ERR=200,END=50) ikr,jkr,nz, & - (indk(inz),indl(inz),inz=1,nz), & - (rklr(inz),rkli(inz),inz=1,nz) - - goto 201 - - 200 realonly = .true. - write(*,*) "realonly=", realonly - 201 close(mdcint) - - open( mdcint, file=trim(filename),form ='unformatted', status='old', err=10) - -!old Read (mdcint,err=20,end=30) datex,timex,nkr, & -!old (idum,i0=1,4*nkr),(kr(i0),kr(-1*i0),i0=1,nkr) - Read (mdcint,err=20,end=30) datex,timex,nkr, & - (kr(i0),kr(-1*i0),i0=1,nkr) - - write(*,*) datex,timex - write(*,*) 'nkr',nkr,'kr(+),kr(-)', (kr(i0),kr(-1*i0),i0=1,nkr) - - 60 if (realonly) then - read (mdcint,ERR=40,END=50) ikr,jkr,nz, & - (indk(inz),indl(inz),inz=1,nz), & - (rklr(inz), inz=1,nz) - rkli = 0.0d+00 - else - read (mdcint,ERR=43,END=50) ikr,jkr,nz, & - (indk(inz),indl(inz),inz=1,nz), & - (rklr(inz), rkli(inz), inz=1,nz) - endif - -! open(25, file=trim(filename),form ='formatted', status='old', err=10) - -! read(25,'(3I4)')ikr,jkr, nz -! read(25,'(4E20.5)')indk(inz),indl(inz),rklr(inz),rkli(inz) - -! write(*,*) 'MDCINT int' - -! do inz=1,nz -! write(25,'(3I4)') ikr,jkr, nz -! write(25,'(4E20.5)') indk(inz),indl(inz),rklr(inz),rkli(inz) -! enddo - -!Iwamuro modify -! write(*,*)'Iwamuro modify' -! write(*,*) ikr, jkr, kkr, lkr -! write(*,*)(rklr(inz), inz=1,nz) -! write(*,'(4I4, E15.5)') ikr, jkr, kkr, lkr, (rklr(inz), inz=1,nz) - - - -! write(*,*) ikr,jkr,nz, & -! (indk(inz),indl(inz),inz=1,nz), & -! (rklr(inz),rkli(inz),inz=1,nz) - - if (ikr==0) goto 50 - - totalint = totalint + nz - -! i = indmor(kr(ikr)) -! itr = indmor(kr(-ikr)) -! j = indmor(kr(jkr)) -! jtr = indmor(kr(-jkr)) -!Iwamuro modify - i = indmor(kr(ikr)) - itr = indmor(kr(-ikr)) - j = indmor(kr(jkr)) - jtr = indmor(kr(-jkr)) - - nmom = ninact + nact + nsec - - If(sp(i)==4 .or. sp(j) == 4) goto 60 - If(i > ninact+nact .and. j > ninact+nact) goto 60 - -! SignIJ = SIGN(1,ikr) * SIGN(1,jkr) -!Iwamuro modify - SignIJ = (-1)**(mod(i+j,2)) - - Do inz = 1, nz - - -! kkr = indk(inz) -! k = indmor(kr(kkr)) -! ktr = indmor(kr(-kkr)) -! lkr = indl(inz) -! l = indmor(kr(lkr)) -! ltr = indmor(kr(-lkr)) -!Iwamuro modify - kkr = indk(inz) - k = indmor(kr(kkr)) - ktr = indmor(kr(-kkr)) - lkr = indl(inz) - l = indmor(kr(lkr)) - ltr = indmor(kr(-lkr)) - -! write(*,'("all ints",4I4,E20.10)')i,j,k,l,rklr(inz) - - If(sp(k)==4 .or. sp(l) == 4) goto 70 - If(k > ninact+nact .and. l > ninact+nact) goto 70 - If(i==j .and. k > l) goto 70 - If(abs(rklr(inz)) <= 1.0d-12)go to 70 - -! SignKL = SIGN(1,kkr) * SIGN(1,lkr) -!Iwmauro modify - SignKL = (-1)**(mod(k+l,2)) - - max1 = max(sp(i), sp(j)) - min1 = min(sp(i), sp(j)) - max2 = max(sp(k), sp(l)) - min2 = min(sp(k), sp(l)) - -!=============================================================== -! Integrals for A space (pi|qr)(21|22) (pi|jk)(21|11) type -!=============================================================== - - If(max1==2 .and. min1==2 .and. max2==2 .and. min2==1) then ! (22|21) => (21|22) -! write(*,'(4I4,2E20.10)')i,j,k,l, rklr(inz), rkli(inz) - - if(k > l) then ! (22|21) => (21|22) - - write(11)k ,l ,i ,j , rklr(inz), rkli(inz) - write(*,'("A1int1",4I4,2E20.10)')k ,l ,i ,j , rklr(inz), rkli(inz) - - else ! (22|12) => (22|21)* => (21|22)* - - write(11)l ,k ,j ,i , rklr(inz), -1.0d+00*rkli(inz) - write(*,'("A1int2",4I4,2E20.10)')l ,k ,j ,i , rklr(inz), -1.0d+00*rkli(inz) - - endif - - elseif(max1==2 .and. min1==1 .and. max2==2 .and. min2==2) then ! (21|22) => (21|22) - -! write(*,'(4I4,2E20.10)')i,j,k,l, rklr(inz), rkli(inz) - - if(i > j) then ! (21|22) => (21|22) - - write(11)i ,j ,k ,l , rklr(inz), rkli(inz) - write(*,'("A1int3",4I4,2E20.10)')i ,j ,k ,l , rklr(inz), rkli(inz) - - else ! (12|22) => (21|22)* - - write(11)j ,i ,l ,k , rklr(inz),-1.0d+00*rkli(inz) - write(*,'("A1int4",4I4,2E20.10)')j ,i ,l ,k , rklr(inz),-1.0d+00*rkli(inz) - - endif - - elseif(max1==2 .and. min1==1 .and. max2==1 .and. min2==1) then ! (21|11)=>(21|11) -! write(*,'(4I4,2E20.10)')i,j,k,l, rklr(inz), rkli(inz) - - if(i > j) then ! (21|11) => (21|11) - - write(12)i ,j ,k ,l , rklr(inz), rkli(inz) - write(*,'("A2int1",4I4,2E20.10)')i ,j ,k ,l , rklr(inz), rkli(inz) - - else ! (12|11) => (21|11)* => (21|11)* - - write(12)j ,i ,l ,k , rklr(inz), -1.0d+00*rkli(inz) - write(*,'("A2int2",4I4,2E20.10)')j ,i ,l ,k , rklr(inz), -1.0d+00*rkli(inz) - - endif - - elseif(max1==1 .and. min1==1 .and. max2==2 .and. min2==1) then ! (11|21)=>(21|11) -! write(*,'(4I4,2E20.10)')i,j,k,l, rklr(inz), rkli(inz) - - if(k > l) then ! (11|21) => (21|11) - - write(12)k ,l ,i ,j , rklr(inz), rkli(inz) - write(*,'("A2int3",4I4,2E20.10)')k ,l ,i ,j , rklr(inz), rkli(inz) - - else ! (11|12) => (11|21)* => (21|11)* - - write(12)l ,k ,j ,i , rklr(inz), -1.0d+00*rkli(inz) - write(*,'("A2int4",4I4,2E20.10)')l ,k ,j ,i , rklr(inz), -1.0d+00*rkli(inz) - - endif - - -!============================================= -! Integrals for B space (pi|qj) (21|21) type -!============================================= - - - elseif(max1==2 .and. min1==1 .and. max2==2 .and. min2==1) then ! (21|21)=>(21|21) - - if(i > j .and. k > l) then ! (21|21) => (21|21) - - write(2)i ,j ,k ,l , rklr(inz), rkli(inz) - - elseif(i < j .and. k > l) then ! (12|21) => (21|21) - - write(2)jtr,itr,k ,l , SignIJ*rklr(inz), SignIJ*rkli(inz) - - elseif(i > j .and. k < l) then ! (21|12) => (21|21) - - write(2)i ,j ,ltr,ktr, SignKL*rklr(inz), SignKL*rkli(inz) - - elseif(i < j .and. k < l) then ! (12|12) => (21|21)* - - write(2)jtr,itr,ltr,ktr,SignIJ*SignKL*rklr(inz),SignIJ*SignKL*rkli(inz) - - endif - - -!============================================================================ -! Integrals for C space (ap|qr)(32|22) type C1int -!============================================================================ - - - elseif(max1==3 .and. min1==2 .and. max2==2 .and. min2==2) then ! (32|22)=>(32|22) - - if(i > j) then ! (32|22)=>(32|22) - - write(31)i ,j ,k ,l , rklr(inz), rkli(inz) -!Iwamuro modify - write(*,'("C1int1",4I4,2E20.10)')i ,j ,k ,l , rklr(inz), rkli(inz) - else ! (23|22)=>(32|22) - - write(31)jtr,itr,k ,l , SignIJ*rklr(inz), SignIJ*rkli(inz) -!Iwamuro modify - write(*,'("C1int2",4I4,2E20.10)')jtr,itr,k ,l , SignIJ*rklr(inz), SignIJ*rkli(inz) - endif - - elseif(max1==2 .and. min1==2 .and. max2==3 .and. min2==2) then ! (22|32)=>(32|22) - - if(k > l) then ! (22|32)=>(32|22) - - write(31)k ,l ,i ,j , rklr(inz), rkli(inz) -!Iwamuro modify - write(*,'("C1int3",4I4,2E20.10)')k ,l ,i ,j , rklr(inz), rkli(inz) - else ! (22|23)=>(32|22) - - write(31)ltr,ktr,i ,j , SignKL*rklr(inz), SignKL*rkli(inz) -!Iwamuro modify - write(*,'("C1int4",4I4,2E20.10)')ltr,ktr,i ,j , SignKL*rklr(inz), SignKL*rkli(inz) - endif - -!============================================================================ -! Integrals for C space (ap|kk)(32|11) type C2int -!============================================================================ - - - elseif(max1==3 .and. min1==2 .and. max2==1 .and. min2==1)then ! (32|11)=>(32|11) - - if(i > j) then ! (32|11)=>(32|11) - - write(32)i ,j ,k ,l , rklr(inz), rkli(inz) - - else ! (23|11)=>(32|11) - - write(32)jtr,itr,k ,l , SignIJ*rklr(inz), SignIJ*rkli(inz) - - endif - - elseif(max1==1 .and. min1==1 .and. max2==3 .and. min2==2)then ! (32|11)=>(32|11) - - if(k > l) then ! (11|32)=>(32|11) - - write(32)k ,l ,i ,j , rklr(inz), rkli(inz) - - else ! (11|23)=>(32|11) - - write(32)ltr,ktr,i ,j , SignKL*rklr(inz), SignKL*rkli(inz) - - endif - -!============================================================================ -! Integrals for C (ai|jp) (31|12)(C3int) and E space (ai|pj)(31|21) (Eint) -!============================================================================ - - - elseif(max1==3 .and. min1==1 .and. max2==2 .and. min2==1) then ! (31|21)=>(31|12) - - if (i > j .and. l > k) then ! (31|12)=>(31|21) For E - write(5 )i ,j ,ltr,ktr, SignKL*rklr(inz), SignKL*rkli(inz) - write(33)i ,j ,k ,l , rklr(inz), rkli(inz) - - elseif(j > i .and. l > k ) then ! (13|12)=>(31|21) For E - write(5 )jtr,itr,ltr,ktr, SignIJ*SignKL*rklr(inz), SignIJ*SignKL*rkli(inz) - write(33)jtr,itr,k ,l , SignIJ*rklr(inz), SignIJ*rkli(inz) - - elseif(i > j .and. k > l ) then ! (31|21)=>(31|21) For E - write(5 )i ,j ,k ,l , rklr(inz), rkli(inz) - write(33)i ,j ,ltr,ktr, SignKL*rklr(inz), SignKL*rkli(inz) - - elseif(i < j .and. k > l ) then ! (13|21)=>(31|21) For E - write(5 )jtr,itr,k ,l , SignIJ*rklr(inz), SignIJ*rkli(inz) - write(33)jtr,itr,ltr,ktr, SignIJ*SignKL*rklr(inz), SignIJ*SignKL*rkli(inz) - - endif - - - elseif(max1==2 .and. min1==1 .and. max2==3 .and. min2==1) then ! (21|31)=>(31|12) - - if (i > j .and. l > k ) then ! (21|13)=>(31|21) For E - write(5 )ltr,ktr,i ,j , SignKL*rklr(inz), SignKL*rkli(inz) - write(33)ltr,ktr,jtr,itr, SignIJ*SignKL*rklr(inz), SignIJ*SignKL*rkli(inz) - - elseif(j > i .and. l > k ) then ! (12|13)=>(31|21) For E - write(5 )ltr,ktr,jtr,itr, SignIJ*SignKL*rklr(inz), SignIJ*SignKL*rkli(inz) - write(33)ltr,ktr,i ,j , SignKL*rklr(inz), SignKL*rkli(inz) - - elseif(i > j .and. k > l) then ! (21|31)=>(31|21) For E - write(5 )k ,l ,i ,j , rklr(inz), rkli(inz) - write(33)k ,l ,jtr,itr, SignIJ*rklr(inz), SignIJ*rkli(inz) - - elseif(i < j .and. k > l) then ! (12|31)=>(31|21) For E - write(5 )k ,l ,jtr,itr, SignIJ*rklr(inz), SignIJ*rkli(inz) - write(33)k ,l ,i ,j , rklr(inz), rkli(inz) - - endif - - -!============================================================================ -! Integrals for D space (ai|pq)(31|22) type (D1int) -!============================================================================ - - - elseif(max1==3 .and. min1==1 .and. max2==2 .and. min2==2) then ! (31|22)=>(31|22) -! write(*,'(4I4,4E20.10)')ikr,jkr,kkr,lkr, rklr(inz), rkli(inz) - - if(i > j) then ! (31|22)=>(31|22) - - write(4)i ,j ,k ,l , rklr(inz), rkli(inz) -! write(*,'(4I4,4E20.10)')i ,j ,k ,l , rklr(inz), rkli(inz) - - else ! (13|22)=>(31|22) - - write(4)jtr,itr,k ,l , SignIJ*rklr(inz), SignIJ*rkli(inz) -! write(*,'(4I4,4E20.10)')jtr,itr,k ,l , SignIJ*rklr(inz), SignIJ*rkli(inz) - - endif - - elseif(max1==2 .and. min1==2 .and. max2==3 .and. min2==1) then ! (22|31)=>(31|22) - -! write(*,'(4I4,4E20.10)')ikr,jkr,kkr,lkr, rklr(inz), rkli(inz) - - if(k > l) then ! (22|31)=>(31|22) - - write(4)k ,l ,i ,j , rklr(inz), rkli(inz) -! write(*,'(4I4,4E20.10)')k ,l ,i ,j , rklr(inz), rkli(inz) - - else ! (22|13)=>(31|22) - - write(4)ltr,ktr,i ,j , SignKL*rklr(inz), SignKL*rkli(inz) -! write(*,'(4I4,4E20.10)')ltr,ktr,i ,j , SignKL*rklr(inz), SignKL*rkli(inz) - - endif - - -!============================================================================ -! Integrals for D space (ap|qi)(32|21) type (D2int) -!============================================================================ - - - elseif(max1==3 .and. min1==2 .and. max2==2 .and. min2==1) then ! (32|21)=>(32|21) - - if(i > j .and. k > l) then ! (32|21)=>(32|21) - - write(41)i ,j ,k ,l , rklr(inz), rkli(inz) - - elseif(i < j .and. k > l) then ! (23|21)=>(32|21) - - write(41)jtr,itr,k ,l , SignIJ*rklr(inz), SignIJ*rkli(inz) - - elseif(i > j .and. k < l) then ! (32|12)=>(32|21) - - write(41)i ,j ,ltr,ktr, SignKL*rklr(inz), SignKL*rkli(inz) - - elseif(i < j .and. k < l) then ! (23|12)=>(32|21) - - write(41)jtr,itr,ltr,ktr, SignIJ*SignKL*rklr(inz), SignIJ*SignKL*rkli(inz) - - endif - - elseif(max1==2 .and. min1==1 .and. max2==3 .and. min2==2) then ! (21|32)=>(32|21) - - if(i > j .and. k > l) then ! (21|32)=>(32|21) - - write(41)k ,l ,i ,j , rklr(inz), rkli(inz) - - elseif(i < j .and. k > l) then ! (12|32)=>(32|21) - - write(41)k ,l ,jtr,itr, SignIJ*rklr(inz), SignIJ*rkli(inz) - - elseif(i > j .and. k < l) then ! (21|23)=>(32|21) - - write(41)ltr,ktr,i ,j , SignKL*rklr(inz), SignKL*rkli(inz) - - elseif(i < j .and. k < l) then ! (12|23)=>(32|21) - - write(41)ltr,ktr,jtr,itr, SignIJ*SignKL*rklr(inz), SignIJ*SignKL*rkli(inz) - - endif - - -!============================================================================ -! Integrals for D space (ai|jk) (31|11) type (D3int) -!============================================================================ - - elseif(max1==3 .and. min1==1 .and. max2==1 .and. min2==1) then ! (31|11)=>(31|11) - - if(i > j) then ! (ai|jk) (31|11)=>(31|11) - - write(42) i ,j ,k ,l , rklr(inz), rkli(inz) - - else ! (i~a~|kk) (13|11)=>(31|11) - - write(42)jtr,itr,k ,l , SignIJ*rklr(inz), SignIJ*rkli(inz) - - endif - - elseif(max1==1 .and. min1==1 .and. max2==3 .and. min2==1) then ! (11|31)=>(31|11) - - if(k > l) then ! (jk|ai) (31|11)=>(31|11) - - write(42) k ,l ,i ,j , rklr(inz), rkli(inz) - - else ! (jk|i~a~)=>( ai|kk) (11|13)=>(31|11) - - write(42) ltr,ktr,i ,j , SignKL*rklr(inz), SignKL*rkli(inz) - - endif - - -!============================================= -! Integrals for F space (ap|bq) (32|32) type -!============================================= - - - elseif(max1==3 .and. min1==2 .and. max2==3 .and. min2==2) then ! (32|32)=>(32|32) - - if(i > j .and. k > l) then ! (32|32) => (32|32) - - write(9)i ,j ,k ,l , rklr(inz), rkli(inz) - - elseif(i < j .and. k > l) then ! (23|32) => (32|32) - - write(9)jtr,itr,k ,l , SignIJ*rklr(inz), SignIJ*rkli(inz) - - elseif(i > j .and. k < l) then ! (32|23) => (32|32) - - write(9)i ,j ,ltr,ktr, SignKL*rklr(inz), SignKL*rkli(inz) - - elseif(i < j .and. k < l) then ! (23|23) => (32|32) - - write(9)jtr,itr,ltr,ktr,SignIJ*SignKL*rklr(inz),SignIJ*SignKL*rkli(inz) - - endif - - -!============================================================================ -! G space (ai|bp)(31|32) type -!============================================================================ - - - elseif(max1==3 .and. min1==1 .and. max2==3 .and. min2==2) then ! (31|32)=>(31|32) - - if (i > j .and. l > k) then ! (31|23)=>(31|32) - write(7)i ,j ,ltr,ktr, SignKL*rklr(inz), SignKL*rkli(inz) - write(*,'("Gint1",4I4,2E20.10)')i ,j ,ltr,ktr, SignKL*rklr(inz), SignKL*rkli(inz) - -! elseif(j > i .and. l > k ) then ! (13|23)=>(31|32) - elseif(j > i .and. l > k .and. abs(rklr(inz)) >= 1.0d-12) then ! (13|23)=>(31|32) - write(7)jtr,itr,ltr,ktr, SignIJ*SignKL*rklr(inz), SignIJ*SignKL*rkli(inz) - write(*,'("Gint2",4I4,2E20.10)')jtr,itr,ltr,ktr, SignIJ*SignKL*rklr(inz), SignIJ*SignKL*rkli(inz) - - elseif(i > j .and. k > l ) then ! (31|32)=>(31|32) - write(7)i ,j ,k ,l , rklr(inz), rkli(inz) - write(*,'("Gint3",4I4,2E20.10)')i ,j ,k ,l , rklr(inz), rkli(inz) - -! elseif(i < j .and. k > l ) then ! (13|32)=>(31|32) - elseif(i < j .and. k > l .and. abs(rklr(inz)) >= 1.0d-12) then ! (13|32)=>(31|32) - write(7)jtr,itr,k ,l , SignIJ*rklr(inz), SignIJ*rkli(inz) - write(*,'("Gint4",4I4,2E20.10)')jtr,itr,k ,l , SignIJ*rklr(inz), SignIJ*rkli(inz) - - endif - - - elseif(max1==3 .and. min1==2 .and. max2==3 .and. min2==1) then ! (32|31)=>(31|32) - - if (i > j .and. l > k ) then ! (32|13)=>(31|32) - write(7)ltr,ktr,i ,j , SignKL*rklr(inz), SignKL*rkli(inz) - write(*,'("Gint5",4I4,2E20.10)')ltr,ktr,i ,j , SignKL*rklr(inz), SignKL*rkli(inz) - - elseif(j > i .and. l > k ) then ! (23|13)=>(31|32) - write(7)ltr,ktr,jtr,itr, SignIJ*SignKL*rklr(inz), SignIJ*SignKL*rkli(inz) - write(*,'("Gint6",4I4,2E20.10)')ltr,ktr,jtr,itr, SignIJ*SignKL*rklr(inz), SignIJ*SignKL*rkli(inz) - - elseif(i > j .and. k > l) then ! (32|31)=>(31|32) - write(7)k ,l ,i ,j , rklr(inz), rkli(inz) - write(*,'("Gint7",4I4,2E20.10)')k ,l ,i ,j , rklr(inz), rkli(inz) - - elseif(i < j .and. k > l) then ! (23|31)=>(31|32) - write(7)k ,l ,jtr,itr, SignIJ*rklr(inz), SignIJ*rkli(inz) - write(*,'("Gint8",4I4,2E20.10)')k ,l ,jtr,itr, SignIJ*rklr(inz), SignIJ*rkli(inz) - - endif - -!============================================= -! Integrals for H space (ai|bj) (31|31) type -!============================================= - - - elseif(max1==3 .and. min1==1 .and. max2==3 .and. min2==1) then ! (31|31)=>(31|31) - - if(i > j .and. k > l) then ! (31|31) => (31|31) - - write(8)i ,j ,k ,l , rklr(inz), rkli(inz) - write(*,'("Hint1",4I4,2E20.10)')i ,j ,k ,l , rklr(inz), rkli(inz) -! write(*,*)i ,j ,k ,l , rklr(inz), rkli(inz) - - elseif(i < j .and. k > l) then ! (13|31) => (31|31) - - write(8)jtr,itr,k ,l , SignIJ*rklr(inz), SignIJ*rkli(inz) - write(*,'("Hint2",4I4,2E20.10)')jtr,itr,k ,l , SignIJ*rklr(inz), SignIJ*rkli(inz) -! write(*,*)jtr,itr,k ,l , SignIJ*rklr(inz), SignIJ*rkli(inz) - - elseif(i > j .and. k < l) then ! (31|13) => (31|31) - - write(8)i ,j ,ltr,ktr, SignKL*rklr(inz), SignKL*rkli(inz) - write(*,'("Hint3",4I4,2E20.10)')i ,j ,ltr,ktr, SignKL*rklr(inz), SignKL*rkli(inz) -! write(*,*)i ,j ,ltr,ktr, SignKL*rklr(inz), SignKL*rkli(inz) - - elseif(i < j .and. k < l) then ! (13|13) => (31|31) - - write(8)jtr,itr,ltr,ktr,SignIJ*SignKL*rklr(inz),SignIJ*SignKL*rkli(inz) - write(*,'("Hint4",4I4,2E20.10)')jtr,itr,ltr,ktr,SignIJ*SignKL*rklr(inz),SignIJ*SignKL*rkli(inz) -! write(*,*)jtr,itr,ltr,ktr,SignIJ*SignKL*rklr(inz),SignIJ*SignKL*rkli(inz) - - endif - - endif - -! if(abs(rkli(inz)) > thres) realc = .false. - - 70 Enddo - - indk(:)=0 - indl(:)=0 - rklr = 0.0d+00 - rkli = 0.0d+00 - - Goto 60 - - - - - 10 write(*,*)'error for opening mdcint 10' - go to 100 - 20 write(*,*)'error for reading mdcint 20' - go to 100 - 30 write(*,*)'end mdcint 30' - go to 100 - 40 write(*,*)'error for reading mdcint 40' - go to 100 - 43 write(*,*)'error for reading mdcint 43' - go to 100 - 50 write(*,*)'end mdcint 50 normal' - go to 100 - - 100 continue - - close (mdcint) - -! write(11) 0, 0, 0, 0, 0.0d+00, 0.0d+00 -! write(12) 0, 0, 0, 0, 0.0d+00, 0.0d+00 -! write(2 ) 0, 0, 0, 0, 0.0d+00, 0.0d+00 -! write(31) 0, 0, 0, 0, 0.0d+00, 0.0d+00 -! write(32) 0, 0, 0, 0, 0.0d+00, 0.0d+00 -! write(33) 0, 0, 0, 0, 0.0d+00, 0.0d+00 -! write(4 ) 0, 0, 0, 0, 0.0d+00, 0.0d+00 -! write(41) 0, 0, 0, 0, 0.0d+00, 0.0d+00 -! write(42) 0, 0, 0, 0, 0.0d+00, 0.0d+00 -! write(5 ) 0, 0, 0, 0, 0.0d+00, 0.0d+00 -! write(9 ) 0, 0, 0, 0, 0.0d+00, 0.0d+00 -! write(7 ) 0, 0, 0, 0, 0.0d+00, 0.0d+00 -! write(8 ) 0, 0, 0, 0, 0.0d+00, 0.0d+00 - - close (11) - close (12) - close (2 ) - close (31) - close (32) - close (33) - close (4 ) - close (41) - close (42) - close (5 ) - close (9 ) - close (7 ) - close (8 ) - - deallocate (indk); Call memminus(KIND(indk),SIZE(indk),1) - deallocate (indl); Call memminus(KIND(indl),SIZE(indl),1) - deallocate (rklr); Call memminus(KIND(rklr),SIZE(rklr),1) - deallocate (rkli); Call memminus(KIND(rkli),SIZE(rkli),1) - deallocate (kr ); Call memminus(KIND(kr ),SIZE(kr ),1) - - end subroutine readint2_ord - diff --git a/src/readint2_ord_co.f90 b/src/readint2_ord_co.f90 index 21e1a82e..5424468a 100644 --- a/src/readint2_ord_co.f90 +++ b/src/readint2_ord_co.f90 @@ -5,13 +5,15 @@ SUBROUTINE readint2_ord_co(filename) ! 2 electorn integrals created by typart in ! ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ use four_caspt2_module + use module_file_manager Implicit NONE character*50, intent(in) :: filename + logical :: is_end_of_file character :: datex*10, timex*8 - integer :: mdcint, nkr, nmom, max1, max2, min1, min2 + integer :: mdcint_unit, nkr, nmom, max1, max2, min1, min2 integer :: nz integer :: i0, i, j, k, l integer :: SignIJ, SignKL, itr, jtr, ltr, ktr, inz, totalint @@ -28,10 +30,10 @@ SUBROUTINE readint2_ord_co(filename) ! 2 electorn integrals created by typart in !Iwamuro modify ! integer :: ikr, jkr, kkr, lkr ! Initialization of Unit numbers for subspace files - unit_a1 = 100; unit_a2 = 200; unit_b = 300 - unit_c1 = 400; unit_c2 = 500; unit_c3 = 600 - unit_d1 = 700; unit_d2 = 800; unit_d3 = 900 - unit_e = 1000; unit_f = 1100; unit_g = 1200; unit_h = 1300 + unit_a1 = default_unit; unit_a2 = default_unit; unit_b = default_unit + unit_c1 = default_unit; unit_c2 = default_unit; unit_c3 = default_unit + unit_d1 = default_unit; unit_d2 = default_unit; unit_d3 = default_unit + unit_e = default_unit; unit_f = default_unit; unit_g = default_unit; unit_h = default_unit a1_cnt = 0; a2_cnt = 0; b_cnt = 0; c1_cnt = 0; c2_cnt = 0; c3_cnt = 0 d1_cnt = 0; d2_cnt = 0; d3_cnt = 0; e_cnt = 0; f_cnt = 0; g_cnt = 0; h_cnt = 0 Allocate (kr(-nmo/2:nmo/2)); Call memplus(KIND(kr), SIZE(kr), 1) @@ -52,45 +54,29 @@ SUBROUTINE readint2_ord_co(filename) ! 2 electorn integrals created by typart in totalint = 0 - open (unit_a1, file=a1int, form='unformatted', status='replace') - open (unit_a2, file=a2int, form='unformatted', status='replace') - open (unit_b, file=bint, form='unformatted', status='replace') - open (unit_c1, file=c1int, form='unformatted', status='replace') - open (unit_c2, file=c2int, form='unformatted', status='replace') - open (unit_c3, file=c3int, form='unformatted', status='replace') - open (unit_d1, file=d1int, form='unformatted', status='replace') - open (unit_d2, file=d2int, form='unformatted', status='replace') - open (unit_d3, file=d3int, form='unformatted', status='replace') - open (unit_e, file=eint, form='unformatted', status='replace') - open (unit_f, file=fint, form='unformatted', status='replace') - open (unit_g, file=gint, form='unformatted', status='replace') - open (unit_h, file=hint, form='unformatted', status='replace') - - mdcint = 1500 - - open (mdcint, file=trim(filename), form='unformatted', status='old', iostat=iostat) - - ! Check the status of the file - if (iostat /= 0) then - ! If iostat is not equal to 0, error detected in opening the file, so stop the program - print *, 'ERROR: Failed to open '//trim(filename)//" , rank:", rank - print *, 'Stop the program' - stop - end if - - Read (mdcint, iostat=iostat) datex, timex, nkr, & + call open_unformatted_file(unit=unit_a1, file=a1int, status='replace', optional_action='write') + call open_unformatted_file(unit=unit_a2, file=a2int, status='replace', optional_action='write') + call open_unformatted_file(unit=unit_b, file=bint, status='replace', optional_action='write') + call open_unformatted_file(unit=unit_c1, file=c1int, status='replace', optional_action='write') + call open_unformatted_file(unit=unit_c2, file=c2int, status='replace', optional_action='write') + call open_unformatted_file(unit=unit_c3, file=c3int, status='replace', optional_action='write') + call open_unformatted_file(unit=unit_d1, file=d1int, status='replace', optional_action='write') + call open_unformatted_file(unit=unit_d2, file=d2int, status='replace', optional_action='write') + call open_unformatted_file(unit=unit_d3, file=d3int, status='replace', optional_action='write') + call open_unformatted_file(unit=unit_e, file=eint, status='replace', optional_action='write') + call open_unformatted_file(unit=unit_f, file=fint, status='replace', optional_action='write') + call open_unformatted_file(unit=unit_g, file=gint, status='replace', optional_action='write') + call open_unformatted_file(unit=unit_h, file=hint, status='replace', optional_action='write') + + mdcint_unit = default_unit + call open_unformatted_file(unit=mdcint_unit, file=trim(filename), status='old', optional_action='read') + + Read (mdcint_unit, iostat=iostat) datex, timex, nkr, & (kr(i0), kr(-1*i0), i0=1, nkr) - ! Check the status of the file - if (iostat < 0) then - ! End of the file is reached. Return to the main program. - print *, 'End of the file is reached '//trim(filename)//" , rank:", rank - print *, 'Return to the main program.' - return - elseif (iostat > 0) then - ! If iostat is greater than 0, error detected in the input file, so exit the program - print *, "Error : Error in reading file ", trim(filename) - stop + call check_iostat(iostat=iostat, file=trim(filename), end_of_file_reached=is_end_of_file) + if (is_end_of_file) then + return ! Return to main program end if if (rank == 0) then @@ -100,17 +86,10 @@ SUBROUTINE readint2_ord_co(filename) ! 2 electorn integrals created by typart in ! Continue to read the file until the end of the file is reached do - read (mdcint, iostat=iostat) i, j, nz, & - (indk(inz), indl(inz), inz=1, nz), & - (rklr(inz), rkli(inz), inz=1, nz) - ! Exit the loop if the end of the file is reached - if (iostat < 0) then - if (rank == 0) print *, 'End of '//trim(filename) + read (mdcint_unit, iostat=iostat) i, j, nz, (indk(inz), indl(inz), inz=1, nz), (rklr(inz), rkli(inz), inz=1, nz) + call check_iostat(iostat=iostat, file=trim(filename), end_of_file_reached=is_end_of_file) + if (is_end_of_file) then exit - elseif (iostat > 0) then - ! If iostat is greater than 0, error detected in the input file, so exit the program - print *, "Error : Error in reading file ", trim(filename) - stop end if if (i == 0 .and. j == 0 .and. nz == 0) exit ! End of the file is reached, exit read loop @@ -891,12 +870,7 @@ SUBROUTINE readint2_ord_co(filename) ! 2 electorn integrals created by typart in end do ! Next inz end do ! Continue to read 2-integrals -10 if (rank == 0) print *, 'error for opening mdcint 10' - go to 100 - -100 continue - - close (mdcint) + close (mdcint_unit) close (unit_a1) close (unit_a2) close (unit_b) diff --git a/src/readint2_ty.f90 b/src/readint2_ty.f90 deleted file mode 100644 index 1c4e18bf..00000000 --- a/src/readint2_ty.f90 +++ /dev/null @@ -1,182 +0,0 @@ -! ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ - -SUBROUTINE readint2_ty(filename, nuniq) ! 2 electorn integrals created by typart in utchem - -! ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ - - use four_caspt2_module - - Implicit NONE - - character*50, intent(in) :: filename - - character :: datex*10, timex*8 - - integer :: mdcint, nkr, idum, nuniq, nmom - integer :: nz, type - integer :: j0, i0, i1 - integer :: k0, l0, ii, jj, kk, ll, signind - integer :: i, j, k, l, ikr, jkr, lkr, kkr - integer :: SignIJ, SignKL, itr, jtr, ltr, ktr, inz, totalint - - integer, allocatable :: indk(:), indl(:), kr(:) - - real*8, allocatable :: rklr(:), rkli(:), int2rs(:), int2is(:) - - logical :: breit - - Allocate (int2rs(0:nmo**4)); Call memplus(KIND(int2rs), SIZE(int2rs), 1) - Allocate (int2is(0:nmo**4)); Call memplus(KIND(int2is), SIZE(int2is), 1) - - Allocate (kr(-nmo/2:nmo/2)); Call memplus(KIND(kr), SIZE(kr), 1) - Allocate (indtwr(nmo, nmo, nmo, nmo)); Call memplus(KIND(indtwr), SIZE(indtwr), 1) - Allocate (indtwi(nmo, nmo, nmo, nmo)); Call memplus(KIND(indtwi), SIZE(indtwi), 1) - - kr = 0 - - Allocate (indk((nmo/2)**2)); Call memplus(KIND(indk), SIZE(indk), 1) - Allocate (indl((nmo/2)**2)); Call memplus(KIND(indl), SIZE(indl), 1) - Allocate (rklr((nmo/2)**2)); Call memplus(KIND(rklr), SIZE(rklr), 1) - Allocate (rkli((nmo/2)**2)); Call memplus(KIND(rkli), SIZE(rkli), 1) - - write (*, '("Current Memory is ",F10.2,"MB")') tmem/1024/1024 - - nuniq = 0 - indk(:) = 0 - indl(:) = 0 - rklr(:) = 0.0d+00 - rkli(:) = 0.0d+00 - int2r(:) = 0.0d+00 - int2i(:) = 0.0d+00 - indtwr = 0 - indtwi = 0 - -!########################################################### -! THIS PART IS TAKEN FROM GOSCIP MOLFDIR PROGRAM PACKAGE -!########################################################### - - totalint = 0 - mdcint = 11 - open (mdcint, file=trim(filename), form='unformatted', status='unknown', err=10) - -60 read (mdcint, ERR=40, END=50) i, j, nz, & - (indk(inz), indl(inz), inz=1, nz), & - (rklr(inz), rkli(inz), inz=1, nz) - - if (i == 0) goto 50 - - totalint = totalint + nz - - itr = i + (-1)**(mod(i, 2) + 1) - jtr = j + (-1)**(mod(j, 2) + 1) - - nmom = ninact + nact + nsec - - SignIJ = (-1)**(mod(i, 2) + mod(j, 2)) -! SignIJ = SIGN(1,ikr) * SIGN(1,jkr) - - Do inz = 1, nz - - k = indk(inz) - ktr = k + (-1)**(mod(k, 2) + 1) - l = indl(inz) - ltr = l + (-1)**(mod(l, 2) + 1) - - If (i > ninact + nact .and. j > ninact + nact .and. & - & k > ninact + nact .and. l > ninact + nact) goto 70 - - SignKL = (-1)**(mod(k, 2) + mod(l, 2)) -! SignKL = SIGN(1,kkr) * SIGN(1,lkr) - nuniq = nuniq + 1 - -!=-> Original integral plus time-reversed partners - INDTWR(I, J, K, L) = NUNIQ - INDTWR(JTR, ITR, K, L) = NUNIQ*SignIJ - INDTWR(I, J, LTR, KTR) = NUNIQ*SignKL - INDTWR(JTR, ITR, LTR, KTR) = NUNIQ*SignIJ*SignKL - INDTWI(I, J, K, L) = NUNIQ - INDTWI(JTR, ITR, K, L) = NUNIQ*SignIJ - INDTWI(I, J, LTR, KTR) = NUNIQ*SignKL - INDTWI(JTR, ITR, LTR, KTR) = NUNIQ*SignIJ*SignKL -!=-> Complex conjugate plus time-reversed partners - INDTWR(J, I, L, K) = NUNIQ - INDTWR(ITR, JTR, L, K) = NUNIQ*SignIJ - INDTWR(J, I, KTR, LTR) = NUNIQ*SignKL - INDTWR(ITR, JTR, KTR, LTR) = NUNIQ*SignIJ*SignKL - INDTWI(J, I, L, K) = -NUNIQ - INDTWI(ITR, JTR, L, K) = -NUNIQ*SignIJ - INDTWI(J, I, KTR, LTR) = -NUNIQ*SignKL - INDTWI(ITR, JTR, KTR, LTR) = -NUNIQ*SignIJ*SignKL -!=-> Particle interchanged plus time-reversed partners - INDTWR(K, L, I, J) = NUNIQ - INDTWR(LTR, KTR, I, J) = NUNIQ*SignKL - INDTWR(K, L, JTR, ITR) = NUNIQ*SignIJ - INDTWR(LTR, KTR, JTR, ITR) = NUNIQ*SignIJ*SignKL - INDTWI(K, L, I, J) = NUNIQ - INDTWI(LTR, KTR, I, J) = NUNIQ*SignKL - INDTWI(K, L, JTR, ITR) = NUNIQ*SignIJ - INDTWI(LTR, KTR, JTR, ITR) = NUNIQ*SignIJ*SignKL -!=-> Particle interchanged and complex conjugated plus time-reversed partners - INDTWR(L, K, J, I) = NUNIQ - INDTWR(KTR, LTR, J, I) = NUNIQ*SignKL - INDTWR(L, K, ITR, JTR) = NUNIQ*SignIJ - INDTWR(KTR, LTR, ITR, JTR) = NUNIQ*SignIJ*SignKL - INDTWI(L, K, J, I) = -NUNIQ - INDTWI(KTR, LTR, J, I) = -NUNIQ*SignKL - INDTWI(L, K, ITR, JTR) = -NUNIQ*SignIJ - INDTWI(KTR, LTR, ITR, JTR) = -NUNIQ*SignIJ*SignKL - - int2rs(nuniq) = rklr(inz) - int2is(nuniq) = rkli(inz) - -! If(abs(rklr(inz))>1.0d-1) write(*,*)rklr(inz),rkli(inz), & -! & i, j, k, l - - if (abs(rkli(inz)) > thres) realc = .false. - -5 FORMAT(4(4I3, 2I6)) - -70 End do - - indk(:) = 0 - indl(:) = 0 - rklr = 0.0d+00 - rkli = 0.0d+00 - - Goto 60 - -10 write (*, *) 'error for opening mdcint 10' - go to 100 -20 write (*, *) 'error for reading mdcint 20' - go to 100 -30 write (*, *) 'end mdcint 30' - go to 100 -40 write (*, *) 'error for reading mdcint 40' - go to 100 -50 write (*, *) 'end mdcint 50 normal' - go to 100 - -100 continue - - close (mdcint) - write (*, *) nuniq, totalint - - Allocate (int2r(0:nuniq)); Call memplus(KIND(int2r), SIZE(int2r), 1) - - int2r(0:nuniq) = int2rs(0:nuniq) - - Deallocate (int2rs); Call memminus(KIND(int2rs), SIZE(int2rs), 1) - - Allocate (int2i(0:nuniq)); Call memplus(KIND(int2i), SIZE(int2i), 1) - - int2i(0:nuniq) = int2is(0:nuniq) - - Deallocate (int2is); Call memminus(KIND(int2is), SIZE(int2is), 1) - - deallocate (indk); Call memminus(KIND(indk), SIZE(indk), 1) - deallocate (indl); Call memminus(KIND(indl), SIZE(indl), 1) - deallocate (rklr); Call memminus(KIND(rklr), SIZE(rklr), 1) - deallocate (rkli); Call memminus(KIND(rkli), SIZE(rkli), 1) - deallocate (kr); Call memminus(KIND(kr), SIZE(kr), 1) - -end subroutine readint2_ty diff --git a/src/readorb_enesym.f90 b/src/readorb_enesym.f90 deleted file mode 100644 index 3d5a0aca..00000000 --- a/src/readorb_enesym.f90 +++ /dev/null @@ -1,356 +0,0 @@ -! ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ - - SUBROUTINE readorb_enesym (filename) ! orbital energies in MRCONEE - -! ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ - - use four_caspt2_module - - Implicit NONE - - integer :: mrconee - character*50,intent(in) :: filename - integer :: j0, j, i, i0, i1, m - integer :: k0, l0, ii, jj, kk, ll, nmomax - -!iwamuro modify - integer :: DS(16,16), SD(16,16), hnsym - - integer, allocatable :: dammo(:) - - real*8 :: w -! logical :: breit - logical :: breit - -! Write(UT_sys_ftmp) NMO,BREIT,ECORE -! Write(UT_sys_ftmp) NSYMRP,(REPN(IRP),IRP=1,NSYMRP) -! Write(UT_sys_ftmp) NSYMRPA,(REPNA(IRP),IRP=1,NSYMRPA*2) -! Write(UT_sys_ftmp) ((MULTB(I,J),I=1,2*NSYMRPA),J=1,2*NSYMRPA) -! Write(UT_sys_ftmp) (IRPMO(IMO),IRPAMO(IMO),ORBMO(IMO),IMO=1,NMO) -! Write(UT_sys_ftmp) ((ONER(IMO,JMO),ONEI(IMO,JMO),JMO=1,NMO),IMO=1,NMO) -! Write(UT_sys_ftmp) RAS(1), RAS(2), RAS(3) - - mrconee=10 - write(*,*)filename - open( mrconee, file=trim(filename),form ='unformatted', status='old', err=10) - write(*,*)'come1' - -! read(mrconee,err=11) nmo, breit, ecore - read(mrconee,err=11) nmo, breit, ecore, nfsym, nz1, sfform, norbt - write(*,*) nmo, breit, ecore, nfsym, nz1, sfform, norbt - - read(mrconee,err=12) nsymrp, (repn(i0), i0 = 1, nsymrp), (nelecd(i0), i0 = 1, nsymrp) -! read(mrconee,err=12) nsymrp, (repn(i0), i0 = 1, nsymrp) - write(*,*) nsymrp, (repn(i0), i0 = 1, nsymrp), (nelecd(i0), i0 = 1, nsymrp) - - read(mrconee,err=13) nsymrpa, (repna(i0), i0 = 1, nsymrpa*2) -! write(*,*) nsymrpa, (repna(i0), i0 = 1, nsymrpa*2) - - read(mrconee,err=14) ((multb(i0,j0),i0=1,2*nsymrpa),j0=1,2*nsymrpa) -! write(*,*) ((multb(i0,j0),i0=1,2*nsymrpa),j0=1,2*nsymrpa) - -! MULTB(1:16, 17:32) = 0 -! MULTB(17:32, 1:16) = 0 - -!-------------------------------------------------------------------------------------------------------------------------- -!iwamuro modify c8h MULTB - - NSYMRP = 16 - NSYMRPA = 16 - REPNA(1) ='1e1/2g'; REPNA(2) ='2e1/2g'; REPNA(3) ='1e3/2g'; REPNA(4) ='2e3/2g' - REPNA(5) ='1e5/2g'; REPNA(6) ='2e5/2g'; REPNA(7) ='1e7/2g'; REPNA(8) ='2e7/2g' - REPNA(9) ='1e1/2u'; REPNA(10)='2e1/2u'; REPNA(11)='1e3/2u'; REPNA(12)='2e3/2u' - REPNA(13)='1e5/2u'; REPNA(14)='2e5/2u'; REPNA(15)='1e7/2u'; REPNA(16)='2e7/2u' - - REPNA(17)='ag '; REPNA(18)='bg '; REPNA(19)='1e1g '; REPNA(20)='2e1g ' - REPNA(21)='1e2g '; REPNA(22)='2e2g '; REPNA(23)='1e3g '; REPNA(24)='2e3g ' - REPNA(25)='au '; REPNA(26)='bu '; REPNA(27)='1e1u '; REPNA(28)='2e1u ' - REPNA(29)='1e2u '; REPNA(30)='2e2u '; REPNA(31)='1e3u '; REPNA(32)='2e3u ' - -!indices 1-hnsym when singles 1-hnsym when doubles hnsym+1-nsymrp - -! SD( 1, 1)= 1; SD( 1, 2)= 2; SD( 1, 3)= 3; SD( 1, 4)= 4; SD( 1, 5)= 5; SD( 1, 6)= 6; SD( 1, 7)= 7; SD( 1, 8)= 8 -! SD( 2, 1)= 7; SD( 2, 2)= 8; SD( 2, 3)= 5; SD( 2, 4)= 6; SD( 2, 5)= 3; SD( 2, 6)= 4; SD( 2, 7)= 1; SD( 2, 8)= 2 -! SD( 3, 1)= 2; SD( 3, 2)= 3; SD( 3, 3)= 6; SD( 3, 4)= 1; SD( 3, 5)= 4; SD( 3, 6)= 7; SD( 3, 7)= 8; SD( 3, 8)= 5 -! SD( 4, 1)= 4; SD( 4, 2)= 1; SD( 4, 3)= 2; SD( 4, 4)= 5; SD( 4, 5)= 8; SD( 4, 6)= 3; SD( 4, 7)= 6; SD( 4, 8)= 7 -! SD( 5, 1)= 3; SD( 5, 2)= 6; SD( 5, 3)= 7; SD( 5, 4)= 2; SD( 5, 5)= 1; SD( 5, 6)= 8; SD( 5, 7)= 5; SD( 5, 8)= 4 -! SD( 6, 1)= 5; SD( 6, 2)= 4; SD( 6, 3)= 1; SD( 6, 4)= 8; SD( 6, 5)= 7; SD( 6, 6)= 2; SD( 6, 7)= 3; SD( 6, 8)= 6 -! SD( 7, 1)= 8; SD( 7, 2)= 5; SD( 7, 3)= 4; SD( 7, 4)= 7; SD( 7, 5)= 6; SD( 7, 6)= 5; SD( 7, 7)= 2; SD( 7, 8)= 3 !SD( 7, 6)= 1 -! SD( 8, 1)= 6; SD( 8, 2)= 7; SD( 8, 3)= 8; SD( 8, 4)= 3; SD( 8, 5)= 2; SD( 8, 6)= 1; SD( 8, 7)= 4; SD( 8, 8)= 1 !SD( 8, 6)= 5 - -! SD -! MULTB( 17, 1)= 1; MULTB( 17, 2)= 2; MULTB( 17, 3)= 3; MULTB( 17, 4)= 4; MULTB( 17, 5)= 5; MULTB( 17, 6)= 6; MULTB( 17, 7)= 7; MULTB( 17, 8)= 8 -! MULTB( 18, 1)= 7; MULTB( 18, 2)= 8; MULTB( 18, 3)= 5; MULTB( 18, 4)= 6; MULTB( 18, 5)= 3; MULTB( 18, 6)= 4; MULTB( 18, 7)= 1; MULTB( 18, 8)= 2 -! MULTB( 19, 1)= 2; MULTB( 19, 2)= 3; MULTB( 19, 3)= 6; MULTB( 19, 4)= 1; MULTB( 19, 5)= 4; MULTB( 19, 6)= 7; MULTB( 19, 7)= 8; MULTB( 19, 8)= 5 -! MULTB( 20, 1)= 4; MULTB( 20, 2)= 1; MULTB( 20, 3)= 2; MULTB( 20, 4)= 5; MULTB( 20, 5)= 8; MULTB( 20, 6)= 3; MULTB( 20, 7)= 6; MULTB( 20, 8)= 7 -! MULTB( 21, 1)= 3; MULTB( 21, 2)= 6; MULTB( 21, 3)= 7; MULTB( 21, 4)= 2; MULTB( 21, 5)= 1; MULTB( 21, 6)= 8; MULTB( 21, 7)= 5; MULTB( 21, 8)= 4 -! MULTB( 22, 1)= 5; MULTB( 22, 2)= 4; MULTB( 22, 3)= 1; MULTB( 22, 4)= 8; MULTB( 22, 5)= 7; MULTB( 22, 6)= 2; MULTB( 22, 7)= 3; MULTB( 22, 8)= 6 -! MULTB( 23, 1)= 8; MULTB( 23, 2)= 5; MULTB( 23, 3)= 4; MULTB( 23, 4)= 7; MULTB( 23, 5)= 6; MULTB( 23, 6)= 1; MULTB( 23, 7)= 2; MULTB( 23, 8)= 3 -! MULTB( 24, 1)= 6; MULTB( 24, 2)= 7; MULTB( 24, 3)= 8; MULTB( 24, 4)= 3; MULTB( 24, 5)= 2; MULTB( 24, 6)= 5; MULTB( 24, 7)= 4; MULTB( 24, 8)= 1 - -! MULTB( 17, 9)= 9; MULTB( 17, 10)= 10; MULTB( 17, 11)= 11; MULTB( 17, 12)= 12; MULTB( 17, 13)= 13; MULTB( 17, 14)= 14; MULTB( 17, 15)= 15; MULTB( 17, 16)= 16 -! MULTB( 18, 9)= 15; MULTB( 18, 10)= 16; MULTB( 18, 11)= 13; MULTB( 18, 12)= 14; MULTB( 18, 13)= 11; MULTB( 18, 14)= 12; MULTB( 18, 15)= 9; MULTB( 18, 16)= 10 -! MULTB( 19, 9)= 10; MULTB( 19, 10)= 11; MULTB( 19, 11)= 14; MULTB( 19, 12)= 9; MULTB( 19, 13)= 12; MULTB( 19, 14)= 15; MULTB( 19, 15)= 16; MULTB( 19, 16)= 13 -! MULTB( 20, 9)= 12; MULTB( 20, 10)= 9; MULTB( 20, 11)= 10; MULTB( 20, 12)= 13; MULTB( 20, 13)= 16; MULTB( 20, 14)= 11; MULTB( 20, 15)= 14; MULTB( 20, 16)= 15 -! MULTB( 21, 9)= 11; MULTB( 21, 10)= 14; MULTB( 21, 11)= 15; MULTB( 21, 12)= 10; MULTB( 21, 13)= 9; MULTB( 21, 14)= 16; MULTB( 21, 15)= 13; MULTB( 21, 16)= 12 -! MULTB( 22, 9)= 13; MULTB( 22, 10)= 12; MULTB( 22, 11)= 9; MULTB( 22, 12)= 16; MULTB( 22, 13)= 15; MULTB( 22, 14)= 10; MULTB( 22, 15)= 11; MULTB( 22, 16)= 14 -! MULTB( 23, 9)= 16; MULTB( 23, 10)= 13; MULTB( 23, 11)= 12; MULTB( 23, 12)= 15; MULTB( 23, 13)= 14; MULTB( 23, 14)= 9; MULTB( 23, 15)= 10; MULTB( 23, 16)= 11 -! MULTB( 24, 9)= 14; MULTB( 24, 10)= 15; MULTB( 24, 11)= 16; MULTB( 24, 12)= 11; MULTB( 24, 13)= 10; MULTB( 24, 14)= 13; MULTB( 24, 15)= 12; MULTB( 24, 16)= 9 - -! MULTB( 25, 1)= 9; MULTB( 25, 2)= 10; MULTB( 25, 3)= 11; MULTB( 25, 4)= 12; MULTB( 25, 5)= 13; MULTB( 25, 6)= 14; MULTB( 25, 7)= 15; MULTB( 25, 8)= 16 -! MULTB( 26, 1)= 15; MULTB( 26, 2)= 16; MULTB( 26, 3)= 13; MULTB( 26, 4)= 14; MULTB( 26, 5)= 11; MULTB( 26, 6)= 12; MULTB( 26, 7)= 9; MULTB( 26, 8)= 10 -! MULTB( 27, 1)= 10; MULTB( 27, 2)= 11; MULTB( 27, 3)= 14; MULTB( 27, 4)= 9; MULTB( 27, 5)= 12; MULTB( 27, 6)= 15; MULTB( 27, 7)= 16; MULTB( 27, 8)= 13 -! MULTB( 28, 1)= 12; MULTB( 28, 2)= 9; MULTB( 28, 3)= 10; MULTB( 28, 4)= 13; MULTB( 28, 5)= 16; MULTB( 28, 6)= 11; MULTB( 28, 7)= 14; MULTB( 28, 8)= 15 -! MULTB( 29, 1)= 11; MULTB( 29, 2)= 14; MULTB( 29, 3)= 15; MULTB( 29, 4)= 10; MULTB( 29, 5)= 9; MULTB( 29, 6)= 16; MULTB( 29, 7)= 13; MULTB( 29, 8)= 12 -! MULTB( 30, 1)= 13; MULTB( 30, 2)= 12; MULTB( 30, 3)= 9; MULTB( 30, 4)= 16; MULTB( 30, 5)= 15; MULTB( 30, 6)= 10; MULTB( 30, 7)= 11; MULTB( 30, 8)= 14 -! MULTB( 31, 1)= 16; MULTB( 31, 2)= 13; MULTB( 31, 3)= 12; MULTB( 31, 4)= 15; MULTB( 31, 5)= 14; MULTB( 31, 6)= 9; MULTB( 31, 7)= 10; MULTB( 31, 8)= 11 -! MULTB( 32, 1)= 14; MULTB( 32, 2)= 15; MULTB( 32, 3)= 16; MULTB( 32, 4)= 11; MULTB( 32, 5)= 10; MULTB( 32, 6)= 13; MULTB( 32, 7)= 12; MULTB( 32, 8)= 9 - -! MULTB( 25, 9)= 1; MULTB( 25, 10)= 2; MULTB( 25, 11)= 3; MULTB( 25, 12)= 4; MULTB( 25, 13)= 5; MULTB( 25, 14)= 6; MULTB( 25, 15)= 7; MULTB( 25, 16)= 8 -! MULTB( 26, 9)= 7; MULTB( 26, 10)= 8; MULTB( 26, 11)= 5; MULTB( 26, 12)= 6; MULTB( 26, 13)= 3; MULTB( 26, 14)= 4; MULTB( 26, 15)= 1; MULTB( 26, 16)= 2 -! MULTB( 27, 9)= 2; MULTB( 27, 10)= 3; MULTB( 27, 11)= 6; MULTB( 27, 12)= 1; MULTB( 27, 13)= 4; MULTB( 27, 14)= 7; MULTB( 27, 15)= 8; MULTB( 27, 16)= 5 -! MULTB( 28, 9)= 4; MULTB( 28, 10)= 1; MULTB( 28, 11)= 2; MULTB( 28, 12)= 5; MULTB( 28, 13)= 8; MULTB( 28, 14)= 3; MULTB( 28, 15)= 6; MULTB( 28, 16)= 7 -! MULTB( 29, 9)= 3; MULTB( 29, 10)= 6; MULTB( 29, 11)= 7; MULTB( 29, 12)= 2; MULTB( 29, 13)= 1; MULTB( 29, 14)= 8; MULTB( 29, 15)= 5; MULTB( 29, 16)= 4 -! MULTB( 30, 9)= 5; MULTB( 30, 10)= 4; MULTB( 30, 11)= 1; MULTB( 30, 12)= 8; MULTB( 30, 13)= 7; MULTB( 30, 14)= 2; MULTB( 30, 15)= 3; MULTB( 30, 16)= 6 -! MULTB( 31, 9)= 8; MULTB( 31, 10)= 5; MULTB( 31, 11)= 4; MULTB( 31, 12)= 7; MULTB( 31, 13)= 6; MULTB( 31, 14)= 1; MULTB( 31, 15)= 2; MULTB( 31, 16)= 3 -! MULTB( 32, 9)= 6; MULTB( 32, 10)= 7; MULTB( 32, 11)= 8; MULTB( 32, 12)= 3; MULTB( 32, 13)= 2; MULTB( 32, 14)= 5; MULTB( 32, 15)= 4; MULTB( 32, 16)= 1 - -!DS -! MULTB( 1, 17)= 1; MULTB( 1, 18)= 7; MULTB( 1, 19)= 2; MULTB( 1, 20)= 4; MULTB( 1, 21)= 3; MULTB( 1, 22)= 5; MULTB( 1, 23)= 8; MULTB( 1, 24)= 6 -! MULTB( 2, 17)= 2; MULTB( 2, 18)= 8; MULTB( 2, 19)= 3; MULTB( 2, 20)= 1; MULTB( 2, 21)= 6; MULTB( 2, 22)= 4; MULTB( 2, 23)= 5; MULTB( 2, 24)= 7 -! MULTB( 3, 17)= 3; MULTB( 3, 18)= 5; MULTB( 3, 19)= 6; MULTB( 3, 20)= 2; MULTB( 3, 21)= 7; MULTB( 3, 22)= 1; MULTB( 3, 23)= 4; MULTB( 3, 24)= 8 -! MULTB( 4, 17)= 4; MULTB( 4, 18)= 6; MULTB( 4, 19)= 1; MULTB( 4, 20)= 5; MULTB( 4, 21)= 2; MULTB( 4, 22)= 8; MULTB( 4, 23)= 7; MULTB( 4, 24)= 3 -! MULTB( 5, 17)= 5; MULTB( 5, 18)= 3; MULTB( 5, 19)= 4; MULTB( 5, 20)= 8; MULTB( 5, 21)= 1; MULTB( 5, 22)= 7; MULTB( 5, 23)= 6; MULTB( 5, 24)= 2 -! MULTB( 6, 17)= 6; MULTB( 6, 18)= 4; MULTB( 6, 19)= 7; MULTB( 6, 20)= 3; MULTB( 6, 21)= 8; MULTB( 6, 22)= 2; MULTB( 6, 23)= 1; MULTB( 6, 24)= 5 -! MULTB( 7, 17)= 7; MULTB( 7, 18)= 1; MULTB( 7, 19)= 8; MULTB( 7, 20)= 6; MULTB( 7, 21)= 5; MULTB( 7, 22)= 3; MULTB( 7, 23)= 2; MULTB( 7, 24)= 4 -! MULTB( 8, 17)= 8; MULTB( 8, 18)= 2; MULTB( 8, 19)= 5; MULTB( 8, 20)= 7; MULTB( 8, 21)= 4; MULTB( 8, 22)= 6; MULTB( 8, 23)= 3; MULTB( 8, 24)= 1 - -! MULTB( 1, 25)= 9; MULTB( 1, 26)= 15; MULTB( 1, 27)= 10; MULTB( 1, 28)= 12; MULTB( 1, 29)= 11; MULTB( 1, 30)= 13; MULTB( 1, 31)= 16; MULTB( 1, 32)= 14 -! MULTB( 2, 25)= 10; MULTB( 2, 26)= 16; MULTB( 2, 27)= 11; MULTB( 2, 28)= 9; MULTB( 2, 29)= 14; MULTB( 2, 30)= 12; MULTB( 2, 31)= 13; MULTB( 2, 32)= 15 -! MULTB( 3, 25)= 11; MULTB( 3, 26)= 13; MULTB( 3, 27)= 14; MULTB( 3, 28)= 10; MULTB( 3, 29)= 15; MULTB( 3, 30)= 9; MULTB( 3, 31)= 12; MULTB( 3, 32)= 16 -! MULTB( 4, 25)= 12; MULTB( 4, 26)= 14; MULTB( 4, 27)= 9; MULTB( 4, 28)= 13; MULTB( 4, 29)= 10; MULTB( 4, 30)= 16; MULTB( 4, 31)= 15; MULTB( 4, 32)= 11 -! MULTB( 5, 25)= 13; MULTB( 5, 26)= 11; MULTB( 5, 27)= 12; MULTB( 5, 28)= 16; MULTB( 5, 29)= 9; MULTB( 5, 30)= 15; MULTB( 5, 31)= 14; MULTB( 5, 32)= 10 -! MULTB( 6, 25)= 14; MULTB( 6, 26)= 12; MULTB( 6, 27)= 15; MULTB( 6, 28)= 11; MULTB( 6, 29)= 16; MULTB( 6, 30)= 10; MULTB( 6, 31)= 9; MULTB( 6, 32)= 13 -! MULTB( 7, 25)= 15; MULTB( 7, 26)= 9; MULTB( 7, 27)= 16; MULTB( 7, 28)= 14; MULTB( 7, 29)= 13; MULTB( 7, 30)= 11; MULTB( 7, 31)= 10; MULTB( 7, 32)= 12 -! MULTB( 8, 25)= 16; MULTB( 8, 26)= 10; MULTB( 8, 27)= 13; MULTB( 8, 28)= 15; MULTB( 8, 29)= 12; MULTB( 8, 30)= 14; MULTB( 8, 31)= 11; MULTB( 8, 32)= 9 - -! MULTB( 9, 17)= 9; MULTB( 9, 18)= 15; MULTB( 9, 19)= 10; MULTB( 9, 20)= 12; MULTB( 9, 21)= 11; MULTB( 9, 22)= 13; MULTB( 9, 23)= 16; MULTB( 9, 24)= 14 -! MULTB( 10, 17)= 10; MULTB( 10, 18)= 16; MULTB( 10, 19)= 11; MULTB( 10, 20)= 9; MULTB( 10, 21)= 14; MULTB( 10, 22)= 12; MULTB( 10, 23)= 13; MULTB( 10, 24)= 15 -! MULTB( 11, 17)= 11; MULTB( 11, 18)= 13; MULTB( 11, 19)= 14; MULTB( 11, 20)= 10; MULTB( 11, 21)= 15; MULTB( 11, 22)= 9; MULTB( 11, 23)= 12; MULTB( 11, 24)= 16 -! MULTB( 12, 17)= 12; MULTB( 12, 18)= 14; MULTB( 12, 19)= 9; MULTB( 12, 20)= 13; MULTB( 12, 21)= 10; MULTB( 12, 22)= 16; MULTB( 12, 23)= 15; MULTB( 12, 24)= 11 -! MULTB( 13, 17)= 13; MULTB( 13, 18)= 11; MULTB( 13, 19)= 12; MULTB( 13, 20)= 16; MULTB( 13, 21)= 9; MULTB( 13, 22)= 15; MULTB( 13, 23)= 14; MULTB( 13, 24)= 10 -! MULTB( 14, 17)= 14; MULTB( 14, 18)= 12; MULTB( 14, 19)= 15; MULTB( 14, 20)= 11; MULTB( 14, 21)= 16; MULTB( 14, 22)= 10; MULTB( 14, 23)= 9; MULTB( 14, 24)= 13 -! MULTB( 15, 17)= 15; MULTB( 15, 18)= 9; MULTB( 15, 19)= 16; MULTB( 15, 20)= 14; MULTB( 15, 21)= 13; MULTB( 15, 22)= 11; MULTB( 15, 23)= 10; MULTB( 15, 24)= 12 -! MULTB( 16, 17)= 16; MULTB( 16, 18)= 10; MULTB( 16, 19)= 13; MULTB( 16, 20)= 15; MULTB( 16, 21)= 12; MULTB( 16, 22)= 14; MULTB( 16, 23)= 11; MULTB( 16, 24)= 9 - -! MULTB( 9, 25)= 1; MULTB( 9, 26)= 7; MULTB( 9, 27)= 2; MULTB( 9, 28)= 4; MULTB( 9, 29)= 3; MULTB( 9, 30)= 5; MULTB( 9, 31)= 8; MULTB( 9, 32)= 6 -! MULTB( 10, 25)= 2; MULTB( 10, 26)= 8; MULTB( 10, 27)= 3; MULTB( 10, 28)= 1; MULTB( 10, 29)= 6; MULTB( 10, 30)= 4; MULTB( 10, 31)= 5; MULTB( 10, 32)= 7 -! MULTB( 11, 25)= 3; MULTB( 11, 26)= 5; MULTB( 11, 27)= 6; MULTB( 11, 28)= 2; MULTB( 11, 29)= 7; MULTB( 11, 30)= 1; MULTB( 11, 31)= 4; MULTB( 11, 32)= 8 -! MULTB( 12, 25)= 4; MULTB( 12, 26)= 6; MULTB( 12, 27)= 1; MULTB( 12, 28)= 5; MULTB( 12, 29)= 2; MULTB( 12, 30)= 8; MULTB( 12, 31)= 7; MULTB( 12, 32)= 3 -! MULTB( 13, 25)= 5; MULTB( 13, 26)= 3; MULTB( 13, 27)= 4; MULTB( 13, 28)= 8; MULTB( 13, 29)= 1; MULTB( 13, 30)= 7; MULTB( 13, 31)= 6; MULTB( 13, 32)= 2 -! MULTB( 14, 25)= 6; MULTB( 14, 26)= 4; MULTB( 14, 27)= 7; MULTB( 14, 28)= 3; MULTB( 14, 29)= 8; MULTB( 14, 30)= 2; MULTB( 14, 31)= 1; MULTB( 14, 32)= 5 -! MULTB( 15, 25)= 7; MULTB( 15, 26)= 1; MULTB( 15, 27)= 8; MULTB( 15, 28)= 6; MULTB( 15, 29)= 5; MULTB( 15, 30)= 3; MULTB( 15, 31)= 2; MULTB( 15, 32)= 4 -! MULTB( 16, 25)= 8; MULTB( 16, 26)= 2; MULTB( 16, 27)= 5; MULTB( 16, 28)= 7; MULTB( 16, 29)= 4; MULTB( 16, 30)= 6; MULTB( 16, 31)= 3; MULTB( 16, 32)= 1 - -! Do i0 = 1, 16 -! Do j0 = 1, 16 -! MULTB(i0,j0)=MULTB(i0,j0)-16 -! End do -! End do - -! Do i0 = 17, 32 -! Do j0 = 17, 32 -! MULTB(i0,j0)=MULTB(i0,j0)-16 -! End do -! End do - -!---------------------------------------------------------------------------------------------------------------------- - - open(unit=20, file='multb_c8h.dat', action='read', & - & form='formatted', status='old') - - Do i0 = 1,32 - read(20,*) (MULTB(i0,j0), j0 = 1,32) - End do - - close(20) -!---------------------------------------------------------------------------------------------------------------------- - - Allocate(sp(1:nmo)) ; Call memplus(KIND(sp),SIZE(sp),1) - sp( 1 : ninact ) = 1 - sp( ninact+1 : ninact+nact ) = 2 - sp( ninact+nact+1 : ninact+nact+nsec ) = 3 - sp( ninact+nact+nsec+1 : nmo ) = 4 - - Do i0 = 1, 2*nsymrpa - Do j0 = 1, 2*nsymrpa - k0 = MULTB(i0, j0) - MULTB2(i0, k0) = j0 - Enddo - End do - - write(*,*) 'MULTB' - - Do i0 = 1, 2*nsymrpa - write(*,'(200I4)') (MULTB(i0, j0) ,j0 = 1, 2*nsymrpa) - End do - - write(*,*) 'MULTB2' - - Do i0 = 1, 2*nsymrpa - write(*,'(200I4)') (MULTB2(i0, j0) ,j0 = 1, 2*nsymrpa) - End do - - Allocate ( irpmo (nmo)); Call memplus(KIND(irpmo ),SIZE(irpmo ),1) - Allocate ( irpamo(nmo)); Call memplus(KIND(irpamo),SIZE(irpamo),1) - Allocate ( orbmo (nmo)); Call memplus(KIND(orbmo ),SIZE(orbmo ),1) - Allocate ( orb (nmo)); Call memplus(KIND(orb ),SIZE(orb ),1) - Allocate ( indmo (nmo)); Call memplus(KIND(indmo ),SIZE(indmo ),1) - Allocate ( indmor(nmo)); Call memplus(KIND(indmor),SIZE(indmor),1) - - Allocate ( dammo (nmo)); Call memplus(KIND(dammo ),SIZE(dammo ),1) - - - irpmo(:) = 0 - irpamo(:) = 0 - orbmo(:) = 0.0d+00 - orb(:) = 0.0d+00 - indmo(:) = 0 - - read(mrconee,err=11) (irpmo(i0),irpamo(i0),orbmo(i0),i0 =1,nmo ) - - close (mrconee) - -!irpamo C8h - -! write(*,'("irpmo ",20I2)')(irpmo(i0),i0=1,20) -! write(*,'("irpamo",20I2)')(irpamo(i0),i0=1,20) -! write(*,'("orbmo",10F10.5)')(orbmo(i0),i0=1,10) - - irpmo(:) = irpamo(:) - - write(*,'("irpmo ",20I2)')(irpmo(i0),i0=1,nmo) - write(*,'("irpamo",20I2)')(irpamo(i0),i0=1,nmo) - write(*,'("orbmo",10F10.5)')(orbmo(i0),i0=1,nmo) - -!Iwamuro modify - Do i = 1,nmo - - If( irpmo(i) <= 8 ) then !keep irpmo - Elseif (irpmo(i) <= 16 ) then - goto 100 ! error - Elseif (irpmo(i) <= 24) then - irpmo(i) = irpmo (i) - 8 - Else - goto 100 !error - Endif - - If (irpmo(i) == 3) then - irpmo(i) = 4 - Elseif (irpmo(i) == 4) then - irpmo(i) = 3 - Elseif (irpmo(i) == 11) then - irpmo(i) = 12 - Elseif (irpmo(i) == 12) then - irpmo(i) = 11 - Endif - - Enddo - - write(*,*) "Modify irpmo" - - write(*,'("irpmo ",20I2)')(irpmo(i0),i0=1,nmo) - - orb = orbmo - -! orb is lower order of orbmo - - do i0 = 1, nmo-1 - m = i0 - do j0 = i0+1, nmo - if( orb(j0) < orb(m)) m = j0 - end do - w = orb(i0) ; orb(i0) = orb(m) ; orb(m) = w - end do - - do i0 = 1, nmo - write(*,*)orb(i0) - end do - - do i0 = 1, nmo - write(*,*)orbmo(i0) - end do - -!! orb is lower order of orbmo - - do i0 = 1, nmo, 2 - m = 0 - do j0 = 1, nmo - if (orbmo(j0)== orb(i0)) then ! orbmo(j0) is i0 th MO - if( m==0) then - indmo(i0) = j0 - m = m+1 - else - indmo(i0+1) = j0 - endif - - end if - end do - end do - - do i0 = 1, nmo - indmor(indmo(i0)) = i0 ! i0 is energetic order, indmo(i0) is symmtric order (MRCONEE order) - end do - -! do i0 = 1, nmo -! write(*,'(2I4)')indmor(i0), indmo(i0), i0 -! end do - - orbmo = orb - - dammo = irpmo - - do i0 = 1, nmo - irpmo(i0) = dammo(indmo(i0)) - irpamo(i0) = dammo(indmo(i0)) - end do - - write(*,*)'inactive' - do i0 = 1, ninact - write(*,'(2I4,2X,E20.10,2X,I4)')i0,indmo(i0),orbmo(i0),irpmo(i0) - end do - - write(*,*)'active' - do i0 = ninact+1, ninact+nact - write(*,'(2I4,2X,E20.10,2X,I4)')i0,indmo(i0),orbmo(i0),irpmo(i0) - end do - - write(*,*)'secondary' - do i0 = ninact+nact+1, ninact+nact+nsec - write(*,'(2I4,2X,E20.10,2X,I4)')i0,indmo(i0),orbmo(i0),irpmo(i0) - end do - -! do i0 = 1, nmo -! indmo(i0)=i0 -! end do - - - deallocate (dammo); Call memminus(KIND(dammo),SIZE(dammo),1) - - goto 1000 - - 10 write(*,*) 'err 0' - go to 1000 - 11 write(*,*) 'err 1' - go to 1000 - 12 write(*,*) 'err 2' - go to 1000 - 13 write(*,*) 'err 3' - go to 1000 - 14 write(*,*) 'err 4' - go to 1000 - 15 write(*,*) 'err 5' - go to 1000 - 100 go to 1000 - - 1000 end subroutine readorb_enesym diff --git a/src/readorb_enesym_co.f90 b/src/readorb_enesym_co.f90 index 94eb91a8..06789927 100644 --- a/src/readorb_enesym_co.f90 +++ b/src/readorb_enesym_co.f90 @@ -5,15 +5,16 @@ SUBROUTINE readorb_enesym_co(filename) ! orbital energies in r4dmoin1 ! ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ use four_caspt2_module + use module_file_manager use module_sort_swap Implicit NONE - integer :: mrconee, IMO, IRP + integer :: mrconee_unit, IMO, IRP character*50, intent(in) :: filename integer :: i0, j0, k0, i, j, m, isym, jsym, ksym, iostat integer, allocatable :: dammo(:), UTCHEMIMO1(:, :), UTCHEMIMO2(:, :) integer, allocatable :: SD(:, :), DS(:, :) - logical :: breit + logical :: breit, is_end_of_file ! Write(UT_sys_ftmp) NMO,UT_molinp_atm_enm - DELETE, & ! BREIT,ETOTAL,scfru @@ -23,17 +24,19 @@ SUBROUTINE readorb_enesym_co(filename) ! orbital energies in r4dmoin1 ! UTCHEMIMO1(IMO,isp),UTCHEMIMO2(IMO,isp),IMO=1,NMO),isp=1,scfru) ! Write(UT_sys_ftmp) (((ONE(JMO,IMO,isp),JMO=1,NMO),IMO=1,NMO),isp=1,scfru) - mrconee = 10 + mrconee_unit = default_unit - open (mrconee, file=trim(filename), form='unformatted', status='old', iostat=iostat) + call open_unformatted_file(unit=mrconee_unit, file=trim(filename), status='old', optional_action='read') - if (iostat /= 0) then ! open failed, stop the program - print *, 'ERROR: Error opening file ', trim(filename), ' , rank = ', rank - print *, 'Stop the program.' + Read (mrconee_unit, iostat=iostat) NMO, BREIT, ECORE ! NMO is nbas - ncore + call check_iostat(iostat=iostat,file=trim(filename),end_of_file_reached=is_end_of_file) + if (is_end_of_file) then + print *, 'Error: error in reading NMO, BREIT, ECORE (end of file reached)' + print *, 'iostat = ', iostat stop end if - Read (mrconee) NMO, BREIT, ECORE ! NMO is nbas - ncore + if (rank == 0) then print *, 'NMO, BREIT, ECORE, 1 ! NMO is nbas - ncore' print *, NMO, BREIT, ECORE, 1 ! NMO is nbas - ncore @@ -50,14 +53,28 @@ SUBROUTINE readorb_enesym_co(filename) ! orbital energies in r4dmoin1 Call memplus(size(UTCHEMIMO1), kind(UTCHEMIMO1), 1) Call memplus(size(UTCHEMIMO2), kind(UTCHEMIMO2), 1) - Read (mrconee) NSYMRP, (REPN(IRP), IRP=1, NSYMRP) ! IRs chars + Read (mrconee_unit, iostat=iostat) NSYMRP, (REPN(IRP), IRP=1, NSYMRP) ! IRs chars + call check_iostat(iostat=iostat,file=trim(filename),end_of_file_reached=is_end_of_file) + if (is_end_of_file) then + print *, 'Error: error in reading NSYMRP, REPN (end of file reached)' + print *, 'iostat = ', iostat + stop + end if + if (rank == 0) then print *, ' NSYMRP, (REPN(IRP),IRP=1,NSYMRP) ! IRs chars' print *, NSYMRP, (REPN(IRP), IRP=1, NSYMRP) ! IRs chars end if !Iwamuro modify - Read (mrconee) nsymrpa, (repna(i0), i0=1, nsymrpa*2) + Read (mrconee_unit, iostat=iostat) nsymrpa, (repna(i0), i0=1, nsymrpa*2) + call check_iostat(iostat=iostat,file=trim(filename),end_of_file_reached=is_end_of_file) + if (is_end_of_file) then + print *, 'Error: error in reading nsymrpa, repna (end of file reached)' + print *, 'iostat = ', iostat + stop + end if + if (rank == 0) then print *, nsymrpa, (repna(i0), i0=1, nsymrpa*2) end if @@ -81,20 +98,27 @@ SUBROUTINE readorb_enesym_co(filename) ! orbital energies in r4dmoin1 ! UTCHEMIMO1(IMO,isp),UTCHEMIMO2(IMO,isp), & ! IMO=1,NMO),isp=1,scfru) ! orbital energies <= used here -! Read(mrconee) ((MULTB_S(J,I),MULTB_D(J,I),J=1,NSYMRP),I=1,NSYMRP) -! Read(mrconee) ((IRPMO(IMO),ORBMO(IMO), & +! Read(mrconee_unit) ((MULTB_S(J,I),MULTB_D(J,I),J=1,NSYMRP),I=1,NSYMRP) +! Read(mrconee_unit) ((IRPMO(IMO),ORBMO(IMO), & ! UTCHEMIMO1(IMO,isp),UTCHEMIMO2(IMO,isp), & ! IMO=1,NMO),isp=1,scfru) ! orbital energies <= used here - Read (mrconee) ((multb(i0, j0), i0=1, 2*nsymrpa), j0=1, 2*nsymrpa) + Read (mrconee_unit, iostat=iostat) ((multb(i0, j0), i0=1, 2*nsymrpa), j0=1, 2*nsymrpa) + call check_iostat(iostat=iostat,file=trim(filename),end_of_file_reached=is_end_of_file) + if (is_end_of_file) then + print *, 'Error: error in reading multb (end of file reached)' + print *, 'iostat = ', iostat + stop + end if + -! Read(mrconee) (IRPMO(IMO),ORBMO(IMO),IMO=1,NMO) ! orbital energies <= used here +! Read(mrconee_unit) (IRPMO(IMO),ORBMO(IMO),IMO=1,NMO) ! orbital energies <= used here !Iwamuro modify ! Do IMO=1,NMO ! Write(*,*) IRPMO(IMO),ORBMO(IMO) ! Enddo -! CLOSE(mrconee) +! CLOSE(mrconee_unit) !---------------------------------------------------------------------------------------- @@ -348,9 +372,13 @@ SUBROUTINE readorb_enesym_co(filename) ! orbital energies in r4dmoin1 orb(:) = 0.0d+00 indmo(:) = 0 - Read (mrconee) (IRPMO(IMO), IRPAMO(IMO), ORBMO(IMO), IMO=1, NMO) ! orbital energies <= used here - - CLOSE (mrconee) + Read (mrconee_unit, iostat=iostat) (IRPMO(IMO), IRPAMO(IMO), ORBMO(IMO), IMO=1, NMO) ! orbital energies <= used here + if (iostat .ne. 0) then + print *, 'Error in reading orbital energies' + print *, 'iostat = ', iostat + stop + end if + CLOSE (mrconee_unit) !Iwamuro modify irpmo(:) = irpamo(:) diff --git a/src/readvec.f90 b/src/readvec.f90 deleted file mode 100644 index cc0c485c..00000000 --- a/src/readvec.f90 +++ /dev/null @@ -1,112 +0,0 @@ -! ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ - -SUBROUTINE readvec(filename) - -! ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ - - use four_caspt2_module - - Implicit NONE - - integer :: mdtriv, lenrec, ios, irec, midet - character*50, intent(in) :: filename - integer :: j, i, i0 - - mdtriv = 10 - eigen(:) = 0.0d+00 - cir(:, :) = 0.0d+00 - cii(:, :) = 0.0d+00 - - open (mdtriv, file=trim(filename), status='old', access='direct', recl=8, err=10) - ios = 0 - read (mdtriv, rec=1, err=11, iostat=ios) lenrec - if (ios .ne. 0) goto 12 - close (mdtriv) - - open (mdtriv, file=filename, access='direct', recl=lenrec, err=100) - read (mdtriv, rec=1, err=100) lenrec, nroot - - Allocate (eigen(nroot)) - read (mdtriv, rec=1, err=100) lenrec, nroot, (eigen(i0), i0=1, nroot) - - read (mdtriv, rec=2, err=200) ndet - - Allocate (idet(ndet)) - - read (mdtriv, rec=2, err=200) ndet, (idet(i), i=1, ndet) - -! write(*,*) (idet(i), i=1,ndet) -! do i = 1, ndet -! write(*,*)(btest(idet(i),i0), i0=0,63) -! end do - - midet = 0 - -! do i0 = 1, ndet -! midet = max0( midet, idet(i0)) -! end do -! -! write(*,*) midet, 'midet' -! write(*,*)(btest(midet,i0), i0=0,63) -! -! -! do i0 = 63, 0, -1 -! if(BTEST(midet, i0)) then -!! write(*,*) i0 -! norb = i0 + 1 -! goto 7 -! endif -! end do - -7 nelec = POPCNT(idet(1)) - write (*, *) POPCNT(idet(1)), idet(1) - do i0 = 1, ndet - if (POPCNT(idet(i0)) /= nelec) then - write (*, *) 'error about nelec', nelec, idet(i0) - end if - end do - - Allocate (cir(ndet, nroot)) - Allocate (cii(ndet, nroot)) - - do irec = 1, nroot - read (mdtriv, rec=irec + 2, err=300) (cir(j, irec), cii(j, irec), j=1, ndet) - end do - - - do i0 = 1, nroot - write (*, *) i0, eigen(i0) - end do - - realcvec = .true. - - write (*, *) 'j,irec, cir(j,irec), cii(j,irec)' - - do irec = 1, nroot - do j = 1, ndet - if (ABS(cii(j, irec)) > thres) then - realcvec = .false. - end if - end do - end do - - goto 1 - -10 write (*, *) 'err 10' - go to 1000 -11 write (*, *) 'err 11' - go to 1000 -12 write (*, *) 'err 12' - go to 1000 - -100 write (*, *) 'err 100 vec come' - go to 1000 - -200 write (*, *) 'err 200' - go to 1000 - -300 write (*, *) 'err 300' - go to 1000 - -1 close (mdtriv) -1000 end subroutine readvec diff --git a/src/solvall_A_ord.f90 b/src/solvall_A_ord.f90 deleted file mode 100644 index a7d1a45f..00000000 --- a/src/solvall_A_ord.f90 +++ /dev/null @@ -1,805 +0,0 @@ -! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= -! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= - - SUBROUTINE solvA_ord (e0, e2a) - -! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= -! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= - - use four_caspt2_module - - Implicit NONE - - real*8, intent(in) :: e0 - real*8, intent(out):: e2a - - - - integer :: dimn, dimm, count, dammy - - integer, allocatable :: indsym(:,:) - - real*8, allocatable :: sr(:,:), ur(:,:) - real*8, allocatable :: br(:,:), wsnew(:), ws(:), wb(:) - real*8, allocatable :: br0(:,:), br1(:,:) - real*8 :: e2(2*nsymrp), alpha - - - complex*16, allocatable :: sc(:,:), uc(:,:), sc0(:,:) - complex*16, allocatable :: bc(:,:) - complex*16, allocatable :: bc0(:,:), bc1(:,:), v(:,:,:,:), vc(:), vc1(:) - - logical :: cutoff - integer :: i, j, k, syma, symb, isym, i0, j0, sym1 - integer :: ix, iy, iz, ii, dimi, ixyz - integer :: jx, jy, jz, ji, it - - real*8 :: thresd - -! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= -! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= - -! SPACE A IS NOW CALCULATED -! -! EtiEuv|0> t > u -! -! DRAS1 = -1 DRAS2 = +1 DRAS3 = 0 -! -!! TABUN USO x > y, t > u, y /= z , u /= v -! -! S(xjyz,tiuv) = d(j,i)[ - <0|EzyEtxEuv|0> + d(tx)<0|EzyEuv|0>] -! -! S(xyz,tuv) = - <0|EzyEtxEuv|0> + d(tx)<0|EzyEuv|0> -! -! B(xyz,tuv) = Siguma_w eps(w){-<0|EzyEtxEuvEww|0> + d(tx)<0|EzyEuvEww|0>} -! -! + S(xyz,tuv)(eps(u)+eps(t)-eps(v)) -! -! alpha(i) = - eps(i) - Siguma_w [eps(w)<0|Eww|0>] (<== calculated as e0 in calce0.f) -! -! V(tuv,i)= - SIGUMA_p,q,r:act <0|EvuEptEqr|0>(pi|qr) -! -! + SIGUMA_p,q:act <0|EvuEpq|0> (pq|ti) -! -! - SIGUMA_p:act <0|EvuEpt|0>[h(pi)+ SIGUMA_k:inact{(pi|kk)-(pk|ki)}] -! -! + <0|Evu|0>[h(ti) + SIGUMA_k:inact{(ti|kk) - (tk|ki)}] -! -! E2 = SIGUMA_i, dimm |Vc1(dimm,i)|^2|/{(alpha(i) + wb(dimm)} - -! thresd = thres - thresd = 1.0D-08 - thres = 1.0D-08 - - e2 = 0.0d+00 - e2a = 0.0d+00 - dimi = 0 - dimn = 0 - syma = 0 - - Allocate(v(ninact,ninact+1:ninact+nact,ninact+1:ninact+nact,ninact+1:ninact+nact)) - Call memplus(KIND(v),SIZE(v),2) - - Call vAmat_ord (v) - - write(*,*)'come' - - - Do isym = 1, nsymrpa - - ixyz = 0 - - Do ix = 1, nact - Do iy = 1, nact - Do iz = 1, nact - - jx = ix+ninact - jy = iy+ninact - jz = iz+ninact - syma = MULTB2(irpmo(jz), nsymrpa + 1) - syma = MULTB (irpmo(jy), syma) - syma = MULTB (irpmo(jx), syma) - - If(nsymrpa==1.or.(nsymrpa/=1.and.(syma == isym))) then - ixyz = ixyz + 1 -!Iwamuro modify - Write (*,'("ixyz1",I4)') ixyz - End if - - 100 End do - End do - End do - - dimn = ixyz - - If(dimn == 0) goto 1000 - - Allocate(indsym(3, dimn)) ; Call memplus(KIND(indsym),SIZE(indsym),1) - - ixyz = 0 - - - Do ix = 1, nact - Do iy = 1, nact - Do iz = 1, nact - - jx = ix+ninact - jy = iy+ninact - jz = iz+ninact - syma = MULTB2(irpmo(jz), nsymrpa + 1) - syma = MULTB (irpmo(jy), syma) - syma = MULTB (irpmo(jx), syma) - - If(nsymrpa==1.or.(nsymrpa/=1.and.(syma == isym))) then - ixyz = ixyz + 1 - indsym(1,ixyz) = ix - indsym(2,ixyz) = iy - indsym(3,ixyz) = iz -!Iwamuro modify - Write (*,'("ixyz2",4I5)') ixyz, ix, iy, iz - End if - - 200 End do - End do - End do - - - write(*,*)'isym, dimn',isym, dimn - - Allocate(sc(dimn,dimn)) ; Call memplus(KIND(sc),SIZE(sc),2) - - sc = 0.0d+00 ! sr N*N - - Call sAmat (dimn, indsym, sc) -! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - write(*,*)'sc matrix is obtained normally' - - Allocate(ws(dimn)) ; Call memplus(KIND(ws),SIZE(ws),1) - - cutoff = .TRUE. -! thresd = 1.0d-15 - - Allocate(sc0(dimn,dimn)) ; Call memplus(KIND(sc0),SIZE(sc0),2) - sc0 = sc - - Call cdiag (sc, dimn, dimm, ws, thresd, cutoff) -! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - write(*,*)'after sc cdiag' - - If(dimm == 0) then - deallocate(indsym) ; Call memminus(KIND(indsym),SIZE(indsym),1) - deallocate(sc0) ; Call memminus(KIND(sc0 ),SIZE(sc0 ),2) - deallocate(sc) ; Call memminus(KIND(sc ),SIZE(sc ),2) - deallocate(ws) ; Call memminus(KIND(ws ),SIZE(ws ),1) - goto 1000 - Endif - - If(debug) then - - write(*,*)'Check whether U*SU is diagonal' - - Call checkdgc(dimn, sc0, sc, ws) -! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - write(*,*)'Check whether U*SU is diagonal END' - End if - - write(*,*)'OK cdiag',dimn,dimm - - Allocate(bc(dimn,dimn)) ; Call memplus(KIND(bc),SIZE(bc),2) ! br N*N - bc = 0.0d+00 - Call bAmat (dimn, sc0, indsym, bc) -! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - write(*,*)'bc matrix is obtained normally' - - - deallocate (sc0) ; Call memminus(KIND(sc0 ),SIZE(sc0 ),2) - - Allocate(uc(dimn,dimm)) ; Call memplus(KIND(uc),SIZE(uc),2) ! uc N*M - Allocate(wsnew(dimm)) ; Call memplus(KIND(wsnew),SIZE(wsnew),1) ! wnew M - uc(:,:) = 0.0d+00 - wsnew(:) = 0.0d+00 - - Call ccutoff (sc, ws, dimn, dimm, uc, wsnew) -! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - write(*,*)'OK ccutoff' - deallocate(sc) ; Call memminus(KIND(sc ),SIZE(sc ),2) - deallocate(ws) ; Call memminus(KIND(ws ),SIZE(ws ),1) - - Call ucramda_s_half (uc, wsnew, dimn, dimm) ! uc N*M matrix rewritten as uramda^(-1/2) -! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - deallocate(wsnew) ; Call memminus(KIND(wsnew ),SIZE(wsnew ),1) - - write(*,*)'ucrams half OK' - Allocate(bc0(dimm, dimn)) ; Call memplus(KIND(bc0),SIZE(bc0),2) ! bc0 M*N - bc0 = 0.0d+00 - bc0 = MATMUL(TRANSPOSE(DCONJG(uc)), bc) - - Allocate(bc1(dimm, dimm)) ; Call memplus(KIND(bc1),SIZE(bc1),2) ! bc1 M*M - bc1 = 0.0d+00 - bc1 = MATMUL(bc0, uc) - - If(debug) then - - write(*,*)'Check whether bc1 is hermite or not' - Do i = 1, dimm - Do j = i, dimm - if(ABS(bc1(i,j)-DCONJG(bc1(j,i))) > 1.0d-6) then - write(*,'("debug",2I4,2E15.7)')i,j,bc1(i,j)-bc1(j,i) - End if - End do - End do - write(*,*)'Check whether bc1 is hermite or not END' - - End if - - deallocate (bc) ; Call memminus(KIND(bc ),SIZE(bc ),2) - deallocate (bc0) ; Call memminus(KIND(bc0 ),SIZE(bc0 ),2) - - cutoff = .FALSE. - - Allocate(wb(dimm)) ; Call memplus(KIND(wb),SIZE(wb),1) - - write(*,*)'bC matrix is transrated to bc1(M*M matrix)!' - - Allocate(bc0(dimm,dimm)) ; Call memplus(KIND(bc0),SIZE(bc0),2) ! bc0 M*M - bc0 = bc1 - - Call cdiag(bc1, dimm, dammy, wb, thresd, cutoff) -! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - - If(debug) then - - write(*,*)'Check whether bc is really diagonalized or not' - - Call checkdgc(dimm, bc0, bc1, wb) -! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - write(*,*)'Check whether bc is really diagonalized or not END' - - End if - deallocate(bc0) ; Call memminus(KIND(bc0),SIZE(bc0),2) - - write(*,*)'bC1 matrix is diagonalized!' - - e2 = 0.0d+00 - - Do ii = 1, ninact - ji = ii - sym1 = MULTB2(irpmo(ji), isym) - if(nsymrpa==1.or.(nsymrpa/=1.and.sym1 == nsymrpa+1)) then - -!Iwamuro modify -! sym1 = irpmo(ji) -! if(nsymrpa==1.or.(nsymrpa/=1.and.sym1 == isym)) then - - - Allocate(vc(dimn)) ; Call memplus(KIND(vc),SIZE(vc),2) - Do it = 1, dimn - vc(it) = v(ii,indsym(1,it)+ninact,indsym(2,it)+ninact,indsym(3,it)+ninact) -! write(*,'(4I4,2E20.10)') & -! & ii,indsym(1,it)+ninact,indsym(2,it)+ninact,indsym(3,it)+ninact,vc(it) - Enddo - - Allocate(vc1(dimm)) ; Call memplus(KIND(vc1),SIZE(vc1),2) - vc1(1:dimm) = MATMUL(TRANSPOSE(DCONJG(uc(1:dimn,1:dimm))),vc(1:dimn)) - - Deallocate (vc) ; Call memminus(KIND(vc),SIZE(vc),2) - - - alpha = - eps(ji) - e0 + eshift ! For Level Shift (2007/2/9) - - vc1(1:dimm) = MATMUL(TRANSPOSE(DCONJG(bc1(1:dimm,1:dimm))),vc1(1:dimm)) - - Do j = 1, dimm - sumc2local = sumc2local + (ABS(vc1(j))**2.0d+00)/((alpha+wb(j))**2.0d+00) - e2(isym) = e2(isym) - (ABS(vc1(j))**2.0d+00)/(alpha+wb(j)) - End do - Deallocate(vc1) ; Call memminus(KIND(vc1),SIZE(vc1),2) - - - Endif - - End do - - write(*,'("e2a(",I3,") = ",E20.10,"a.u.")')isym,e2(isym) - - Deallocate(bc1) ; Call memminus(KIND(bc1),SIZE(bc1),2) - Deallocate(uc) ; Call memminus(KIND(uc),SIZE(uc),2) - Deallocate(wb) ; Call memminus(KIND(wb),SIZE(wb),1) - Deallocate(indsym); Call memminus(KIND(indsym),SIZE(indsym),2) - - - e2a = e2a + e2(isym) - - 1000 End do ! isym - - write(*,'("e2a = ",E20.10,"a.u.")')e2a - - write(*,'("sumc2,a = ",E20.10)')sumc2local - sumc2 = sumc2 + sumc2local - - Deallocate(v); Call memminus(KIND(v),SIZE(v),2) - - continue - write(*,*)'end solva' - end - - - - - -! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= -! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= -! - SUBROUTINE sAmat(dimn, indsym, sc) ! Assume C1 molecule, overlap matrix S in space A -! -! S(xyz,tuv) = - <0|EzyEtxEuv|0> + d(tx)<0|EzyEuv|0> -! -! x > y, t > u - -! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= -! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= - - use four_caspt2_module - - Implicit NONE - - integer, intent(in) :: dimn, indsym(3, dimn) - complex*16, intent(out) :: sc(dimn,dimn) - - real*8 ::a,b - - integer :: it, iu, iv, ix, iy, iz - integer :: jt, ju, jv, jx, jy, jz - integer :: i, j - integer :: count - - - - sc = 0.0d+00 - - Do i = 1, dimn - ix = indsym(1,i) - iy = indsym(2,i) - iz = indsym(3,i) - - Do j = i, dimn - it = indsym(1,j) - iu = indsym(2,j) - iv = indsym(3,j) - - a = 0.0d+0 - b = 0.0d+0 - -! S(xyz,tuv) = - <0|EzyEtxEuv|0> + d(tx)<0|EzyEuv|0> - - Call dim3_density & - (iz, iy, it, ix, iu, iv, a,b) - - sc(i,j) = sc(i,j) - DCMPLX(a,b) - - If(it == ix) then - a = 0.0d+0 - b = 0.0d+0 - - Call dim2_density (iz, iy, iu, iv, a,b) - - sc(i,j) = sc(i,j) + DCMPLX(a,b) - - End if - - sc(j,i) = DCONJG(sc(i,j)) - - End do !j - End do !i - - End subroutine sAmat - - - -! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= -! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= - - SUBROUTINE bAmat (dimn, sc, indsym, bc) ! Assume C1 molecule, overlap matrix B in space A -! -! B(xyz,tuv) = Siguma_w eps(w){-<0|EzyEtxEuvEww|0> + d(tx)<0|EzyEuvEww|0>} -! -! + S(xyz,tuv)(eps(u)+eps(t)-eps(v)) -! -! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= -! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= - - use four_caspt2_module - - Implicit NONE - - integer :: it, iu, iv, ix, iy, iz, iw - integer :: jt, ju, jv, jx, jy, jz, jw - integer :: i, j - - integer, intent(in) :: dimn, indsym(3,dimn) - complex*16, intent(in) :: sc(dimn,dimn) - complex*16, intent(out) :: bc(dimn,dimn) - - real*8 :: e, denr, deni - complex*16 :: den - -! write(*,*)'sc0',sc(5,5) - - bc(:,:) = 0.0d+00 - - Do i = 1, dimn - ix = indsym(1,i) - iy = indsym(2,i) - iz = indsym(3,i) - jx = ix + ninact - jy = iy + ninact - jz = iz + ninact - - Do j = i, dimn - - it = indsym(1,j) - iu = indsym(2,j) - iv = indsym(3,j) - jt = it + ninact - ju = iu + ninact - jv = iv + ninact - -! B(xyz,tuv) = Siguma_w eps(w){-<0|EzyEtxEuvEww|0> + d(tx)<0|EzyEuvEww|0>} -! -! + S(xyz,tuv)(eps(u)+eps(t)-eps(v)) - - e = eps(ju) + eps(jt) - eps(jv) - - Do iw = 1, nact - jw = iw + ninact - - Call dim4_density & - (iz, iy, it, ix, iu, iv, iw, iw, denr, deni) - den = DCMPLX(denr, deni) - bc(i,j) = bc(i,j) - den*eps(jw) - - If(it == ix) then - Call dim3_density & - (iz, iy, iu, iv, iw, iw, denr, deni) - den = DCMPLX(denr, deni) - bc(i,j) = bc(i,j) + den*eps(jw) - - Endif - End do - - bc(i, j) = bc(i, j) + sc(i, j)*e - - bc(j, i) = DCONJG(bc(i, j)) - - - End do !i - End do !j - - - write(*,*)'bAmat is ended' - - End subroutine bAmat - - - -! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= -! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= -! - SUBROUTINE vAmat_ord (v) -! -! Assume C1 molecule, V=<0|H|i> matrix in space A -! -! V(tuv,i)= - SIGUMA_p,q,r:act <0|EvuEptEqr|0>(pi|qr) -! -! + SIGUMA_p,q:act <0|EvuEpq|0> (pq|ti) -! -! - SIGUMA_p:act <0|EvuEpt|0>[h(pi)+ SIGUMA_k:inact{(pi|kk)-(pk|ki)}] -! -! + <0|Evu|0>[h(ti) + SIGUMA_k:inact{(ti|kk) - (tk|ki)}] -! -! -! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= -! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= - - use four_caspt2_module - - Implicit NONE - - - complex*16, intent(out) :: & - & v(ninact,ninact+1:ninact+nact,ninact+1:ninact+nact,ninact+1:ninact+nact) - - real*8 :: dr, di, signkl - complex*16 :: cint2, d, dens1(nact,nact), effh(ninact+1:ninact+nact,ninact) - complex*16 :: cint1 - - integer :: it, iu, iv, ii, ip, iq, ir, ik - integer :: jt, ju, jv, ji, jp, jq, jr, jk - integer :: i, j, k, l, kkr, lkr, count, dim(nsymrpa) - integer :: dim2(nsymrpa+1:nsymrpa*2), isym, sym, i0 - - integer,allocatable :: indt(:,:), indu(:,:), indv(:,:) - integer,allocatable :: ind2u(:,:), ind2v(:,:) - logical :: test - - - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! V(tuv,i)= - SIGUMA_p,q,r:act <0|EvuEptEqr|0>(pi|qr) -! -! + SIGUMA_p,q:act <0|EvuEpq|0> (pq|ti) -! -! - SIGUMA_p:act <0|EvuEpt|0>[h(pi)+ SIGUMA_k:inact{(pi|kk)-(pk|ki)}] -! -! + <0|Evu|0>[h(ti) + SIGUMA_k:inact{(ti|kk) - (tk|ki)}] -! -! = - SIGUMA_p,q,r:act <0|EvuEptEqr|0>(pi|qr) -! -! + SIGUMA_p,q:act <0|EvuEpq|0> (pq|ti) -! -! - SIGUMA_p:act <0|EvuEpt|0>effh(pi) + <0|Evu|0>effh(ti) -! ========================================= This part is calculated after reading int2 -! -! effh is stored in memory while reading int2. -! -! effh(p,i) = h(pi)+ SIGUMA_k:inact{(pi|kk)-(pk|ki)} - - v = 0.0d+00 - dens1 = 0.0d+00 - effh = 0.0d+00 - dim = 0 - - Allocate(indt (nact**3, nsymrpa)); Call memplus(KIND(indt),SIZE(indt),1) - Allocate(indu (nact**3, nsymrpa)); Call memplus(KIND(indu),SIZE(indu),1) - Allocate(indv (nact**3, nsymrpa)); Call memplus(KIND(indv),SIZE(indv),1) - indt = 0 - indu = 0 - indv = 0 - dim = 0 - - Do isym = 1, nsymrpa - Do it = 1, nact - jt = it+ninact - Do iv = 1, nact - jv = iv + ninact - Do iu = 1, nact - ju = iu + ninact - - sym = MULTB2(irpmo(jv),nsymrpa+1) - sym = MULTB (irpmo(ju),sym) - sym = MULTB2(isym ,sym) - sym = MULTB (irpmo(jt),sym) - - if(nsymrpa==1.or.(nsymrpa/=1.and.sym == nsymrpa+1)) then - dim(isym) = dim(isym) + 1 - indt(dim(isym),isym) =it - indu(dim(isym),isym) =iu - indv(dim(isym),isym) =iv - endif - Enddo - Enddo - Enddo - Enddo - -!Iwamuro modify -! Do isym = 1, nsymrpa -! write(*,'("dim(ism)")')dim(isym) -! Enddo - - - Allocate(ind2u(nact**2, nsymrpa+1:2*nsymrpa)); Call memplus(KIND(ind2u),SIZE(ind2u),1) - Allocate(ind2v(nact**2, nsymrpa+1:2*nsymrpa)); Call memplus(KIND(ind2v),SIZE(ind2v),1) - ind2u = 0.0d+00 - ind2v = 0.0d+00 - dim2 = 0 - - Do isym = nsymrpa+1, 2*nsymrpa - Do iu = 1, nact - ju = iu+ninact - Do iv = 1, nact - jv = iv + ninact - -!Iwamuro modify - -! Do isym = 1, nsymrpa+1 -! Do iu = 1, nact -! ju = iu+ninact -! Do iv = 1, nact -! jv = iv + ninact - - sym = MULTB2(irpmo(jv),nsymrpa+1) - sym = MULTB (irpmo(ju),sym) - - if(nsymrpa==1.or.(nsymrpa/=1.and.sym == isym)) then - dim2(isym) = dim2(isym) + 1 - ind2u(dim2(isym),isym) = iu - ind2v(dim2(isym),isym) = iv - endif - - Enddo - Enddo - Enddo - - Do isym = nsymrpa+1, 2*nsymrpa - write(*,'(2I4)')dim2(isym),isym - End do - -!Iwamuro modify -! Do isym = 1, nsymrpa+1 -! write(*,'(2I4)')dim2(isym),isym -! End do - - Do ii = 1, ninact - ji = ii - Do it = 1, nact - jt = it+ninact - - Call tramo1(jt, ji, cint1) - effh(jt, ji) = cint1 - -! if(jt==11.and.ji==1) write(*,'("eff 1int",2I4,2E20.10)') jt,ji,cint1 -! if(jt==11.and.ji==1) write(*,'("eff 1int",2E20.10)') effh(jt,ji) - - End do - End do - - -! write(*,*)'effh(11,1)',effh(11,1) - - - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Two types of integrals are stored -! -! (21|22) stored (pi|qr) ...TYPE 1 -! (21|11) stored (pi|jk) ...TYPE 2 -! -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - - open(1, file ='A1int', status='old', form='unformatted') - - 30 read(1, err=10, end=20) i,j,k,l,cint2 ! (ij|kl) - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! V(tuv,i)= - SIGUMA_p,q,r:act <0|EvuEptEqr|0>(pi|qr) -! -! + SIGUMA_p,q:act <0|EvuEpq|0> (ti|pq) -! -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -! write(*,'("TYPE 1 ",4I4,2E20.10)')i,j,k,l,cint2 - - isym = irpmo(j) - Do i0 = 1, dim(isym) - it = indt(i0, isym) - iu = indu(i0, isym) - iv = indv(i0, isym) - jt = it + ninact - ju = iu + ninact - jv = iv + ninact - - Call dim3_density (iv, iu, i-ninact, it, k-ninact, l-ninact, dr, di) - d = DCMPLX(dr, di) - v(j, jt, ju, jv) = v(j, jt, ju, jv) - cint2*d - - Enddo - - isym = MULTB2(irpmo(j),nsymrpa+1) ! j coresponds to ii - isym = MULTB (irpmo(i),isym ) ! i coresponds to it - - Do i0 = 1, dim2(isym) - iu = ind2u(i0, isym) - iv = ind2v(i0, isym) - ju = iu + ninact - jv = iv + ninact - - Call dim2_density (iv, iu, k-ninact, l-ninact, dr, di) - d = DCMPLX(dr, di) - v(j, i, ju, jv) = v(j, i, ju, jv) + cint2*d - - Enddo - - goto 30 - - 20 close(1) - write(*,*)'reading A1int2 is over' - - Call timing(date1, tsec1, date0, tsec0) - date1 = date0 - tsec1 = tsec0 - - - open(1, file ='A2int', status='old', form='unformatted') ! TYPE 2 integrals - - 300 read(1, err=10, end=200) i,j,k,l,cint2 ! (ij|kl) - count = 0 - - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! effh(p,i) = h(pi)+ SIGUMA_k:inact{(pi|kk)-(pk|ki)} -! -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - - if(k==l.and.j/=k) then ! (PI|KK) type - - effh(i, j) = effh(i, j) + cint2 -! write(*,'("A2int+",4I4,2E20.10)')i,j,k,l,cint2 - - elseif(j==k.and.k/=l) then ! (PK|KI) type - - effh(i, l) = effh(i, l) - cint2 -! write(*,'("A2int-",4I4,2E20.10)')i,j,k,l,cint2 - - endif - - goto 300 - - 200 close(1) - write(*,*)'reading A2int2 is over' - - - Call timing(date1, tsec1, date0, tsec0) - date1 = date0 - tsec1 = tsec0 - - - -! - SIGUMA_p:act <0|EvuEpt|0>effh(pi) + <0|Evu|0>effh(ti) - - Do ii = 1, ninact - ji = ii - isym = irpmo(ji) - -! Do ip = 1, nact -! jp = ip + ninact -! if(ABS(effh(jp,ji)) > 1.0d-10) write(*,'("o effh ",2I4,2E20.10)')jp,ji,effh(jp,ji) -! Enddo - - - Do i0 = 1, dim(isym) - it = indt(i0, isym) - iu = indu(i0, isym) - iv = indv(i0, isym) - jt = it+ninact - ju = iu + ninact - jv = iv + ninact - - Call dim1_density (iv, iu, dr, di) - - d = DCMPLX(dr, di) - v(ji, jt, ju, jv) = v(ji, jt, ju, jv) + effh(jt,ji)*d - - Do ip = 1, nact - jp = ip + ninact - - Call dim2_density (iv, iu, ip, it, dr, di) - d = DCMPLX(dr, di) - v(ji, jt, ju, jv) = v(ji, jt, ju, jv) - effh(jp,ji)*d - - End do ! ip - - End do !i0 - End do !ii - - - - goto 100 - - 10 write(*,*) 'error while opening file Aint' ; goto 1000 - 100 continue - - 1000 write(*,*)'vAmat_ord is ended' - - deallocate(indt) ; Call memminus(KIND(indt),SIZE(indt),1) - deallocate(indu) ; Call memminus(KIND(indu),SIZE(indu),1) - deallocate(indv) ; Call memminus(KIND(indv),SIZE(indv),1) - deallocate(ind2u); Call memminus(KIND(ind2u),SIZE(ind2u),1) - deallocate(ind2v); Call memminus(KIND(ind2v),SIZE(ind2v),1) - - - Call timing(date1, tsec1, date0, tsec0) - date1 = date0 - tsec1 = tsec0 - - - end subroutine vAmat_ord diff --git a/src/solvall_A_ord_ty.f90 b/src/solvall_A_ord_ty.f90 index d41ff458..4983bfef 100644 --- a/src/solvall_A_ord_ty.f90 +++ b/src/solvall_A_ord_ty.f90 @@ -114,6 +114,7 @@ SUBROUTINE solvA_ord_ty(e0, e2a) symb = MULTB_D(irpmo(jy), irpmo(jz)) syma = MULTB_S(syma, symb) + ! y,xについて(たとえば)1sの配置になるようなものは使わないようにする If (nsymrpa == 1 .or. (nsymrpa /= 1 .and. (syma == 1))) then ixyz = ixyz + 1 End if @@ -142,6 +143,7 @@ SUBROUTINE solvA_ord_ty(e0, e2a) symb = MULTB_D(irpmo(jy), irpmo(jz)) syma = MULTB_S(syma, symb) + ! y,xについて(たとえば)1sの配置になるようなものは使わないようにする If (nsymrpa == 1 .or. (nsymrpa /= 1 .and. (syma == 1))) then ixyz = ixyz + 1 indsym(1, ixyz) = ix @@ -544,6 +546,7 @@ SUBROUTINE vAmat_ord_ty(v) ! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= use four_caspt2_module + use module_file_manager Implicit NONE #ifdef HAVE_MPI @@ -554,11 +557,12 @@ SUBROUTINE vAmat_ord_ty(v) real*8 :: dr, di complex*16 :: cint2, d, dens1(nact, nact), effh(nact, ninact) complex*16 :: cint1 + logical :: is_end_of_file integer :: it, iu, iv, ii, ip integer :: jt, ju, jv, ji, jp integer :: i, j, k, l, dim(nsymrpa) - integer :: dim2(nsymrpa), isym, i0, syma, symb, symc, iostat + integer :: dim2(nsymrpa), isym, i0, syma, symb, symc, iostat, twoint_unit integer, allocatable :: indt(:, :), indu(:, :), indv(:, :) integer, allocatable :: ind2u(:, :), ind2v(:, :) integer :: datetmp0, datetmp1 @@ -591,6 +595,7 @@ SUBROUTINE vAmat_ord_ty(v) dens1 = 0.0d+00 effh = 0.0d+00 dim = 0 + twoint_unit = default_unit Allocate (indt(nact**3, nsymrpa)); Call memplus(KIND(indt), SIZE(indt), 1) Allocate (indu(nact**3, nsymrpa)); Call memplus(KIND(indu), SIZE(indu), 1) @@ -674,17 +679,13 @@ SUBROUTINE vAmat_ord_ty(v) ! !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - open (1, file=a1int, status='old', form='unformatted') + call open_unformatted_file(unit=twoint_unit, file=a1int, status='old', optional_action='read') if (rank == 0) print *, 'open A1int' do - read (1, iostat=iostat) i, j, k, l, cint2 ! (ij|kl) - ! Exit the loop if iostat is less than 0 - if (iostat < 0) then - if (rank == 0) print *, 'End of A1int' + read (twoint_unit, iostat=iostat) i, j, k, l, cint2 ! (ij|kl) + call check_iostat(iostat=iostat, file=a1int, end_of_file_reached=is_end_of_file) + if (is_end_of_file) then exit - elseif (iostat > 0) then - ! If iostat is greater than 0, error detected in the input file, so exit the program - stop 'Error: Error in reading A1int' end if !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -729,23 +730,18 @@ SUBROUTINE vAmat_ord_ty(v) end do - close (1) + close (twoint_unit) Call timing(datetmp1, tsectmp1, datetmp0, tsectmp0) datetmp1 = datetmp0 tsectmp1 = tsectmp0 - open (1, file=a2int, status='old', form='unformatted') ! TYPE 2 integrals - + call open_unformatted_file(unit=twoint_unit, file=a2int, status='old', optional_action='read') ! TYPE 2 integrals do - read (1, iostat=iostat) i, j, k, l, cint2 ! (ij|kl) - ! Exit the loop if iostat is less than 0 - if (iostat < 0) then - if (rank == 0) print *, 'End of A2int' + read (twoint_unit, iostat=iostat) i, j, k, l, cint2 ! (ij|kl) + call check_iostat(iostat=iostat, file=a2int, end_of_file_reached=is_end_of_file) + if (is_end_of_file) then exit - elseif (iostat > 0) then - ! If iostat is greater than 0, error detected in the input file, so exit the program - stop 'Error: Error in reading A2int' end if !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ! effh(p,i) = h(pi)+ SIGUMA_k:inact{(pi|kk)-(pk|ki)} @@ -763,7 +759,7 @@ SUBROUTINE vAmat_ord_ty(v) end if end do - close (1) + close (twoint_unit) if (rank == 0) print *, 'reading A2int2 is over' #ifdef HAVE_MPI diff --git a/src/solvall_B_ord.f90 b/src/solvall_B_ord.f90 deleted file mode 100644 index 65d7a545..00000000 --- a/src/solvall_B_ord.f90 +++ /dev/null @@ -1,649 +0,0 @@ -! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= -! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= - - SUBROUTINE solvB_ord (e0, e2b) - -! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= -! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= - - use four_caspt2_module - - Implicit NONE - - real*8, intent(in) :: e0 - real*8, intent(out):: e2b - - - - integer :: dimn, dimm, count, dammy - - integer, allocatable :: indsym(:,:) - - real*8, allocatable :: sr(:,:), ur(:,:) - real*8, allocatable :: br(:,:), wsnew(:), ws(:), wb(:) - real*8, allocatable :: br0(:,:), br1(:,:) - real*8 :: e2(2*nsymrpa), e, alpha - - - complex*16, allocatable :: sc(:,:), uc(:,:), sc0(:,:) - complex*16, allocatable :: bc(:,:) - complex*16, allocatable :: bc0(:,:), bc1(:,:), v(:,:,:), vc(:), vc1(:) - - integer, allocatable :: ii0(:), ij0(:), iij(:,:) - integer :: nij - - logical :: cutoff - integer :: j, i, k, syma, isym, i0, j0 - integer :: ij, it, ii, iu, jj, jt, ji, ju - - - real*8 :: thresd - -! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= -! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= - -! SPACE B IS NOW CALCULATED -! -! EtiEuj|0> -! -! DRAS1 = -2 DRAS2 = 2 DRAS3 = 0 -! -! t > u, i > j -! -! -! S(xkyl,tiuj) = d(ki)d(lj)S(xy,tu) -! -! S(xy, tu) = <0|EtxEuy|0> -d(tx)<0|Euy|0> -d(uy)<0|Etx|0> -d(ty)<0|Eux|0> +d(tx)d(uy)-d(ty)d(ux) -! -! B(xy,tu) = Siguma_w [eps(w){<0|EtxEuyEww|0>-d(tx)<0|EuyEww|0> -d(uy)<0|EtxEww|0> -d(ty)<0|EuxEww|0>] -! -! +{d(tx)d(uy)-d(ty)d(ux)}*e0 +S(xy,tu){eps(t)+eps(u)} -! -! a(i,j) = -eps(i) - eps(j) - e0 -! -! V(i,j) = SIGUMA_p,q:active <0|EptEqu|0>(pi|qj) -! -! + SIGUMA_p:active[<0|Ept|0> {(pj|ui) - (uj|pi)} - <0|Epu|0> (ti|pj)] -! -! + (uj|ti) - (tj|ui) -! -! -! E2 = SIGUMA_a,i, dimm |V1(dimm,ai)|^2|/{(alpha(ai) + wb(dimm)} - - -! thresd = thres - thresd = 1.0D-08 - thres = 1.0D-08 - - e2 = 0.0d+00 - e2b = 0.0d+00 - dimn = 0 - syma = nsymrpa + 1 - - write(*,*)' ENTER solv B part' - write(*,*)' nsymrpa', nsymrpa - - i0 = 0 - Do ii = 1, ninact - Do ij = 1, ii-1 - i0 = i0 + 1 - End do - End do - - nij = i0 - Allocate(iij(ninact,ninact)); Call memminus(KIND(iij),SIZE(iij),1) - iij = 0 - Allocate(ii0(nij)) ; Call memminus(KIND(ii0),SIZE(ii0),1) - Allocate(ij0(nij)) ; Call memminus(KIND(ii0),SIZE(ii0),1) - - i0 = 0 - Do ii = 1, ninact - Do ij = 1, ii-1 - i0 = i0 + 1 - iij(ii, ij) = i0 - iij(ij, ii) = i0 - ii0(i0) = ii - ij0(i0) = ij - End do - End do - Allocate(v(nij, ninact+1:ninact+nact, ninact+1:ninact+nact)) - Call memplus(KIND(v),SIZE(v),2) - v = 0.0d+00 - - Call vBmat_ord (nij, iij, v) - - - Do isym = nsymrpa+1, 2*nsymrpa - - dimn = 0 - Do it = 1, nact - jt = it + ninact - Do iu = 1, it-1 - ju = iu + ninact - syma = nsymrpa + 1 - syma = MULTB ( irpmo(ju), syma) - syma = MULTB ( irpmo(jt), syma) - - if (nsymrpa == 1 .or. (nsymrpa /=1 .and. syma == isym)) then - dimn = dimn + 1 - End if - End do ! iu - End do ! it - - write(*,*)'isym, dimn',isym, dimn - - If(dimn == 0) goto 1000 - - Allocate(indsym(2, dimn)) ; Call memplus(KIND(indsym),SIZE(indsym),1) - - dimn = 0 - Do it = 1, nact - jt = it + ninact - Do iu = 1, it-1 - ju = iu + ninact - - syma = nsymrpa + 1 - syma = MULTB ( irpmo(ju), syma) - syma = MULTB ( irpmo(jt), syma) - - if (nsymrpa == 1 .or. (nsymrpa /=1 .and. syma == isym)) then -! if (syma == isym) then - dimn = dimn + 1 - indsym(1,dimn) = it - indsym(2,dimn) = iu - End if - 200 End do ! iu - End do ! it - - Allocate(sc(dimn,dimn)); Call memplus(KIND(sc),SIZE(sc),2) - sc = 0.0d+00 ! sc N*N - - Call sBmat (dimn, indsym, sc) -! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - - write(*,*)'sc matrix is obtained normally' - - Allocate(ws(dimn)); Call memplus(KIND(ws),SIZE(ws),1) - - cutoff = .TRUE. - thresd = 1.0d-08 - - Allocate(sc0(dimn,dimn)); Call memplus(KIND(sc0),SIZE(sc0),2) - sc0 = sc - - Call cdiag (sc, dimn, dimm, ws, thresd, cutoff) -! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - write(*,*)'after s cdiag, new dimension is',dimm - - If(dimm == 0) then - deallocate(indsym) ; Call memminus(KIND(indsym),SIZE(indsym),1) - deallocate(sc0) ; Call memminus(KIND(sc0 ),SIZE(sc0 ),2) - deallocate(sc) ; Call memminus(KIND(sc ),SIZE(sc ),2) - deallocate(ws) ; Call memminus(KIND(ws ),SIZE(ws ),1) - goto 1000 - Endif - - Allocate(bc(dimn,dimn)) ; Call memplus(KIND(bc),SIZE(bc),2) ! br N*N - bc = 0.0d+00 - - Call bBmat (e0, dimn, sc0, indsym, bc) -! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - - write(*,*)'bc matrix is obtained normally' - - If(debug) then - - write(*,*)'Check whether U*SU is diagonal' - - Call checkdgc(dimn, sc0, sc, ws) -! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - - write(*,*)'Check whether U*SU is diagonal END' - - End if - - deallocate (sc0) ; Call memminus(KIND(sc0 ),SIZE(sc0 ),2) - - write(*,*)'OK cdiag',dimn,dimm - - Allocate(uc(dimn,dimm)) ; Call memplus(KIND(uc),SIZE(uc),2) ! uc N*M - Allocate(wsnew(dimm)) ; Call memplus(KIND(wsnew),SIZE(wsnew),1) ! wnew M - uc(:,:) = 0.0d+00 - wsnew(:) = 0.0d+00 - - - - Call ccutoff (sc, ws, dimn, dimm, uc, wsnew) -! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - write(*,*)'OK ccutoff' - deallocate(sc) ; Call memminus(KIND(sc ),SIZE(sc ),2) - deallocate(ws) ; Call memminus(KIND(ws ),SIZE(ws ),1) - - Call ucramda_s_half (uc, wsnew, dimn, dimm) ! uc N*M matrix rewritten as uramda^(-1/2) -! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - deallocate(wsnew) ; Call memminus(KIND(wsnew ),SIZE(wsnew ),1) - - write(*,*)'ucrams half OK' - Allocate(bc0(dimm, dimn)) ; Call memplus(KIND(bc0),SIZE(bc0),2) ! bc0 M*N - bc0 = 0.0d+00 - bc0 = MATMUL(TRANSPOSE(DCONJG(uc)), bc) - - Allocate(bc1(dimm, dimm)) ; Call memplus(KIND(bc1),SIZE(bc1),2) ! bc1 M*M - bc1 = 0.0d+00 - bc1 = MATMUL(bc0, uc) - - - If(debug) then - - write(*,*)'Check whether bc1 is hermite or not' - Do i = 1, dimm - Do j = i, dimm - if(ABS(bc1(i,j)-DCONJG(bc1(j,i))) > 1.0d-6) then - write(*,'(2I4,2E15.7)')i,j,bc1(i,j)-bc1(j,i) - End if - End do - End do - write(*,*)'Check whether bc1 is hermite or not END' - - End if - - - deallocate (bc) ; Call memminus(KIND(bc ),SIZE(bc ),2) - deallocate (bc0) ; Call memminus(KIND(bc0 ),SIZE(bc0 ),2) - - cutoff = .FALSE. - - Allocate(wb(dimm)) ; Call memplus(KIND(wb),SIZE(wb),1) - - write(*,*)'bC matrix is transrated to bc1(M*M matrix)!' - - Allocate(bc0(dimm,dimm)) ; Call memplus(KIND(bc0),SIZE(bc0),2) ! bc0 M*M - bc0 = bc1 - - - Call cdiag(bc1, dimm, dammy, wb, thresd, cutoff) -! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - - If(debug) then - - write(*,*)'Check whether bc is really diagonalized or not' - - Call checkdgc(dimm, bc0, bc1, wb) -! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - write(*,*)'Check whether bc is really diagonalized or not END' - End if - - deallocate(bc0) ; Call memminus(KIND(bc0),SIZE(bc0),2) - - write(*,*)'bC1 matrix is diagonalized!' - - - e2 = 0.0d+00 - - Do i0 = 1, nij - ji = ii0(i0) - jj = ij0(i0) - - syma = isym - syma = MULTB (irpmo(ji), syma) - syma = MULTB (irpmo(jj), syma) - - If(nsymrpa==1.or.(nsymrpa/=1.and.(syma == nsymrpa + 1))) then - - - Allocate(vc(dimn)) ; Call memplus(KIND(vc),SIZE(vc),2) - Do it = 1, dimn - vc(it) = v(i0,indsym(1,it)+ninact,indsym(2,it)+ninact) - Enddo - - Allocate(vc1(dimm)) ; Call memplus(KIND(vc1),SIZE(vc1),2) - vc1 = 0.0d+00 - - vc1(1:dimm) = MATMUL(TRANSPOSE(DCONJG(uc(1:dimn,1:dimm))),vc(1:dimn)) ! v => v~ - Deallocate (vc) ; Call memminus(KIND(vc),SIZE(vc),2) - - alpha = - eps(ji) - eps(jj) - e0 + eshift ! For Level Shift (2007/2/9) - - - vc1(1:dimm) = & - & MATMUL(TRANSPOSE(DCONJG(bc1(1:dimm,1:dimm))),vc1(1:dimm)) ! v~ => v~~ - - - Do j = 1, dimm - sumc2local = sumc2local + (ABS(vc1(j))**2.0d+00)/((alpha+wb(j))**2.0d+00) - e = (ABS(vc1(j))**2.0d+00)/(alpha+wb(j)) - e2(isym) = e2(isym) - e - End do - - Deallocate(vc1) ; Call memminus(KIND(vc1),SIZE(vc1),2) - - End if - - End do !i0 - - - Deallocate(bc1) ; Call memminus(KIND(bc1),SIZE(bc1),2) - Deallocate(uc) ; Call memminus(KIND(uc),SIZE(uc),2) - Deallocate(wb) ; Call memminus(KIND(wb),SIZE(wb),1) - Deallocate(indsym); Call memminus(KIND(indsym),SIZE(indsym),2) - - 1000 write(*,'("e2b(",I3,") = ",E20.10,"a.u.")')isym,e2(isym) - e2b = e2b + e2(isym) - - - End do ! isym - - write(*,'("e2b = ",E20.10,"a.u.")')e2b - - write(*,'("sumc2,b = ",E20.10)')sumc2local - sumc2 =sumc2 + sumc2local - - deallocate(iij) ; Call memminus(KIND(iij),SIZE(iij),1) - deallocate(ii0) ; Call memminus(KIND(ii0),SIZE(ii0),1) - deallocate(ij0) ; Call memminus(KIND(ij0),SIZE(ij0),1) - deallocate(v) ; Call memminus(KIND(v),SIZE(v),2) - - - continue - write(*,*)'end solvB_ord' - end - - - - - -! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= -! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= - - SUBROUTINE sBmat(dimn, indsym, sc) ! Assume C1 molecule, overlap matrix S in space B - -! S(xy, tu) = <0|EtxEuy|0> -d(tx)<0|Euy|0> -d(uy)<0|Etx|0> -d(ty)<0|Eux|0> +d(tx)d(uy)-d(ty)d(ux) -! -! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= -! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= - - use four_caspt2_module - - Implicit NONE - - integer, intent(in) :: dimn, indsym(2, dimn) - complex*16, intent(out) :: sc(dimn,dimn) - - real*8 :: a,b - - integer :: it, iu, iy, ix, ivx, itu - integer :: jt, ju, jy, jx - integer :: i, j - integer :: count - - - - sc = 0.0d+00 - - Do i = 1, dimn - - ix = indsym(1,i) - iy = indsym(2,i) - - Do j = i, dimn - - it = indsym(1,j) - iu = indsym(2,j) - -! S(xy, tu) = <0|EtxEuy|0> -d(tx)<0|Euy|0> -d(uy)<0|Etx|0> -d(ty)<0|Eux|0> +d(tx)d(uy)-d(ty)d(ux) -! ~~~~~~~~This term is0 - Call dim2_density (it, ix, iu, iy, a,b) - sc(i,j) = sc(i,j) + DCMPLX(a,b) - - If(it == ix) then - Call dim1_density (iu, iy, a,b) - sc(i,j) = sc(i,j) - DCMPLX(a,b) - Endif - - If(iu == iy) then - Call dim1_density (it, ix, a,b) - sc(i,j) = sc(i,j) - DCMPLX(a,b) - Endif - - If(it == iy) then - Call dim1_density (iu, ix, a,b) - sc(i,j) = sc(i,j) - DCMPLX(a,b) - Endif - - If((it == ix).and.(iu == iy)) then - sc(i,j) = sc(i,j) + 1.0d+00 - Endif - -! If((it == iy).and.(iu == ix)) then -! write(*,*)'it == iy).and.(iu == ix)' -! sc(i,j) = sc(i,j) - 1.0d+00 -! Endif - - - sc(j,i) = DCONJG(sc(i,j)) - - End do !j - End do !i - - End subroutine sBmat - - - -! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= -! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= - - SUBROUTINE bBmat (e0, dimn, sc, indsym, bc) ! Assume C1 molecule, overlap matrix B in space B -! -! B(xy,tu) = Siguma_w [eps(w){<0|EtxEuyEww|0>-d(tx)<0|EuyEww|0> -d(uy)<0|EtxEww|0> -d(ty)<0|EuxEww|0>] -! -! +{d(tx)d(uy)-d(ty)d(ux)}*e0 +S(xy,tu){eps(t)+eps(u)} -! -! -! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= -! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= - - use four_caspt2_module - - Implicit NONE - - integer, intent(in) :: dimn, indsym(2,dimn) - complex*16, intent(in) :: sc(dimn,dimn) - complex*16, intent(out) :: bc(dimn,dimn) - real*8, intent(in) :: e0 - - real*8 :: e, denr, deni - complex*16 :: den - - integer :: it, iu, iv, ix, iy, iz, iw - integer :: jt, ju, jy, jx, jw, i, j - - - bc(:,:) = 0.0d+00 - - write(*,*)'B space Bmat iroot=',iroot - - Do i = 1, dimn - - ix = indsym(1,i) - jx = ix + ninact - iy = indsym(2,i) - jy = iy + ninact - - Do j = i, dimn - - it = indsym(1,j) - jt = it + ninact - iu = indsym(2,j) - ju = iu + ninact - -! B(xy,tu) = Siguma_w [eps(w){<0|EtxEuyEww|0>-d(tx)<0|EuyEww|0> -d(uy)<0|EtxEww|0> -d(ty)<0|EuxEww|0>] -! -! +{d(tx)d(uy)-d(ty)d(ux)}*e0 +S(xy,tu){eps(t)+eps(u)} - - - e = eps(jt) + eps(ju) - - Do iw = 1, nact - jw = iw + ninact - - Call dim3_density & - (it, ix, iu, iy, iw, iw, denr, deni) - den = DCMPLX(denr, deni) - bc(i,j) = bc(i,j) + den*eps(jw) - - If(it == ix) then - - Call dim2_density (iu, iy, iw, iw, denr, deni) - den = DCMPLX(denr, deni) - bc(i,j) = bc(i,j) - den*eps(jw) - - End if - - If(iu == iy) then - - Call dim2_density (it, ix, iw, iw, denr, deni) - den = DCMPLX(denr, deni) - bc(i,j) = bc(i,j) - den*eps(jw) - - End if - - If(it == iy) then - - Call dim2_density (iu, ix, iw, iw, denr, deni) - den = DCMPLX(denr, deni) - bc(i,j) = bc(i,j) - den*eps(jw) - - End if - - End do - -! +{d(tx)d(uy)-d(ty)d(ux)}*e0 +S(xy,tu){eps(t)+eps(u)} - - If((it == ix) .and.(iu == iy)) then - bc(i, j) = bc(i, j) + e0 - Endif - -! If((it == iy) .and.(iu == ix)) then ! THIS TERM IS 0 -! bc(i, j) = bc(i, j) - e0 -! Endif - - bc(i, j) = bc(i, j) + sc(i, j)*e - - bc(j, i) = DCONJG(bc(i, j)) - - - End do !i - End do !j - - - write(*,*)'bBmat is ended' - - End subroutine bBmat - - - -! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= -! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= - - SUBROUTINE vBmat_ord (nij, iij, v) -! -! -! V(i,j) = SIGUMA_p,q:active <0|EptEqu|0>(pi|qj) -! -! + SIGUMA_p:active[<0|Ept|0> {(pj|ui) - (uj|pi)} - <0|Epu|0> (ti|pj)] -! -! + (uj|ti) - (tj|ui) -! -! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= -! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= - - use four_caspt2_module - - Implicit NONE - - - integer, intent(in) :: nij, iij(ninact,ninact) - - complex*16, intent(out) :: v(nij,ninact+1:ninact+nact,ninact+1:ninact+nact) - - real*8 :: dr, di - complex*16 :: cint2, dens - - integer :: i, j, k, l, tij, ip, iq, save, count - integer :: it, jt, ju, iu - - v = 0.0d+00 - - open(1, file ='Bint', status='old', form='unformatted') ! (21|21) stored (ti|uj) i > j - - 30 read(1, err=10, end=20) i,j,k,l,cint2 ! (ij|kl) - - if(j <= l) goto 30 -! write(*,'(4I4,2E20.10)')i,j,k,l,cint2 - -!------------------------------------------------------------------------------------------------ -! i > j -! -! V(i,j) = SIGUMA_p,q:active <0|EptEqu|0>(pi|qj) ! term1 -! -! + SIGUMA_p:active[<0|Ept|0> {(ui|pj) - (pi|uj)} - <0|Epu|0> (ti|pj)] ! term2 -! -! + (ti|uj) - (ui|tj) ! term3 -! -!------------------------------------------------------------------------------------------------ - - tij = iij(j, l) - -! write(*,'(5I4,2E20.10)')i,j,k,l,tij,cint2 - - ! Term 3 ! + (ti|uj) - (ui|tj) (i > j) - - v(tij, i, k) = v(tij, i, k) + cint2 ! + (ti|uj) - v(tij, k, i) = v(tij, k, i) - cint2 ! - (ui|tj) - - - ! Term 2 ! + SIGUMA_p:active[<0|Ept|0> {(ui|pj) - (pi|uj)} - <0|Epu|0> (ti|pj)] - ! =========================== ================ - ! loop for t loop for u(variable u is renamed to t) - Do it = 1, nact - jt = it + ninact - - Call dim1_density (k-ninact, it, dr, di) - dens = DCMPLX(dr, di) - v(tij,jt,i) = v(tij,jt,i) + cint2*dens - v(tij,i,jt) = v(tij,i,jt) - cint2*dens - - - Call dim1_density (i-ninact, it, dr, di) - dens = DCMPLX(dr, di) - v(tij,jt,k) = v(tij,jt,k) - cint2*dens - - - ! Term1 ! SIGUMA_p,q:active <0|EptEqu|0>(pi|qj) ! term1 - ! ================== - ! loop for t and u - - Do iu = 1, it -1 - ju = iu + ninact - Call dim2_density (i-ninact, it, k-ninact, iu, dr, di) - dens = DCMPLX(dr, di) - v(tij,jt,ju) = v(tij,jt,ju) + cint2*dens - End do - - End do - - goto 30 - - 20 close(1) - write(*,*)'reading int2 is over' - goto 100 - - 10 write(*,*) 'error while opening file Bint' ; goto 100 - - 100 write(*,*)'vBmat_ord is ended' - - - end subroutine vBmat_ord - - - diff --git a/src/solvall_B_ord_ty.f90 b/src/solvall_B_ord_ty.f90 index 233e82ca..45498456 100644 --- a/src/solvall_B_ord_ty.f90 +++ b/src/solvall_B_ord_ty.f90 @@ -571,6 +571,7 @@ SUBROUTINE vBmat_ord_ty(nij, iij, v) ! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= use four_caspt2_module + use module_file_manager Implicit NONE #ifdef HAVE_MPI @@ -582,23 +583,18 @@ SUBROUTINE vBmat_ord_ty(nij, iij, v) real*8 :: dr, di complex*16 :: cint2, dens integer :: i, j, k, l, tij - integer :: it, jt, ju, iu, iostat + integer :: it, iu, iostat, twoint_unit + logical :: is_end_of_file v = 0.0d+00 + twoint_unit = default_unit - open (1, file=bint, status='old', form='unformatted') ! (21|21) stored (ti|uj) i > j + call open_unformatted_file(unit=twoint_unit, file=bint, status='old', optional_action='read') ! (21|21) stored (ti|uj) i > j do - read (1, iostat=iostat) i, j, k, l, cint2 ! (ij|kl) - - ! Exit the loop if iostat is less than 0 - if (iostat < 0) then - if (rank == 0) then - print *, 'End of B1int' - end if + read (twoint_unit, iostat=iostat) i, j, k, l, cint2 ! (ij|kl) + call check_iostat(iostat=iostat, file=bint, end_of_file_reached=is_end_of_file) + if (is_end_of_file) then exit - elseif (iostat > 0) then - ! If iostat is greater than 0, error detected in the input file, so exit the program - stop 'Error: Error in reading Bint' end if if (j <= l) cycle ! Read the next line if j <= l @@ -626,7 +622,7 @@ SUBROUTINE vBmat_ord_ty(nij, iij, v) ! Term 2 ! + SIGUMA_p:active[<0|Ept|0> {(ui|pj) - (pi|uj)} - <0|Epu|0> (ti|pj)] ! =========================== ================ ! loop for t loop for u(variable u is renamed to t) - !$OMP parallel do schedule(dynamic,1) private(dr,di,dens,iu,ju) + !$OMP parallel do schedule(dynamic,1) private(dr,di,dens,iu) Do it = 1, nact Call dim1_density(k, it, dr, di) @@ -643,7 +639,6 @@ SUBROUTINE vBmat_ord_ty(nij, iij, v) ! loop for t and u Do iu = 1, it - 1 - ju = iu + ninact Call dim2_density(i, it, k, iu, dr, di) dens = DCMPLX(dr, di) v(tij, it, iu) = v(tij, it, iu) + cint2*dens @@ -653,7 +648,7 @@ SUBROUTINE vBmat_ord_ty(nij, iij, v) !$OMP end parallel do end do - close (1) + close (twoint_unit) if (rank == 0) print *, 'vBmat_ord_ty is ended' #ifdef HAVE_MPI diff --git a/src/solvall_C_ord.f90 b/src/solvall_C_ord.f90 deleted file mode 100644 index 411dd6b0..00000000 --- a/src/solvall_C_ord.f90 +++ /dev/null @@ -1,752 +0,0 @@ -! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= -! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= - - SUBROUTINE solvC_ord (e0, e2c) - -! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= -! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= - - use four_caspt2_module - - Implicit NONE - - real*8, intent(in) :: e0 - real*8, intent(out):: e2c - - - - integer :: dimn, dimm, count, dammy - - integer, allocatable :: indsym(:,:) - - real*8, allocatable :: sr(:,:), ur(:,:) - real*8, allocatable :: br(:,:), wsnew(:), ws(:), wb(:) - real*8, allocatable :: br0(:,:), br1(:,:) - real*8 :: e2(nsymrp) , dr, di, alpha - - - complex*16, allocatable :: sc(:,:), uc(:,:), sc0(:,:) - complex*16, allocatable :: bc(:,:) - complex*16, allocatable :: bc0(:,:), bc1(:,:), v(:,:,:,:), vc(:), vc1(:) - - logical :: cutoff - integer :: j, i, k, syma, symb, isym, sym1, i0 - integer :: ix, iy, iz, ia, dima, ixyz - integer :: jx, jy, jz, ja, it - integer :: aa, tt, uu, vv - - real*8 :: thresd - -! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= -! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= - -! SPACE C IS NOW CALCULATED -! -! EatEuv|0> -! -! DRAS1 = 0 DRAS2 = -1 DRAS3 = +1 -! -! -! S(xyz,tuv) = <0|EzyExtEuv|0> -! -! B(xyz,tuv) = Siguma_w [eps(w)<0|EzyExtEuvEww|0>+S(xyz,tuv)(eps(u)-eps(v)-eps(t))] -! -! a(a) = eps(a) - Siguma_w [eps(w)<0|Eww|0>] (<== calculated as e0 in calce0.f) -! -! V(tuv,a) = Siguma_p [h'ap - Siguma_q(aq|qp)]<0|EvuEtp|0> + Siguma_pqr<0|EvuEtrEpq|0>(ar|pq) -! -! where h'ap = hap + Siguma_k(is oqqupied)[(ap|kk)-(ak|kp)] -! -! Indices are restricted as t > v, x > z -! So the dimension of (xyz) is (norb**3+norb**2)/2 -! -! E2 = SIGUMA_a, dimm |V1(dimm,a)|^2|/{(a(a) + wb(dimm)} - - -! thresd = thres - thresd = 1.0D-08 - thres = 1.0D-08 - - e2 = 0.0d+00 - e2c = 0.0d+00 - dima = 0 - dimn= 0 - syma = 0 - - Allocate(v(ninact+nact+1:ninact+nact+nsec, ninact+1:ninact+nact, & - & ninact+1:ninact+nact, ninact+1:ninact+nact)) - - Call vCmat_ord (v) - -! Do aa = ninact+nact+1, ninact+nact+nsec -! Do tt = ninact+1, ninact+nact -! Do uu = ninact+1, ninact+nact -! Do vv = ninact+1, ninact+nact -! write(*,'(4I4,E20.5)') 'a,t,u,v,V', aa,tt,uu,vv,v(aa,tt,uu,vv) -! Enddo -! Enddo -! Enddo -! Enddo - - write(*,*)'come' - - Do isym = 1, nsymrpa - - ixyz = 0 - - Do ix = 1, nact - Do iy = 1, nact - Do iz = 1, nact -! Do iz = 1, ix-1 - if(ix == iz) goto 100 - jx = ix+ninact - jy = iy+ninact - jz = iz+ninact - syma = MULTB2(irpmo(jz), nsymrpa + 1) - syma = MULTB (irpmo(jy), syma) - syma = MULTB2(irpmo(jx), syma) - - If(nsymrpa==1.or.(nsymrpa/=1.and.(syma == isym))) then - ixyz = ixyz + 1 - End if - - 100 End do - End do - End do - - dimn = ixyz - - If(dimn == 0) goto 1000 - - Allocate(indsym(3, dimn)) - indsym=0 - ixyz = 0 - - Do ix = 1, nact - Do iy = 1, nact - Do iz = 1, nact -! Do iz = 1, ix-1 - if(ix == iz) goto 200 - - jx = ix+ninact - jy = iy+ninact - jz = iz+ninact - syma = MULTB2(irpmo(jz), nsymrpa + 1) - syma = MULTB (irpmo(jy), syma) - syma = MULTB2(irpmo(jx), syma) - - If(nsymrpa==1.or.(nsymrpa/=1.and.(syma == isym))) then - ixyz = ixyz + 1 - indsym(1,ixyz) = ix - indsym(2,ixyz) = iy - indsym(3,ixyz) = iz - End if - - 200 End do - End do - End do - - - write(*,*)'isym, dimn',isym, dimn - - Allocate(sc(dimn,dimn)) - sc = 0.0d+00 ! sr N*N - - Call sCmat (dimn, indsym, sc) -! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - - write(*,*)'sC matrix is obtained normally' - - Allocate(ws(dimn)) - ws = 0.0d+00 - cutoff = .TRUE. -! thresd = 1.0d-15 - - Allocate(sc0(dimn,dimn)) - sc0 = 0.0d+00 - sc0 = sc - - Call cdiag (sc, dimn, dimm, ws, thresd, cutoff) -! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - write(*,*)'after sc cdiag' - write(*,*)'after s cdiag, new dimension is',dimm - - - If(dimm == 0) then - deallocate(indsym) - deallocate(sc0) - deallocate(sc) - deallocate(ws) - goto 1000 - Endif - - If (debug) then - - write(*,*)'Check whether U*SU is diagonal' - - Call checkdgc(dimn, sc0, sc, ws) -! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - End if - - write(*,*)'Check whether U*SU is diagonal END' - write(*,*)'OK cdiag',dimn,dimm - - - Allocate(bc(dimn,dimn)) ! br N*N - bc = 0.0d+00 - - Call bCmat (dimn, sc0, indsym, bc) -! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - - deallocate (sc0) - - write(*,*)'bC matrix is obtained normally' - - Allocate(uc(dimn,dimm)) ! uc N*M - Allocate(wsnew(dimm)) ! wnew M - uc(:,:) = 0.0d+00 - wsnew(:) = 0.0d+00 - - Call ccutoff (sc, ws, dimn, dimm, uc, wsnew) -! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -! Do i0 = 1, dimm -! write(*,'(E20.10)') wsnew(i0) -! End do - - write(*,*)'OK ccutoff' - deallocate (ws) - deallocate (sc) - - - - Call ucramda_s_half (uc, wsnew, dimn, dimm) ! uc N*M matrix rewritten as uramda^(-1/2) -! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - deallocate(wsnew) - - write(*,*)'ucrams half OK' - Allocate(bc0(dimm, dimn)) ! bc0 M*N - bc0 = 0.0d+00 - bc0 = MATMUL(TRANSPOSE(DCONJG(uc)), bc) - Allocate(bc1(dimm, dimm)) ! bc1 M*M - bc1 = 0.0d+00 - bc1 = MATMUL(bc0, uc) - - If (debug) then - - write(*,*)'Check whether bc1 is hermite or not' - Do i = 1, dimm - Do j = i, dimm - if(ABS(bc1(i,j)-DCONJG(bc1(j,i))) > 1.0d-6) then - write(*,'(2I4,2E15.7)')i,j,bc1(i,j)-bc1(j,i) - End if - End do - End do - write(*,*)'Check whether bc1 is hermite or not END' - - End if - - deallocate (bc) - deallocate (bc0) - - cutoff = .FALSE. - - Allocate(wb(dimm)) - wb = 0.0d+00 - write(*,*)'bC matrix is transrated to bc1(M*M matrix)!' - - Allocate(bc0(dimm,dimm)) - bc0 = 0.0d+00 - bc0 = bc1 - - Call cdiag(bc1, dimm, dammy, wb, thresd, cutoff) -! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - - If (debug) then - - write(*,*)'Check whether bc is really diagonalized or not' - - Call checkdgc(dimm, bc0, bc1, wb) -! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - write(*,*)'Check whether bc is really diagonalized or not END' - - End if - - deallocate(bc0) - - write(*,*)'bC1 matrix is diagonalized!' - - - Do ia = 1, nsec - ja = ia+ninact+nact - sym1 = MULTB(irpmo(ja), isym) - - if(nsymrpa==1.or.(nsymrpa/=1.and.sym1 == nsymrpa+1)) then - - Allocate(vc(dimn)) - Do it = 1, dimn - vc(it) = v(ja,indsym(1,it)+ninact,indsym(2,it)+ninact,indsym(3,it)+ninact) -! write(*,'(4I4,2E20.10)') & -! & ja,indsym(1,it)+ninact,indsym(2,it)+ninact,indsym(3,it)+ninact,vc(it) - Enddo - - Allocate(vc1(dimm)) - vc1(1:dimm) = MATMUL(TRANSPOSE(DCONJG(uc(1:dimn,1:dimm))),vc(1:dimn)) - - Deallocate (vc) - - - alpha = eps(ja) - e0 + eshift ! For Level Shift (2007/2/9) - - vc1(1:dimm) = MATMUL(TRANSPOSE(DCONJG(bc1(1:dimm,1:dimm))),vc1(1:dimm)) - - Do j = 1, dimm - sumc2local = sumc2local + (ABS(vc1(j))**2.0d+00)/((alpha+wb(j))**2.0d+00) - e2(isym) = e2(isym) - (ABS(vc1(j))**2.0d+00)/(alpha+wb(j)) - End do - Deallocate(vc1) - - Endif - - End do - - write(*,'("e2c(",I3,") = ",E20.10,"a.u.")')isym,e2(isym) - - deallocate(bc1) - deallocate(indsym) - Deallocate(uc) - Deallocate(wb) - - e2c = e2c + e2(isym) - - 1000 End do ! isym - - write(*,'("e2c = ",E20.10,"a.u.")')e2c - write(*,'("sumc2,c = ",E20.10)')sumc2local - sumc2 = sumc2 + sumc2local - - - continue - write(*,*)'end solvc' - end - - - - - - - -! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= -! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= - - SUBROUTINE sCmat(dimn, indsym, sc) ! Assume C1 molecule, overlap matrix S in space C - - -! S(xyz,tuv) = <0|EzyExtEuv|0> -! x > z, t > v - -! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= -! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= - - use four_caspt2_module - - Implicit NONE - - integer, intent(in) :: dimn, indsym(3, dimn) - complex*16, intent(out) :: sc(dimn,dimn) - - real*8 ::a,b - - integer :: it, iu, iv, ix, iy, iz - integer :: jt, ju, jv, jx, jy, jz - integer :: i, j - integer :: count - - - - sc = 0.0d+00 - - Do i = 1, dimn - ix = indsym(1,i) - iy = indsym(2,i) - iz = indsym(3,i) - - Do j = i, dimn - - it = indsym(1,j) - iu = indsym(2,j) - iv = indsym(3,j) - - a = 0.0d+0 - b = 0.0d+0 - - Call dim3_density & - (iz, iy, ix, it, iu, iv, a,b) - - sc(i,j) = DCMPLX(a,b) - sc(j,i) = DCMPLX(a,-b) - If(ABS(sc(i,j)) > 1.0d+00) then - write(*,'(2I4,2E20.10)')i,j,sc(i,j) - Endif - End do !j - End do !i - - End subroutine sCmat - - - -! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= -! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= - - SUBROUTINE bCmat (dimn, sc, indsym, bc) ! Assume C1 molecule, overlap matrix B in space C -! -! Indices are restricted as t > v, x > z -! So the dimension of (xyz) is (norb**3+norb**2)/2 -! -! S(xyz,tuv) = <0|EzyExtEuv|0> -! -! B(xyz,tuv) = Siguma_w [eps(w)<0|EzyExtEuvEww|0>+S(xyz,tuv)(eps(u)-eps(v)-eps(t))] -! -! a(a) = eps(a) - Siguma_w [eps(w)<0|Eww|0>] -! -! H0-ES = B-aS : a is iependent from the index of active orbital like, x, y, z, and so on -! -! Here B matrix is constructed. -! -! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= -! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= - - use four_caspt2_module - - Implicit NONE - - integer :: it, iu, iv, ix, iy, iz, iw, i, j - integer :: jt, ju, jv, jx, jy, jz, jw - - integer, intent(in) :: dimn, indsym(3,dimn) - complex*16, intent(in) :: sc(dimn,dimn) - complex*16, intent(out) :: bc(dimn,dimn) - - real*8 :: e, denr, deni - complex*16 :: den - - - bc(:,:) = 0.0d+00 - - write(*,*)'C space Bmat iroot=',iroot - - Do i = 1, dimn - ix = indsym(1,i) - iy = indsym(2,i) - iz = indsym(3,i) - jx = ix + ninact - jy = iy + ninact - jz = iz + ninact - - Do j = i, dimn - - it = indsym(1,j) - iu = indsym(2,j) - iv = indsym(3,j) - jt = it + ninact - ju = iu + ninact - jv = iv + ninact - -! Siguma_w [eps(w)<0|EzyExtEuvEww|0>]+S(xyz,tuv)(eps(u)-eps(v)-eps(t)) - - e = eps(ju) - eps(jv) - eps(jt) - - Do iw = 1, nact - jw = iw + ninact - - Call dim4_density & - (iz, iy, ix, it, iu, iv, iw, iw, denr, deni) - den = DCMPLX(denr, deni) - bc(i,j) = bc(i,j) + den*eps(jw) - - End do - - bc(i, j) = bc(i, j) + sc(i, j)*e - - bc(j, i) = DCONJG(bc(i, j)) - - - End do !i - End do !j - - - write(*,*)'bCmat is ended' - - End subroutine bCmat - - - -! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= -! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= - - SUBROUTINE vCmat_ord (v) - -! Assume C1 molecule, V=<0|H|i> matrix in space C -! -! -! -! V(a,tuv) = Siguma_p [h'ap - Siguma_w(aw|wp)]<0|EvuEtp|0> + Siguma_pqr<0|EvuEtrEpq|0>(ar|pq) -! -! where h'ap = hap + Siguma_k(runs inactive (and frozen) orbital)[(ap|kk)-(ak|kp)] -! -! Indices are restricted as t > v, x > z -! -! So the dimension of (xyz) is (norb**3+norb**2)/2 ! <= C1 case -! -! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= -! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= - - use four_caspt2_module - - Implicit NONE - - - complex*16, intent(out) :: v(ninact+nact+1:ninact+nact+nsec, ninact+1:ninact+nact, & - & ninact+1:ninact+nact, ninact+1:ninact+nact) - - real*8 :: dr, di, signkl - complex*16 :: cint1, cint2, term1, d - complex*16 :: effh(ninact+nact+1:ninact+nact+nsec,ninact+1:ninact+nact) - - integer :: i, j, k, l, kkr, lkr, count, dim(nsymrpa) - integer :: isym, sym - - integer,allocatable :: indt(:,:), indu(:,:), indv(:,:) - logical :: test - integer :: it, iu, iv, iw, ia, ip, iq, ir, ik - integer :: jt, ju, jv, jw, ja, jp, jq, jr, jk - integer :: i0 - - -!^~^~^~^~^~^~^~^~^~^~^~^~^~^~^~^~^~^~^~^~^~^~^~^~^~^~^~^~^~^~^~^~^~^~^~^~^~^~^~^~^~^~^~^~^~^~^~^~ -! V(a,t,u,v) = Siguma_p [h'ap - Siguma_w(aw|wp)]<0|EvuEtp|0> + Siguma_pqr<0|EvuEtrEpq|0>(ar|pq) -! -! All indices run active spinor space except below k(inactive). -! -! where h'ap = hap + Siguma_k(is oqqupied)[(ap|kk)-(ak|kp)] -! -! -! effh(a,p) = hap + Siguma_k(is oqqupied)[(ap|kk)-(ak|kp)] - Siguma_w(aw|wp) -! -! is calculated and stored in memory and after reading int2, take count in V(a,t,u,v) -! -! -!===============================================! -! Three types of integrals are stored Cint ! -! ! -! (ap|qr) = (32|22) TYPE 1 (includes (aw|wp) ) ! -! ! -! (ap|kk) = (32|11) TYPE 2 ! -! ! -! (ak|kp) = (31|12) TYPE 3 ! -!===============================================! -! -!^~^~^~^~^~^~^~^~^~^~^~^~^~^~^~^~^~^~^~^~^~^~^~^~^~^~^~^~^~^~^~^~^~^~^~^~^~^~^~^~^~^~^~^~^~^~^~^~ - - Call timing(date1, tsec1, date0, tsec0) - date1 = date0 - tsec1 = tsec0 - - v = 0.0d+00 - effh = 0.0d+00 - dim = 0 - - Allocate(indt (nact**3, nsymrpa)) - Allocate(indu (nact**3, nsymrpa)) - Allocate(indv (nact**3, nsymrpa)) - indt = 0 - indu = 0 - indv = 0 - dim = 0 - - Do isym = 1, nsymrpa - Do it = 1, nact - jt = it+ninact - Do iv = 1, nact - jv = iv + ninact - Do iu = 1, nact - ju = iu + ninact - - sym = MULTB2(irpmo(jv),nsymrpa+1) - sym = MULTB (irpmo(ju),sym) - sym = MULTB2(irpmo(jt),sym) - sym = MULTB (isym ,sym) - - if(nsymrpa==1.or.(nsymrpa/=1.and.sym == nsymrpa+1)) then - dim(isym) = dim(isym) + 1 - indt(dim(isym),isym) =it - indu(dim(isym),isym) =iu - indv(dim(isym),isym) =iv - endif - Enddo - Enddo - Enddo - Enddo - - Do isym = 1, nsymrpa - write(*,*)dim(isym),isym - Enddo - - - Do ia = 1, nsec - ja = ia+ninact+nact - Do it = 1, nact - jt = it+ninact - - Call tramo1(ja, jt, cint1) - - effh(ja, jt) = cint1 -! write(*,'("1int ",2I4,2E20.10)')ja,jt,effh(ja,jt) - - End do - End do - - - - - open(1, file ='C1int', status='old', form='unformatted') - - 30 read(1, err=10, end=20) i,j,k,l,cint2 ! (ij|kl) - -! write(*,'("TYPE 1 ",4I4,2E20.10)')i,j,k,l,cint2 - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! + Siguma_pqr<0|EvuEtrEpq|0>(ar|pq) -! -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - - isym = irpmo(i) ! i corresponds to a - Do i0 = 1, dim(isym) - it = indt(i0, isym) - iu = indu(i0, isym) - iv = indv(i0, isym) - jt = it + ninact - ju = iu + ninact - jv = iv + ninact - -! test =.FALSE. -! if(j==1.and.jt==3.and.ju==4.and.jv==8) test=.TRUE. - - Call dim3_density (iv, iu, it, j-ninact, k-ninact, l-ninact, dr, di) - d = DCMPLX(dr, di) - v(i, jt, ju, jv) = v(i, jt, ju, jv) + cint2*d - - -! if(test.and.ABS(d)>1.0d-10.and.AbS(cint2)>1.0d-10) & -! & write(*,'("3dim-2int2",6I4,2E20.10,4I4,2E20.10)') & -! &iv, iu, i-ninact, it, k-ninact, l-ninact, d, i,j,k,l,cint2 - - - Enddo - -! effh(a,p) = hap + Siguma_k(is oqqupied)[(ap|kk)-(ak|kp)] - Siguma_w(aw|wp) -! ~~~~~~~~~~~~~~~~~~~ - if(j == k) then - effh(i,l) = effh(i,l) - cint2 - endif - - goto 30 - - 20 close(1) - write(*,*)'reading C1int2 is over' - - - open(1, file ='C2int', status='old', form='unformatted') ! TYPE 2 integrals - - 300 read(1, err=10, end=200) i,j,k,l,cint2 - -! -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! effh(a,p) = hap + Siguma_k(is oqqupied)[(ap|kk)-(ak|kp)] - Siguma_w(aw|wp) -! ======== -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - - if(k==l) then - - effh(i,j) = effh(i,j) + cint2 - - endif - - goto 300 - - 200 close(1) - write(*,*)'reading C2int2 is over' - - - open(1, file ='C3int', status='old', form='unformatted') ! TYPE 3 integrals - - 3000 read(1, err=10, end=2000) i,j,k,l,cint2 ! (ij|kl):=> (ak|kp) - -! -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! effh(a,p) = hap + Siguma_k(is oqqupied)[(ap|kk)-(ak|kp)] - Siguma_w(aw|wp) -! ========= -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - if(j==k) then - - effh(i,l) = effh(i,l) - cint2 - - endif - - goto 3000 - - 2000 close(1) - write(*,*)'reading C3int2 is over' - - -! Siguma_p effh(a,p)<0|EvuEtp|0> - - Do ia = 1, nsec - ja = ia+ninact+nact -! write(*,'("effh ",2I4,2E20.10)')ja, jp, effh(ja,jp) - - isym = irpmo(ja) - - Do ip = 1, nact - jp = ip + ninact - -! write(*,'("effh ",2I4,2E20.10)')ja,jp,effh(ja,jp) - if(ABS(effh(ja, jp)) < 1.0d-10) goto 70 - - Do i0 = 1, dim(isym) - it = indt(i0, isym) - iu = indu(i0, isym) - iv = indv(i0, isym) - jt = it + ninact - ju = iu + ninact - jv = iv + ninact - - Call dim2_density (iv, iu, it, ip, dr, di) - d = DCMPLX(dr, di) - - - v(ja, jt, ju, jv) = v(ja, jt, ju, jv) + effh(ja,jp)*d - - End do !i0 - - 70 End do !ip - End do !ia - - - goto 101 - - - 10 write(*,*) 'error while opening file Cint' ; goto 101 - - 101 write(*,*)'vCmat_ord is ended' - - deallocate(indt) - deallocate(indu) - deallocate(indv) - - Call timing(date1, tsec1, date0, tsec0) - date1 = date0 - tsec1 = tsec0 - - - end subroutine vCmat_ord diff --git a/src/solvall_C_ord_original.f90 b/src/solvall_C_ord_original.f90 deleted file mode 100644 index 67120aa0..00000000 --- a/src/solvall_C_ord_original.f90 +++ /dev/null @@ -1,760 +0,0 @@ -! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= -! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= - - SUBROUTINE solvC_ord (e0, e2c) - -! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= -! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= - - use four_caspt2_module - - Implicit NONE - - real*8, intent(in) :: e0 - real*8, intent(out):: e2c - - - - integer :: dimn, dimm, count, dammy - - integer, allocatable :: indsym(:,:) - - real*8, allocatable :: sr(:,:), ur(:,:) - real*8, allocatable :: br(:,:), wsnew(:), ws(:), wb(:) - real*8, allocatable :: br0(:,:), br1(:,:) - real*8 :: e2(nsymrp) , dr, di, alpha - - - complex*16, allocatable :: sc(:,:), uc(:,:), sc0(:,:) - complex*16, allocatable :: bc(:,:) - complex*16, allocatable :: bc0(:,:), bc1(:,:), v(:,:,:,:), vc(:), vc1(:) - - logical :: cutoff - integer :: j, i, k, syma, symb, isym, sym1, i0, symc - integer :: ix, iy, iz, ia, dima, ixyz - integer :: jx, jy, jz, ja, it - - - real*8 :: thresd - -! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= -! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= - -! SPACE C IS NOW CALCULATED -! -! EatEuv|0> -! -! DRAS1 = 0 DRAS2 = -1 DRAS3 = +1 -! -! -! S(xyz,tuv) = <0|EzyExtEuv|0> -! -! B(xyz,tuv) = Siguma_w [eps(w)<0|EzyExtEuvEww|0>+S(xyz,tuv)(eps(u)-eps(v)-eps(t))] -! -! a(a) = eps(a) - Siguma_w [eps(w)<0|Eww|0>] (<== calculated as e0 in calce0.f) -! -! V(tuv,a) = Siguma_p [h'ap - Siguma_q(aq|qp)]<0|EvuEtp|0> + Siguma_pqr<0|EvuEtrEpq|0>(ar|pq) -! -! where h'ap = hap + Siguma_k(is oqqupied)[(ap|kk)-(ak|kp)] -! -! Indices are restricted as t > v, x > z -! So the dimension of (xyz) is (norb**3+norb**2)/2 -! -! E2 = SIGUMA_a, dimm |V1(dimm,a)|^2|/{(a(a) + wb(dimm)} - - -! thresd = thres - thresd = 1.0D-08 - thres = 1.0D-08 - - e2 = 0.0d+00 - e2c = 0.0d+00 - dima = 0 - dimn= 0 - syma = 0 - - Allocate(v(ninact+nact+1:ninact+nact+nsec, ninact+1:ninact+nact, & - & ninact+1:ninact+nact, ninact+1:ninact+nact)) - - Call vCmat_ord (v) - - write(*,*)'come' - - Do isym = 1, nsymrpa - - ixyz = 0 - - Do ix = 1, nact - Do iy = 1, nact - Do iz = 1, nact -! Do iz = 1, ix-1 - if(ix == iz) goto 100 - jx = ix+ninact - jy = iy+ninact - jz = iz+ninact - syma = MULTB2(irpmo(jz), nsymrpa + 1) - syma = MULTB (irpmo(jy), syma) - syma = MULTB2(irpmo(jx), syma) - -!Iwamuro think -! syma = MULTB(irpmo(jx), isym) -! symb = MULTB2(irpmo(jz), nsymrpa + 1) -! symc = MULTB(irpmo(jy), symb) -!Iwamuro modify -! write(*,*)"syma1",syma -!Iwamuro modify - If(nsymrpa==1.or.(nsymrpa/=1.and.(syma == symc))) then -! If(nsymrpa==1.or.(nsymrpa/=1.and.(syma == isym))) then - ixyz = ixyz + 1 - End if -!Iwamuro modify -! write(*,*)"ixyz1", ixyz - - - 100 End do - End do - End do - - dimn = ixyz - - If(dimn == 0) goto 1000 - - Allocate(indsym(3, dimn)) - indsym=0 - ixyz = 0 - - Do ix = 1, nact - Do iy = 1, nact - Do iz = 1, nact -! Do iz = 1, ix-1 - if(ix == iz) goto 200 - - jx = ix+ninact - jy = iy+ninact - jz = iz+ninact - syma = MULTB2(irpmo(jz), nsymrpa + 1) - syma = MULTB (irpmo(jy), syma) - syma = MULTB2(irpmo(jx), syma) -!Iwamuro modify -! write(*,*)"syma2",syma - - If(nsymrpa==1.or.(nsymrpa/=1.and.(syma == isym))) then - ixyz = ixyz + 1 - indsym(1,ixyz) = ix - indsym(2,ixyz) = iy - indsym(3,ixyz) = iz - End if - - 200 End do - End do - End do - - - write(*,*)'isym, dimn',isym, dimn - - Allocate(sc(dimn,dimn)) - sc = 0.0d+00 ! sr N*N - - Call sCmat (dimn, indsym, sc) -! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - - write(*,*)'sC matrix is obtained normally' - - Allocate(ws(dimn)) - ws = 0.0d+00 - cutoff = .TRUE. -! thresd = 1.0d-15 - - Allocate(sc0(dimn,dimn)) - sc0 = 0.0d+00 - sc0 = sc - - Call cdiag (sc, dimn, dimm, ws, thresd, cutoff) -! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - write(*,*)'after sc cdiag' - write(*,*)'after s cdiag, new dimension is',dimm - - If(dimm == 0) then - deallocate(indsym) - deallocate(sc0) - deallocate(sc) - deallocate(ws) - goto 1000 - Endif - - If (debug) then - - write(*,*)'Check whether U*SU is diagonal' - - Call checkdgc(dimn, sc0, sc, ws) -! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - End if - - write(*,*)'Check whether U*SU is diagonal END' - write(*,*)'OK cdiag',dimn,dimm - - - Allocate(bc(dimn,dimn)) ! br N*N - bc = 0.0d+00 - - Call bCmat (dimn, sc0, indsym, bc) -! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - - deallocate (sc0) - - write(*,*)'bC matrix is obtained normally' - - Allocate(uc(dimn,dimm)) ! uc N*M - Allocate(wsnew(dimm)) ! wnew M - uc(:,:) = 0.0d+00 - wsnew(:) = 0.0d+00 - - Call ccutoff (sc, ws, dimn, dimm, uc, wsnew) -! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -! Do i0 = 1, dimm -! write(*,'(E20.10)') wsnew(i0) -! End do - - write(*,*)'OK ccutoff' - deallocate (ws) - deallocate (sc) - - - - Call ucramda_s_half (uc, wsnew, dimn, dimm) ! uc N*M matrix rewritten as uramda^(-1/2) -! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - deallocate(wsnew) - - write(*,*)'ucrams half OK' - Allocate(bc0(dimm, dimn)) ! bc0 M*N - bc0 = 0.0d+00 - bc0 = MATMUL(TRANSPOSE(DCONJG(uc)), bc) - Allocate(bc1(dimm, dimm)) ! bc1 M*M - bc1 = 0.0d+00 - bc1 = MATMUL(bc0, uc) - - If (debug) then - - write(*,*)'Check whether bc1 is hermite or not' - Do i = 1, dimm - Do j = i, dimm - if(ABS(bc1(i,j)-DCONJG(bc1(j,i))) > 1.0d-6) then - write(*,'(2I4,2E15.7)')i,j,bc1(i,j)-bc1(j,i) - End if - End do - End do - write(*,*)'Check whether bc1 is hermite or not END' - - End if - - deallocate (bc) - deallocate (bc0) - - cutoff = .FALSE. - - Allocate(wb(dimm)) - wb = 0.0d+00 - write(*,*)'bC matrix is transrated to bc1(M*M matrix)!' - - Allocate(bc0(dimm,dimm)) - bc0 = 0.0d+00 - bc0 = bc1 - - Call cdiag(bc1, dimm, dammy, wb, thresd, cutoff) -! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - - If (debug) then - - write(*,*)'Check whether bc is really diagonalized or not' - - Call checkdgc(dimm, bc0, bc1, wb) -! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - write(*,*)'Check whether bc is really diagonalized or not END' - - End if - - deallocate(bc0) - - write(*,*)'bC1 matrix is diagonalized!' - - - Do ia = 1, nsec - ja = ia+ninact+nact - sym1 = MULTB(irpmo(ja), isym) -!Iwamuro modify -! write(*,*)"sym11",sym1 - - if(nsymrpa==1.or.(nsymrpa/=1.and.sym1 == nsymrpa+1)) then - - Allocate(vc(dimn)) - Do it = 1, dimn - vc(it) = v(ja,indsym(1,it)+ninact,indsym(2,it)+ninact,indsym(3,it)+ninact) -! write(*,'(4I4,2E20.10)') & -! & ja,indsym(1,it)+ninact,indsym(2,it)+ninact,indsym(3,it)+ninact,vc(it) - Enddo - - Allocate(vc1(dimm)) - vc1(1:dimm) = MATMUL(TRANSPOSE(DCONJG(uc(1:dimn,1:dimm))),vc(1:dimn)) - - Deallocate (vc) - - - alpha = eps(ja) - e0 + eshift ! For Level Shift (2007/2/9) - - vc1(1:dimm) = MATMUL(TRANSPOSE(DCONJG(bc1(1:dimm,1:dimm))),vc1(1:dimm)) - - Do j = 1, dimm - sumc2local = sumc2local + (ABS(vc1(j))**2.0d+00)/((alpha+wb(j))**2.0d+00) - e2(isym) = e2(isym) - (ABS(vc1(j))**2.0d+00)/(alpha+wb(j)) - End do - Deallocate(vc1) - - Endif - - End do - - write(*,'("e2c(",I3,") = ",E20.10,"a.u.")')isym,e2(isym) - - deallocate(bc1) - deallocate(indsym) - Deallocate(uc) - Deallocate(wb) - - e2c = e2c + e2(isym) - - 1000 End do ! isym - - write(*,'("e2c = ",E20.10,"a.u.")')e2c - write(*,'("sumc2,c = ",E20.10)')sumc2local - sumc2 = sumc2 + sumc2local - - - continue - write(*,*)'end solvc' - end - - - - - - - -! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= -! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= - - SUBROUTINE sCmat(dimn, indsym, sc) ! Assume C1 molecule, overlap matrix S in space C - - -! S(xyz,tuv) = <0|EzyExtEuv|0> -! x > z, t > v - -! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= -! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= - - use four_caspt2_module - - Implicit NONE - - integer, intent(in) :: dimn, indsym(3, dimn) - complex*16, intent(out) :: sc(dimn,dimn) - - real*8 ::a,b - - integer :: it, iu, iv, ix, iy, iz - integer :: jt, ju, jv, jx, jy, jz - integer :: i, j - integer :: count - - - - sc = 0.0d+00 - - Do i = 1, dimn - ix = indsym(1,i) - iy = indsym(2,i) - iz = indsym(3,i) - - Do j = i, dimn - - it = indsym(1,j) - iu = indsym(2,j) - iv = indsym(3,j) - - a = 0.0d+0 - b = 0.0d+0 - - Call dim3_density & - (iz, iy, ix, it, iu, iv, a,b) - - sc(i,j) = DCMPLX(a,b) - sc(j,i) = DCMPLX(a,-b) - If(ABS(sc(i,j)) > 1.0d+00) then - write(*,'(2I4,2E20.10)')i,j,sc(i,j) - Endif - End do !j - End do !i - - End subroutine sCmat - - - -! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= -! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= - - SUBROUTINE bCmat (dimn, sc, indsym, bc) ! Assume C1 molecule, overlap matrix B in space C -! -! Indices are restricted as t > v, x > z -! So the dimension of (xyz) is (norb**3+norb**2)/2 -! -! S(xyz,tuv) = <0|EzyExtEuv|0> -! -! B(xyz,tuv) = Siguma_w [eps(w)<0|EzyExtEuvEww|0>+S(xyz,tuv)(eps(u)-eps(v)-eps(t))] -! -! a(a) = eps(a) - Siguma_w [eps(w)<0|Eww|0>] -! -! H0-ES = B-aS : a is iependent from the index of active orbital like, x, y, z, and so on -! -! Here B matrix is constructed. -! -! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= -! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= - - use four_caspt2_module - - Implicit NONE - - integer :: it, iu, iv, ix, iy, iz, iw, i, j - integer :: jt, ju, jv, jx, jy, jz, jw - - integer, intent(in) :: dimn, indsym(3,dimn) - complex*16, intent(in) :: sc(dimn,dimn) - complex*16, intent(out) :: bc(dimn,dimn) - - real*8 :: e, denr, deni - complex*16 :: den - - - bc(:,:) = 0.0d+00 - - write(*,*)'C space Bmat iroot=',iroot - - Do i = 1, dimn - ix = indsym(1,i) - iy = indsym(2,i) - iz = indsym(3,i) - jx = ix + ninact - jy = iy + ninact - jz = iz + ninact - - Do j = i, dimn - - it = indsym(1,j) - iu = indsym(2,j) - iv = indsym(3,j) - jt = it + ninact - ju = iu + ninact - jv = iv + ninact - -! Siguma_w [eps(w)<0|EzyExtEuvEww|0>]+S(xyz,tuv)(eps(u)-eps(v)-eps(t)) - - e = eps(ju) - eps(jv) - eps(jt) - - Do iw = 1, nact - jw = iw + ninact - - Call dim4_density & - (iz, iy, ix, it, iu, iv, iw, iw, denr, deni) - den = DCMPLX(denr, deni) - bc(i,j) = bc(i,j) + den*eps(jw) - - End do - - bc(i, j) = bc(i, j) + sc(i, j)*e - - bc(j, i) = DCONJG(bc(i, j)) - - - End do !i - End do !j - - - write(*,*)'bCmat is ended' - - End subroutine bCmat - - - -! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= -! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= - - SUBROUTINE vCmat_ord (v) - -! Assume C1 molecule, V=<0|H|i> matrix in space C -! -! -! -! V(a,tuv) = Siguma_p [h'ap - Siguma_w(aw|wp)]<0|EvuEtp|0> + Siguma_pqr<0|EvuEtrEpq|0>(ar|pq) -! -! where h'ap = hap + Siguma_k(runs inactive (and frozen) orbital)[(ap|kk)-(ak|kp)] -! -! Indices are restricted as t > v, x > z -! -! So the dimension of (xyz) is (norb**3+norb**2)/2 ! <= C1 case -! -! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= -! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= - - use four_caspt2_module - - Implicit NONE - - - complex*16, intent(out) :: v(ninact+nact+1:ninact+nact+nsec, ninact+1:ninact+nact, & - & ninact+1:ninact+nact, ninact+1:ninact+nact) - - real*8 :: dr, di, signkl - complex*16 :: cint1, cint2, term1, d - complex*16 :: effh(ninact+nact+1:ninact+nact+nsec,ninact+1:ninact+nact) - - integer :: i, j, k, l, kkr, lkr, count, dim(nsymrpa) - integer :: isym, sym - - integer,allocatable :: indt(:,:), indu(:,:), indv(:,:) - logical :: test - integer :: it, iu, iv, iw, ia, ip, iq, ir, ik - integer :: jt, ju, jv, jw, ja, jp, jq, jr, jk - integer :: i0 - - -!^~^~^~^~^~^~^~^~^~^~^~^~^~^~^~^~^~^~^~^~^~^~^~^~^~^~^~^~^~^~^~^~^~^~^~^~^~^~^~^~^~^~^~^~^~^~^~^~ -! V(a,t,u,v) = Siguma_p [h'ap - Siguma_w(aw|wp)]<0|EvuEtp|0> + Siguma_pqr<0|EvuEtrEpq|0>(ar|pq) -! -! All indices run active spinor space except below k(inactive). -! -! where h'ap = hap + Siguma_k(is oqqupied)[(ap|kk)-(ak|kp)] -! -! -! effh(a,p) = hap + Siguma_k(is oqqupied)[(ap|kk)-(ak|kp)] - Siguma_w(aw|wp) -! -! is calculated and stored in memory and after reading int2, take count in V(a,t,u,v) -! -! -!===============================================! -! Three types of integrals are stored Cint ! -! ! -! (ap|qr) = (32|22) TYPE 1 (includes (aw|wp) ) ! -! ! -! (ap|kk) = (32|11) TYPE 2 ! -! ! -! (ak|kp) = (31|12) TYPE 3 ! -!===============================================! -! -!^~^~^~^~^~^~^~^~^~^~^~^~^~^~^~^~^~^~^~^~^~^~^~^~^~^~^~^~^~^~^~^~^~^~^~^~^~^~^~^~^~^~^~^~^~^~^~^~ - - Call timing(date1, tsec1, date0, tsec0) - date1 = date0 - tsec1 = tsec0 - - v = 0.0d+00 - effh = 0.0d+00 - dim = 0 - - Allocate(indt (nact**3, nsymrpa)) - Allocate(indu (nact**3, nsymrpa)) - Allocate(indv (nact**3, nsymrpa)) - indt = 0 - indu = 0 - indv = 0 - dim = 0 - - Do isym = 1, nsymrpa - Do it = 1, nact - jt = it+ninact - Do iv = 1, nact - jv = iv + ninact - Do iu = 1, nact - ju = iu + ninact - - sym = MULTB2(irpmo(jv),nsymrpa+1) - sym = MULTB (irpmo(ju),sym) - sym = MULTB2(irpmo(jt),sym) - sym = MULTB (isym ,sym) -!Iwamuro modify -! write(*,*)"symA",sym - - if(nsymrpa==1.or.(nsymrpa/=1.and.sym == nsymrpa+1)) then - dim(isym) = dim(isym) + 1 - indt(dim(isym),isym) =it - indu(dim(isym),isym) =iu - indv(dim(isym),isym) =iv - endif - Enddo - Enddo - Enddo - Enddo - - Do isym = 1, nsymrpa - write(*,*)dim(isym),isym - Enddo - - - Do ia = 1, nsec - ja = ia+ninact+nact - Do it = 1, nact - jt = it+ninact - - Call tramo1(ja, jt, cint1) - - effh(ja, jt) = cint1 -! write(*,'("1int ",2I4,2E20.10)')ja,jt,effh(ja,jt) - - End do - End do - - - - - open(1, file ='C1int', status='old', form='unformatted') - - 30 read(1, err=10, end=20) i,j,k,l,cint2 ! (ij|kl) - -! write(*,'("TYPE 1 ",4I4,2E20.10)')i,j,k,l,cint2 - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! + Siguma_pqr<0|EvuEtrEpq|0>(ar|pq) -! -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - - isym = irpmo(i) ! i corresponds to a - Do i0 = 1, dim(isym) - it = indt(i0, isym) - iu = indu(i0, isym) - iv = indv(i0, isym) - jt = it + ninact - ju = iu + ninact - jv = iv + ninact - -! test =.FALSE. -! if(j==1.and.jt==3.and.ju==4.and.jv==8) test=.TRUE. - - Call dim3_density (iv, iu, it, j-ninact, k-ninact, l-ninact, dr, di) - d = DCMPLX(dr, di) - v(i, jt, ju, jv) = v(i, jt, ju, jv) + cint2*d - - -! if(test.and.ABS(d)>1.0d-10.and.AbS(cint2)>1.0d-10) & -! & write(*,'("3dim-2int2",6I4,2E20.10,4I4,2E20.10)') & -! &iv, iu, i-ninact, it, k-ninact, l-ninact, d, i,j,k,l,cint2 - - - Enddo - -! effh(a,p) = hap + Siguma_k(is oqqupied)[(ap|kk)-(ak|kp)] - Siguma_w(aw|wp) -! ~~~~~~~~~~~~~~~~~~~ - if(j == k) then - effh(i,l) = effh(i,l) - cint2 - endif - - goto 30 - - 20 close(1) - write(*,*)'reading C1int2 is over' - - - open(1, file ='C2int', status='old', form='unformatted') ! TYPE 2 integrals - - 300 read(1, err=10, end=200) i,j,k,l,cint2 - -! write(*,'("TYPE 2 ",4I4,2E20.10)')i,j,k,l,cint2 -! -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! effh(a,p) = hap + Siguma_k(is oqqupied)[(ap|kk)-(ak|kp)] - Siguma_w(aw|wp) -! ======== -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - - if(k==l) then - - effh(i,j) = effh(i,j) + cint2 - - endif - - goto 300 - - 200 close(1) - write(*,*)'reading C2int2 is over' - - - open(1, file ='C3int', status='old', form='unformatted') ! TYPE 3 integrals - - 3000 read(1, err=10, end=2000) i,j,k,l,cint2 ! (ij|kl):=> (ak|kp) - -! write(*,'("TYPE 3 ",4I4,2E20.10)')i,j,k,l,cint2 -! -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! effh(a,p) = hap + Siguma_k(is oqqupied)[(ap|kk)-(ak|kp)] - Siguma_w(aw|wp) -! ========= -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - if(j==k) then - - effh(i,l) = effh(i,l) - cint2 - - endif - - goto 3000 - - 2000 close(1) - write(*,*)'reading C3int2 is over' - - -! Siguma_p effh(a,p)<0|EvuEtp|0> - - Do ia = 1, nsec - ja = ia+ninact+nact -! write(*,'("effh ",2I4,2E20.10)')ja, jp, effh(ja,jp) - - isym = irpmo(ja) - - Do ip = 1, nact - jp = ip + ninact - -! write(*,'("effh ",2I4,2E20.10)')ja,jp,effh(ja,jp) - if(ABS(effh(ja, jp)) < 1.0d-10) goto 70 - - Do i0 = 1, dim(isym) - it = indt(i0, isym) - iu = indu(i0, isym) - iv = indv(i0, isym) - jt = it + ninact - ju = iu + ninact - jv = iv + ninact - - Call dim2_density (iv, iu, it, ip, dr, di) - d = DCMPLX(dr, di) - - - v(ja, jt, ju, jv) = v(ja, jt, ju, jv) + effh(ja,jp)*d - - End do !i0 - - 70 End do !ip - End do !ia - - - goto 101 - - - 10 write(*,*) 'error while opening file Cint' ; goto 101 - - 101 write(*,*)'vCmat_ord is ended' - - deallocate(indt) - deallocate(indu) - deallocate(indv) - - Call timing(date1, tsec1, date0, tsec0) - date1 = date0 - tsec1 = tsec0 - - - end subroutine vCmat_ord diff --git a/src/solvall_C_ord_ty.f90 b/src/solvall_C_ord_ty.f90 index ef64f62a..8f30bf16 100644 --- a/src/solvall_C_ord_ty.f90 +++ b/src/solvall_C_ord_ty.f90 @@ -516,6 +516,7 @@ SUBROUTINE vCmat_ord_ty(v) ! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= use four_caspt2_module + use module_file_manager Implicit NONE #ifdef HAVE_MPI @@ -529,10 +530,11 @@ SUBROUTINE vCmat_ord_ty(v) integer :: isym, syma, symb, symc integer, allocatable :: indt(:, :), indu(:, :), indv(:, :) integer :: it, iu, iv, ia, ip - integer :: jt, ju, jv, ja, jp - integer :: i0, iostat + integer :: jt, ju, jv, ja + integer :: i0, iostat, twoint_unit integer :: datetmp0, datetmp1 real(8) :: tsectmp0, tsectmp1 + logical :: is_end_of_file !^~^~^~^~^~^~^~^~^~^~^~^~^~^~^~^~^~^~^~^~^~^~^~^~^~^~^~^~^~^~^~^~^~^~^~^~^~^~^~^~^~^~^~^~^~^~^~^~ ! V(a,t,u,v) = Siguma_p [h'ap - Siguma_w(aw|wp)]<0|EvuEtp|0> + Siguma_pqr<0|EvuEtrEpq|0>(ar|pq) ! @@ -566,6 +568,7 @@ SUBROUTINE vCmat_ord_ty(v) v = 0.0d+00 effh = 0.0d+00 dim = 0 + twoint_unit = default_unit Allocate (indt(nact**3, nsymrpa)) Allocate (indu(nact**3, nsymrpa)) @@ -584,7 +587,6 @@ SUBROUTINE vCmat_ord_ty(v) ju = iu + ninact ! EatEuv|0> - ! if((it == iv).and.(iu/=iv)) goto 100 syma = MULTB_D(irpmo(ju), irpmo(jv)) symb = MULTB_D(isym, irpmo(jt)) @@ -619,17 +621,12 @@ SUBROUTINE vCmat_ord_ty(v) End do End do !$OMP end parallel do - open (1, file=c1int, status='old', form='unformatted') - + call open_unformatted_file(unit=twoint_unit, file=c1int, status='old', optional_action='read') do ! Read TYPE 1 integrals C1int until EOF - read (1, iostat=iostat) i, j, k, l, cint2 ! (ij|kl) - ! Exit loop if the iostat is less than 0 (End of File) - if (iostat < 0) then - if (rank == 0) print *, 'End of C1int' + read (twoint_unit, iostat=iostat) i, j, k, l, cint2 ! (ij|kl) + call check_iostat(iostat=iostat, file=c1int, end_of_file_reached=is_end_of_file) + if (is_end_of_file) then exit - else if (iostat > 0) then - ! Stop the program if the iostat is greater than 0 - stop 'Error: Error in reading C1int' end if !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ! + Siguma_pqr<0|EvuEtrEpq|0>(ar|pq) @@ -655,25 +652,19 @@ SUBROUTINE vCmat_ord_ty(v) effh(i, l) = effh(i, l) - cint2 end if end do - - close (1) + close (twoint_unit) if (rank == 0) print *, 'reading C1int2 is over' + Call timing(datetmp1, tsectmp1, datetmp0, tsectmp0) datetmp1 = datetmp0 tsectmp1 = tsectmp0 - open (1, file=c2int, status='old', form='unformatted') ! TYPE 2 integrals + call open_unformatted_file(unit=twoint_unit, file=c2int, status='old', optional_action='read') do ! Read TYPE 2 integrals C2int until EOF - read (1, iostat=iostat) i, j, k, l, cint2 - ! Exit loop if the iostat is less than 0 (End of File) - if (iostat < 0) then - if (rank == 0) then - print *, 'End of C2int' - end if + read (twoint_unit, iostat=iostat) i, j, k, l, cint2 + call check_iostat(iostat=iostat, file=c2int, end_of_file_reached=is_end_of_file) + if (is_end_of_file) then exit - else if (iostat > 0) then - ! Stop the program if the iostat is greater than 0 - stop 'Error: Error in reading C2int' end if ! !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -687,26 +678,19 @@ SUBROUTINE vCmat_ord_ty(v) end if end do + close (twoint_unit) - close (1) if (rank == 0) print *, 'reading C2int2 is over' Call timing(datetmp1, tsectmp1, datetmp0, tsectmp0) datetmp1 = datetmp0 tsectmp1 = tsectmp0 - open (1, file=c3int, status='old', form='unformatted') ! TYPE 3 integrals - + call open_unformatted_file(unit=twoint_unit, file=c3int, status='old', optional_action='read') ! TYPE 3 integrals do ! Read TYPE 3 integrals C3int until EOF - read (1, iostat=iostat) i, j, k, l, cint2 ! (ij|kl):=> (ak|kp) - ! Exit loop if the iostat is less than 0 (End of File) - if (iostat < 0) then - if (rank == 0) then - print *, 'End of C3int' - end if + read (twoint_unit, iostat=iostat) i, j, k, l, cint2 ! (ij|kl):=> (ak|kp) + call check_iostat(iostat=iostat, file=c3int, end_of_file_reached=is_end_of_file) + if (is_end_of_file) then exit - else if (iostat > 0) then - ! Stop the program if the iostat is greater than 0 - stop 'Error: Error in reading C3int' end if ! !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -720,11 +704,13 @@ SUBROUTINE vCmat_ord_ty(v) end if end do - close (1) + close (twoint_unit) + if (rank == 0) print *, 'reading C3int2 is over' Call timing(datetmp1, tsectmp1, datetmp0, tsectmp0) datetmp1 = datetmp0 tsectmp1 = tsectmp0 + #ifdef HAVE_MPI call MPI_Allreduce(MPI_IN_PLACE, effh(1, 1), nsec*nact, MPI_COMPLEX16, MPI_SUM, MPI_COMM_WORLD, ierr) #endif diff --git a/src/solvall_D_ord.f90 b/src/solvall_D_ord.f90 deleted file mode 100644 index 92fc9e30..00000000 --- a/src/solvall_D_ord.f90 +++ /dev/null @@ -1,666 +0,0 @@ -! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= -! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= - - SUBROUTINE solvD_ord (e0, e2d) - -! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= -! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= - - use four_caspt2_module - - Implicit NONE - - real*8, intent(in) :: e0 - real*8, intent(out):: e2d - - - - integer :: dimn, dimm, count, dammy - - integer, allocatable :: indsym(:,:) - - real*8, allocatable :: sr(:,:), ur(:,:) - real*8, allocatable :: br(:,:), wsnew(:), ws(:), wb(:) - real*8, allocatable :: br0(:,:), br1(:,:) - real*8 :: e2(nsymrpa*2), e, alpha - - - complex*16, allocatable :: sc(:,:), uc(:,:), sc0(:,:) - complex*16, allocatable :: bc(:,:) - complex*16, allocatable :: bc0(:,:), bc1(:,:), v(:,:,:), vc(:), vc1(:) - - integer, allocatable :: ia0(:), ii0(:), iai(:,:) - integer :: nai - - logical :: cutoff - integer :: j, i, k, syma, isym, i0, j0 - integer :: ia, it, ii, iu - integer :: ja, jt, ji, ju - - - real*8 :: thresd - -! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= -! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= - -! SPACE D IS NOW CALCULATED -! -! EaiEtu|0> -! -! DRAS1 = -1 DRAS2 = 0 DRAS3 = +1 -! -! t and u run all active spinor space independently! -! -! -! S(bjxy,aitu) = d(ba)d(ij)<0|EyxEtu|0> -! -! S(xy, tu) = <0|EyxEtu|0> -! -! B(xy,tu) = Siguma_w [eps(w)<0|EyxEtuEww|0>+S(xy,tu)(eps(t)-eps(u))] -! -! a(a,i) = eps(a) - eps(i) - e0 -! -!! dame!! V(a,i) = SIGUMA_pq:active <0|EutEpq|0>{(ai|pq) - (aq|pi)} -!! dame!! -!! dame!! + <0|Eut|0>[hai +{ SIGUMA_k:inactive(ai|kk) + SIGUMA_p:active(ap|pi)}] -! -! -! V(a,i) = SIGUMA_pq:active <0|EutEpq|0>{(ai|pq) - (aq|pi)} -! -! + <0|Eut|0>[hai +{ SIGUMA_k:inactive(ai|kk) - (ak|ki) } -! -! -! E2 = SIGUMA_a,i, dimm |V1(dimm,ai)|^2|/{(alpha(ai) + wb(dimm)} - - -! thresd = thres - thresd = 1.0D-08 - thres = 1.0D-08 - - e2 = 0.0d+00 - e2d = 0.0d+00 - dimn = 0 - syma = 0 - - write(*,*)' ENTER solv D part' - write(*,*)' nsymrpa', nsymrpa - - - i0 = 0 - Do ia = 1, nsec - Do ii = 1, ninact - i0 = i0 + 1 - End do - End do - - nai = i0 - Allocate(iai(ninact+nact+1:ninact+nact+nsec,ninact)) - iai = 0 - Allocate(ia0(nai)) - Allocate(ii0(nai)) - - i0 = 0 - Do ia = 1, nsec - ja = ia + ninact+nact - Do ii = 1, ninact - i0 = i0 + 1 - iai(ja, ii) = i0 - ia0(i0) = ja - ii0(i0) = ii - End do - End do - Allocate(v(nai, ninact+1:ninact+nact, ninact+1:ninact+nact)) - v = 0.0d+00 - - Call vDmat_ord (nai, iai, v) - - write(*,*)'come' - - - - Do isym = nsymrpa+1, 2*nsymrpa - - dimn = 0 - Do it = 1, nact - jt = it + ninact - Do iu = 1, nact - ju = iu + ninact - - syma = nsymrpa + 1 - syma = MULTB ( irpmo(jt), syma) - syma = MULTB2( irpmo(ju), syma) - - if (nsymrpa == 1 .or. (nsymrpa /=1 .and. syma == isym)) then - dimn = dimn + 1 - End if - 100 End do ! iu - End do ! it - -! write(*,*)'isym, dimn',isym, dimn - - If(dimn == 0) goto 1000 - - Allocate(indsym(2, dimn)) - indsym = 0 - dimn = 0 - - Do it = 1, nact - jt = it + ninact - Do iu = 1, nact - ju = iu + ninact - - syma = nsymrpa + 1 - syma = MULTB ( irpmo(jt), syma) - syma = MULTB2( irpmo(ju), syma) - - if (nsymrpa == 1 .or. (nsymrpa /=1 .and. syma == isym)) then - dimn = dimn + 1 - indsym(1,dimn) = it - indsym(2,dimn) = iu - End if - 200 End do ! iu - End do ! it - - - Allocate(sc(dimn,dimn)) - sc = 0.0d+00 ! sc N*N - - Call sDmat (dimn, indsym, sc) -! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - - write(*,*)'sc matrix is obtained normally' - Allocate(ws(dimn)) - ws = 0.0d+00 - cutoff = .TRUE. - thresd = 1.0d-08 -! thresd = 1.0d-15 - - Allocate(sc0(dimn,dimn)) - sc0 = sc - - Call cdiag (sc, dimn, dimm, ws, thresd, cutoff) -! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - write(*,*)'after s cdiag' -! Do i0 = 1, dimn -! write(*,'(E20.10)') ws(i0) -! End do - - If(dimm == 0) then - deallocate(indsym) - deallocate(sc0) - deallocate(sc) - deallocate(ws) - goto 1000 - Endif - - - If (debug) then - - write(*,*)'Check whether U*SU is diagonal' - - Call checkdgc(dimn, sc0, sc, ws) -! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - write(*,*)'Check whether U*SU is diagonal END' - - End if - - Allocate(bc(dimn,dimn)) ! bc N*N - bc = 0.0d+00 - - Call bDmat (dimn, sc0, indsym, bc) -! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - - write(*,*)'bc matrix is obtained normally' - - - deallocate (sc0) - - write(*,*)'OK cdiag',dimn,dimm - - Allocate(uc(dimn,dimm)) ! uc N*M - Allocate(wsnew(dimm)) ! wnew M - uc(:,:) = 0.0d+00 - wsnew(:) = 0.0d+00 - - Call ccutoff (sc, ws, dimn, dimm, uc, wsnew) -! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - write(*,*)'OK ccutoff' - deallocate (ws) - deallocate (sc) - - Call ucramda_s_half (uc, wsnew, dimn, dimm) ! uc N*M matrix rewritten as uramda^(-1/2) -! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - deallocate(wsnew) - - write(*,*)'ucrams half OK' - Allocate(bc0(dimm, dimn)) ! bc0 M*N - bc0 = 0.0d+00 - bc0 = MATMUL(TRANSPOSE(DCONJG(uc)), bc) - Allocate(bc1(dimm, dimm)) ! bc1 M*M - bc1 = 0.0d+00 - bc1 = MATMUL(bc0, uc) - - IF (debug) then - - write(*,*)'Check whether bc1 is hermite or not' - Do i = 1, dimm - Do j = i, dimm - if(ABS(bc1(i,j)-DCONJG(bc1(j,i))) > 1.0d-6) then - write(*,'(2I4,2E15.7)')i,j,bc1(i,j)-bc1(j,i) - End if - End do - End do - write(*,*)'Check whether bc1 is hermite or not END' - - End if - - deallocate (bc) - deallocate (bc0) - - cutoff = .FALSE. - - Allocate(wb(dimm)) - wb = 0.0d+00 - - write(*,*)'bC matrix is transrated to bc1(M*M matrix)!' - - Allocate(bc0(dimm,dimm)) - bc0 = bc1 - - Call cdiag(bc1, dimm, dammy, wb, thresd, cutoff) -! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - If(debug) then - - write(*,*)'Check whether bc is really diagonalized or not' - - Call checkdgc(dimm, bc0, bc1, wb) -! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - write(*,*)'Check whether bc is really diagonalized or not END' - End if - - deallocate(bc0) - - write(*,*)'bC1 matrix is diagonalized!' - - e2 = 0.0d+00 - Do i0 = 1, nai - ja = ia0(i0) - ji = ii0(i0) - - syma = isym - syma = MULTB2(irpmo(ji), syma) - syma = MULTB (irpmo(ja), syma) - - If(nsymrpa==1.or.(nsymrpa/=1.and.(syma == nsymrpa + 1))) then - - - Allocate(vc(dimn)) - Do it = 1, dimn - vc(it) = v(i0,indsym(1,it)+ninact,indsym(2,it)+ninact) - Enddo - - Allocate(vc1(dimm)) - - vc1(1:dimm) = MATMUL(TRANSPOSE(DCONJG(uc(1:dimn,1:dimm))),vc(1:dimn)) - Deallocate (vc) - - alpha = + eps(ja) - eps(ji) - e0 + eshift ! For Level Shift (2007/2/9) - - vc1(1:dimm) = MATMUL(TRANSPOSE(DCONJG(bc1(1:dimm,1:dimm))),vc1(1:dimm)) - - Do j = 1, dimm - sumc2local = sumc2local + (ABS(vc1(j))**2.0d+00)/((alpha+wb(j))**2.0d+00) - e = (ABS(vc1(j))**2.0d+00)/(alpha+wb(j)) - e2(isym) = e2(isym) - e - End do - - deallocate(vc1) - - End if - - End do !i0 - - - deallocate(indsym) - deallocate(uc) - deallocate(wb) - Deallocate (bc1) - - 1000 write(*,'("e2d(",I3,") = ",E20.10,"a.u.")')isym,e2(isym) - e2d = e2d + e2(isym) - - - End do ! isym - - write(*,'("e2d = ",E20.10,"a.u.")')e2d - - write(*,'("sumc2,d = ",E20.10)')sumc2local - sumc2 = sumc2 + sumc2local - - deallocate(iai) - deallocate(ia0) - deallocate(ii0) - deallocate(v) - - continue - write(*,*)'end solvD_ord' - end - - - - - -! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= -! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= - - SUBROUTINE sDmat(dimn, indsym, sc) ! Assume C1 molecule, overlap matrix S in space D - -! S(xy, tu) = <0|EyxEtu|0> -! -! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= -! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= - - use four_caspt2_module - - Implicit NONE - - integer, intent(in) :: dimn, indsym(2, dimn) - complex*16, intent(out) :: sc(dimn,dimn) - - real*8 :: a,b - - integer :: it, iu, iy, ix, ivx, itu - integer :: i, j - integer :: count - - - - sc = 0.0d+00 - - Do i = 1, dimn - - ix = indsym(1,i) - iy = indsym(2,i) - Do j = i, dimn - - it = indsym(1,j) - iu = indsym(2,j) - - a = 0.0d+0 - b = 0.0d+0 - Call dim2_density (iy, ix, it, iu, a,b) - sc(i,j) = DCMPLX(a,b) - sc(j,i) = DCONJG(sc(i,j)) - -! If(ABS(sc(i,j)) > 1.0d+00) then -! write(*,'(2I4,2E20.10)')i,j,sc(i,j) -! Endif - - End do !j - End do !i - - End subroutine sDmat - - - -! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= -! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= - - SUBROUTINE bDmat (dimn, sc, indsym, bc) ! Assume C1 molecule, overlap matrix B in space D -! -! B(xy,tu) = Siguma_w [eps(w)<0|EyxEtuEww|0>+S(xy,tu)(eps(t)-eps(u))] -! -! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= -! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= - - use four_caspt2_module - - Implicit NONE - - integer, intent(in) :: dimn, indsym(2,dimn) - complex*16, intent(in) :: sc(dimn,dimn) - complex*16, intent(out) :: bc(dimn,dimn) - - real*8 :: e, denr, deni - complex*16 :: den - - integer :: it, iu, iv, ix, iy, iz, iw - integer :: jt, ju, jy, jx, jw, i, j - - - bc(:,:) = 0.0d+00 - - write(*,*)'F space Bmat iroot=',iroot - - Do i = 1, dimn - - ix = indsym(1,i) - jx = ix + ninact - iy = indsym(2,i) - jy = iy + ninact - - Do j = i, dimn - - it = indsym(1,j) - jt = it + ninact - iu = indsym(2,j) - ju = iu + ninact - -! B(xy,tu) = Siguma_w [eps(w)<0|EyxEtuEww|0>+S(xy,tu)(eps(t)-eps(u))] - - - e = eps(jt) - eps(ju) - - Do iw = 1, nact - jw = iw + ninact - - Call dim3_density & - (iy, ix, it, iu, iw, iw, denr, deni) - den = DCMPLX(denr, deni) - bc(i,j) = bc(i,j) + den*eps(jw) - - End do - - bc(i, j) = bc(i, j) + sc(i, j)*e - - bc(j, i) = DCONJG(bc(i, j)) - - - End do !i - End do !j - - - write(*,*)'bDmat is ended' - - End subroutine bDmat - - - -! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= -! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= -! - SUBROUTINE vDmat_ord (nai, iai, v) -! -! -! V(a,i) = SIGUMA_pq:active <0|EutEpq|0>{(ai|pq) - (aq|pi)} -! -! + <0|Eut|0>[hai +{ SIGUMA_k:inactive(ai|kk) - (ak|ki)}] -! -! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= -! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= - - use four_caspt2_module - - Implicit NONE - - - integer, intent(in) :: nai, iai(ninact+nact+1:ninact+nact+nsec,ninact) - - complex*16, intent(out) :: v(nai,ninact+1:ninact+nact,ninact+1:ninact+nact) - - real*8 :: dr, di, signkl - complex*16 :: cint1, cint2, dens, d - complex*16 :: effh(ninact+nact+1:ninact+nact+nsec,ninact) - - integer :: i, j, k, l, tai, ip, iq, save, count - integer :: it, jt, ju, iu, ia, ii, ja, ji, kkr, lkr - logical :: test - - - v = 0.0d+00 - effh = 0.0d+00 - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! V(tai, jt, ju) = SIGUMA_pq:active <0|EutEpq|0>{(ai|pq) - (aq|pi)} -! -! + <0|Eut|0>[hai +{ SIGUMA_k:inactive(ai|kk) - (ak|ki)}] -! -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! - - Do ia = 1, nsec - ja = ia + ninact + nact - Do ii = 1, ninact - ji = ii - Call tramo1(ja, ji, cint1) - effh(ja,ji) = cint1 -! if(ja==19.and.ji==1) write(*,'("effh int1 ",2I4,2E20.10)')ja,ji,cint1 - End do - End do - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! V(a,i, jt, ju) = SIGUMA_pq:active <0|EutEpq|0>{(ai|pq) - (aq|pi)} -! -! + <0|Eut|0>[hai +{ SIGUMA_k:inactive(ai|kk) - (ak|ki)}] -! -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Three types of integrals are stored -! -! (31|22) stored (ai|pq) ...TYPE 1 D1int -! (32|21) stored (ap|qi) ...TYPE 2 D2int -! -! (31|11) stored (ai|jk) ...TYPE 3 D3int -! -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - - - open(1, file ='D1int', status='old', form='unformatted') - - 30 read(1, err=10, end=20) i,j,k,l,cint2 ! (ij|kl) - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! V(a,i, jt, ju) = SIGUMA_pq:active <0|EutEpq|0>{(ai|pq) - (aq|pi)} -! -! + <0|Eut|0>[hai +{ SIGUMA_k:inactive(ai|kk) - (ak|ki)}] -! -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - ja = i - ji = j - tai = iai(ja, ji) -! write(*,'("type1 (31|22)",4I4,2E20.10)')i,j,k,l,cint2 - - Do it = 1, nact - jt = it + ninact - Do iu = 1, nact - ju = iu + ninact - - Call dim2_density (iu, it, k-ninact, l-ninact, dr, di) - d = DCMPLX(dr, di) - v(tai, jt, ju) = v(tai, jt, ju) + d*cint2 - - End do - Enddo - - goto 30 - 20 close(1) - write(*,*)'reading D2int2 is over' - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! V(a,i, jt, ju) = SIGUMA_pq:active <0|EutEpq|0>{(ai|pq) - (aq|pi)} -! -! + <0|Eut|0>[hai +{ SIGUMA_k:inactive(ai|kk) - (ak|ki)}] -! -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - - open(1, file ='D2int', status='old', form='unformatted') - - 31 read(1, err=10, end=21) i,j,k,l,cint2 ! (ij|kl) - ja = i - ji = l - tai = iai(ja, ji) - - Do it = 1, nact - jt = it + ninact - Do iu = 1, nact - ju = iu + ninact - - Call dim2_density (iu, it, k-ninact, j-ninact, dr, di) - d = DCMPLX(dr, di) - - v(tai, jt, ju) = v(tai, jt, ju) - d*cint2 - - End do - Enddo - - goto 31 - - 21 close(1) - write(*,*)'reading D2int2 is over' - - open(1, file ='D3int', status='old', form='unformatted') ! (ai|jk) is stored - - 300 read(1, err=10, end=200) i,j,k,l,cint2 ! (ij|kl) -! write(*,*)'D1int', i,j,k,l ,cint2 - - if(j/=k.and.k==l) then !(ai|kk) - - effh(i,j) = effh(i,j) + cint2 - - elseif(j==k.and.k/=l)then !(ak|ki) - - effh(i,l) = effh(i,l) - cint2 - - endif - - goto 300 - - - 200 close(1) - write(*,*)'reading D3int2 is over' - - - - Do ia = 1, nsec - ja = ia + ninact + nact - Do ii = 1, ninact - ji = ii - tai = iai(ja, ji) -! if(ABS(effh(ja,ji)) > 1.0d-10) write(*,'("effh ",2I4,2E20.10)')ja,ji,effh(ja,ji) - - Do it = 1, nact - jt = it + ninact - Do iu = 1, nact - ju = iu + ninact - - Call dim1_density (iu, it, dr, di) - - d= DCMPLX(dr, di) - v(tai, jt, ju) = v(tai, jt, ju) + effh(ja,ji)*d - Enddo - Enddo - - Enddo - Enddo - - goto 100 - - 10 write(*,*) 'error while opening file Dint' ; goto 100 - - 100 write(*,*)'vDmat_ord is ended' - - - end subroutine vDmat_ord - - - diff --git a/src/solvall_D_ord_ty.f90 b/src/solvall_D_ord_ty.f90 index de5c90be..5e752572 100644 --- a/src/solvall_D_ord_ty.f90 +++ b/src/solvall_D_ord_ty.f90 @@ -508,6 +508,7 @@ SUBROUTINE vDmat_ord_ty(nai, iai, v) ! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= use four_caspt2_module + use module_file_manager Implicit NONE #ifdef HAVE_MPI @@ -518,10 +519,11 @@ SUBROUTINE vDmat_ord_ty(nai, iai, v) real*8 :: dr, di complex*16 :: cint1, cint2, d complex*16 :: effh(nsec, ninact) - integer :: i, j, k, l, tai, iostat + integer :: i, j, k, l, tai, iostat, twoint_unit integer :: it, jt, ju, iu, ia, ii, ja, ji integer :: datetmp0, datetmp1 real(8) :: tsectmp0, tsectmp1 + logical :: is_end_of_file if (rank == 0) print *, 'Enter vDmat. Please ignore timer under this line.' datetmp1 = date0; datetmp0 = date0 @@ -529,6 +531,7 @@ SUBROUTINE vDmat_ord_ty(nai, iai, v) tsectmp1 = tsectmp0 v = 0.0d+00 effh = 0.0d+00 + twoint_unit = default_unit !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ! V(tai, jt, ju) = SIGUMA_pq:active <0|EutEpq|0>{(ai|pq) - (aq|pi)} @@ -567,16 +570,13 @@ SUBROUTINE vDmat_ord_ty(nai, iai, v) Call timing(datetmp1, tsectmp1, datetmp0, tsectmp0) datetmp1 = datetmp0 tsectmp1 = tsectmp0 - open (1, file=d1int, status='old', form='unformatted') + + call open_unformatted_file(unit=twoint_unit, file=d1int, status='old', optional_action='read') do - read (1, iostat=iostat) i, j, k, l, cint2 ! (ij|kl) - ! Exit the loop if the end of the file is reached - if (iostat < 0) then - if (rank == 0) print *, 'End of D1int' + read (twoint_unit, iostat=iostat) i, j, k, l, cint2 ! (ij|kl) + call check_iostat(iostat=iostat, file=d1int, end_of_file_reached=is_end_of_file) + if (is_end_of_file) then exit - else if (iostat > 0) then - ! If iostat is greater than 0, error detected in the input file, so exit the program - stop 'Error: Error in reading D1int' end if !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -603,7 +603,8 @@ SUBROUTINE vDmat_ord_ty(nai, iai, v) End do !$OMP end parallel do end do - close (1) + close (twoint_unit) + if (rank == 0) print *, 'reading D1int2 is over' !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ! V(a,i, jt, ju) = SIGUMA_pq:active <0|EutEpq|0>{(ai|pq) - (aq|pi)} @@ -616,16 +617,13 @@ SUBROUTINE vDmat_ord_ty(nai, iai, v) Call timing(datetmp1, tsectmp1, datetmp0, tsectmp0) datetmp1 = datetmp0 tsectmp1 = tsectmp0 - open (1, file=d2int, status='old', form='unformatted') + + call open_unformatted_file(unit=twoint_unit, file=d2int, status='old', optional_action='read') do - read (1, iostat=iostat) i, j, k, l, cint2 ! (ij|kl) - ! Exit the loop if the end of the file is reached - if (iostat < 0) then - if (rank == 0) print *, 'End of D2int' + read (twoint_unit, iostat=iostat) i, j, k, l, cint2 ! (ij|kl) + call check_iostat(iostat=iostat, file=d2int, end_of_file_reached=is_end_of_file) + if (is_end_of_file) then exit - else if (iostat > 0) then - ! If iostat is greater than 0, error detected in the input file, so exit the program - stop 'Error: Error in reading D2int' end if ja = i @@ -644,24 +642,22 @@ SUBROUTINE vDmat_ord_ty(nai, iai, v) End do !$OMP end parallel do end do + close (twoint_unit) - close (1) - if (rank == 0) print *, 'reading D2int2 is over' - if (rank == 0) print *, 'before d3int' + if (rank == 0) then + print *, 'reading D2int2 is over' + print *, 'before d3int' + end if Call timing(datetmp1, tsectmp1, datetmp0, tsectmp0) datetmp1 = datetmp0 tsectmp1 = tsectmp0 - open (1, file=d3int, status='old', form='unformatted') ! (ai|jk) is stored - do - read (1, iostat=iostat) i, j, k, l, cint2 ! (ij|kl) - ! Exit the loop if the end of the file is reached - if (iostat < 0) then - if (rank == 0) print *, 'End of D3int' + call open_unformatted_file(unit=twoint_unit, file=d3int, status='old', optional_action='read') ! (ai|jk) is stored + do + read (twoint_unit, iostat=iostat) i, j, k, l, cint2 ! (ij|kl) + call check_iostat(iostat=iostat, file=d3int, end_of_file_reached=is_end_of_file) + if (is_end_of_file) then exit - else if (iostat > 0) then - ! If iostat is greater than 0, error detected in the input file, so exit the program - stop 'Error: Error in reading D3int' end if if (j /= k .and. k == l) then !(ai|kk) @@ -674,10 +670,9 @@ SUBROUTINE vDmat_ord_ty(nai, iai, v) end if end do + close (twoint_unit) - close (1) if (rank == 0) print *, 'reading D3int2 is over' - if (rank == 0) print *, 'end d3int' Call timing(datetmp1, tsectmp1, datetmp0, tsectmp0) datetmp1 = datetmp0 tsectmp1 = tsectmp0 diff --git a/src/solvall_E_ord.f90 b/src/solvall_E_ord.f90 deleted file mode 100644 index 0584680d..00000000 --- a/src/solvall_E_ord.f90 +++ /dev/null @@ -1,551 +0,0 @@ -! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= -! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= - - SUBROUTINE solvE_ord (e0, e2e) - -! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= -! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= - - use four_caspt2_module - - Implicit NONE - - real*8, intent(in) :: e0 - real*8, intent(out):: e2e - - - - integer :: dimn, dimm, count, dammy - - integer, allocatable :: indsym(:,:) - - real*8, allocatable :: sr(:,:), ur(:,:) - real*8, allocatable :: br(:,:), wsnew(:), ws(:), wb(:) - real*8, allocatable :: br0(:,:), br1(:,:) - real*8 :: e2(2*nsymrpa), alpha, e - - - complex*16, allocatable :: sc(:,:), uc(:,:), sc0(:,:) - complex*16, allocatable :: bc(:,:) - complex*16, allocatable :: bc0(:,:), bc1(:,:), v(:,:), vc(:), vc1(:) - - logical :: cutoff - integer :: j, i, k, syma, isym, indt(1:nact) - integer :: ia, it, ij, ii, ja, jt, jj, ji - - integer :: i0 - integer, allocatable :: ia0(:), ii0(:), ij0(:), iaij(:,:,:) - integer :: naij - - real*8 :: thresd - -! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= -! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= - -! SPACE E IS NOW CALCULATED -! -! EtiEaj|0> -! -! DRAS1 =-2 DRAS2 = +1 DRAS3 = +1 -! -! i > j -! -! S(ukbl,tiaj) = d(ki) d(lj) d(ba) [d(ut) - <0|Etu|0>] <= S(u,t) -! ~~~~~~~~~~~~~~~~~~~ -! S(u,t) = d(ut) - <0|Etu|0> -! -! B(u,t) = Siguma_w [eps(w){d(tu)<0|Eww|0>-<0|EtuEww|0>}] + S(u,t)eps(t) -! -! = - Siguma_w [eps(w)<0|EtuEww|0>] + d(tu)e0 + S(u,t)eps(t) -! -! alpha(i,j,a) = -eps(i) - eps(j) + eps(a) - e0 -! -! where -! -! e0 = Siguma_w [eps(w)<0|Eww|0>] (<== calculated as e0 in calce0.f) -! -! V(t,ija) =[SIGUMA_p:active <0|Ept|0>{(ai|pj) - (aj|pi)}] + (aj|ti) - (ai|tj) -! -! E2 = SIGUMA_iab, dimm |V1(t,ija)|^2|/{(alpha(ija) + wb(t)} -! -! thresd = thres - thresd = 1.0D-08 - thres = 1.0D-08 - - e2 = 0.0d+00 - e2e= 0.0d+00 - dimn = 0 - syma = 0 - indt=0 - write(*,*)' ENTER solv E part' - write(*,*)' nsymrpa', nsymrpa - - i0 = 0 - Do ia = 1, nsec - Do ii = 1, ninact - Do ij = 1, ii-1 ! i > j - i0 = i0 + 1 - End do - End do - End do - - naij = i0 - Allocate(iaij(ninact+nact+1:ninact+nact+nsec,1:ninact,1:ninact)) - iaij = 0 - Allocate(ia0(naij)) - Allocate(ii0(naij)) - Allocate(ij0(naij)) - - i0 = 0 - Do ia = 1, nsec - ja = ia+ninact+nact - Do ii = 1, ninact - ji = ii - Do ij = 1, ii-1 ! i > j - jj = ij - i0 = i0 + 1 - iaij(ja, ji, jj) = i0 - iaij(ja, jj, ji) = i0 - ia0(i0) = ja - ii0(i0) = ji - ij0(i0) = jj - End do - End do - End do - - Allocate(v(naij, ninact+1:ninact+nact)) - v = 0.0d+00 - - Call vEmat_ord (naij, iaij, v) - write(*,*)'come' - - - - Do isym = 1, nsymrpa - - dimn = 0 - Do it = 1, nact - jt = it + ninact - if (irpmo(jt) == isym) then - dimn = dimn + 1 - indt(dimn) = it - End if - End do ! it - - write(*,*)'isym, dimn',isym, dimn - - If(dimn == 0) goto 1000 - - Allocate(sc(dimn,dimn)) - sc = 0.0d+00 ! sc N*N - - Call sEmat (dimn, indt(1:dimn), sc) -! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - - write(*,*)'sc matrix is obtained normally' - - Allocate(ws(dimn)) - - cutoff = .TRUE. -! thresd = 1.0d-15 - - Allocate(sc0(dimn,dimn)) - sc0 = sc - - Call cdiag (sc, dimn, dimm, ws, thresd, cutoff) -! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - write(*,*)'after s cdiag, new dimension is', dimm - - If(dimm == 0) then - deallocate(sc0) - deallocate(sc) - deallocate(ws) - goto 1000 - Endif - - If(debug) then - - write(*,*)'Check whether U*SU is diagonal' - - Call checkdgc(dimn, sc0, sc, ws) -! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - write(*,*)'Check whether U*SU is diagonal END' - - End if - - Allocate(bc(dimn,dimn)) ! bc N*N - bc = 0.0d+00 - - Call bEmat (e0, dimn, sc0, indt(1:dimn), bc) -! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - write(*,*)'bc matrix is obtained normally' - - - deallocate (sc0) - - write(*,*)'OK cdiag',dimn,dimm - - Allocate(uc(dimn,dimm)) ! uc N*M - Allocate(wsnew(dimm)) ! wnew M - uc(:,:) = 0.0d+00 - wsnew(:) = 0.0d+00 - - Call ccutoff (sc, ws, dimn, dimm, uc, wsnew) -! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - write(*,*)'OK ccutoff' - deallocate (ws) - deallocate (sc) - - Call ucramda_s_half (uc, wsnew, dimn, dimm) ! uc N*M matrix rewritten as uramda^(-1/2) -! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - deallocate(wsnew) - - write(*,*)'ucrams half OK' - Allocate(bc0(dimm, dimn)) ! bc0 M*N - bc0 = 0.0d+00 - bc0 = MATMUL(TRANSPOSE(DCONJG(uc)), bc) - Allocate(bc1(dimm, dimm)) ! bc1 M*M - bc1 = 0.0d+00 - bc1 = MATMUL(bc0, uc) - - If(debug) then - - write(*,*)'Check whether bc1 is hermite or not' - Do i = 1, dimm - Do j = i, dimm - if(ABS(bc1(i,j)-DCONJG(bc1(j,i))) > 1.0d-6) then - write(*,'(2I4,2E15.7)')i,j,bc1(i,j)-bc1(j,i) - End if - End do - End do - write(*,*)'Check whether bc1 is hermite or not END' - - End if - - deallocate (bc) - deallocate (bc0) - - cutoff = .FALSE. - - Allocate(wb(dimm)) - - write(*,*)'bC matrix is transrated to bc1(M*M matrix)!' - - Allocate(bc0(dimm,dimm)) - bc0 = bc1 - - Call cdiag(bc1, dimm, dammy, wb, thresd, cutoff) -! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - If (debug) then - - write(*,*)'Check whether bc is really diagonalized or not' - - Call checkdgc(dimm, bc0, bc1, wb) -! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - write(*,*)'Check whether bc is really diagonalized or not END' - - End if - - deallocate(bc0) - - write(*,*)'bC1 matrix is diagonalized!' - - e2 = 0.0d+00 - - Do i0 = 1, naij - ja = ia0(i0) - ji = ii0(i0) - jj = ij0(i0) - - syma = nsymrpa + 1 - syma = MULTB2(irpmo(jj), syma) - syma = MULTB (irpmo(ja), syma) - syma = MULTB2(irpmo(ji), syma) - syma = MULTB (isym, syma) - - If(nsymrpa==1.or.(nsymrpa/=1.and.(syma == nsymrpa + 1))) then - - Allocate(vc(dimn)) - - Do it = 1, dimn - vc(it) = v(i0,indt(it)+ninact) - Enddo - - Allocate(vc1(dimm)) - vc1 = 0.0d+00 - - vc1(1:dimm) = MATMUL(TRANSPOSE(DCONJG(uc(1:dimn,1:dimm))),vc(1:dimn)) - Deallocate (vc) - - alpha = + eps(ja) -eps(ji) - eps(jj) - e0 + eshift ! For Level Shift (2007/2/9) - - vc1(1:dimm) = MATMUL(TRANSPOSE(DCONJG(bc1(1:dimm,1:dimm))),vc1(1:dimm)) - - Do j = 1, dimm - e = DCONJG(vc1(j))*vc1(j)/(alpha+wb(j)) - sumc2local = sumc2local + e/(alpha+wb(j)) - e2(isym) = e2(isym) - e - End do - - deallocate(vc1) - - End if - - End do - - - - deallocate(uc) - deallocate(wb) - Deallocate (bc1) - - 1000 write(*,'("e2e(",I3,") = ",E20.10,"a.u.")')isym,e2(isym) - e2e = e2e + e2(isym) - - End do ! isym - - write(*,'("e2e = ",E20.10,"a.u.")')e2e - - write(*,'("sumc2,e = ",E20.10)')sumc2local - sumc2 = sumc2 + sumc2local - - deallocate(iaij) - deallocate(ia0) - deallocate(ii0) - deallocate(ij0) - deallocate(v) - - - - - continue - write(*,*)'end solve_ord' - end - - - - - -! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= -! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= - - SUBROUTINE sEmat(dimn, indt, sc) ! Assume C1 molecule, overlap matrix S in space E - - -! S(u,t) = d(ut) - <0|Etu|0> -! -! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= -! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= - - use four_caspt2_module - - Implicit NONE - - integer, intent(in) :: dimn, indt(dimn) - complex*16, intent(out) :: sc(dimn,dimn) - - real*8 ::a,b - - integer :: it, iu - integer :: i, j - - - - sc = 0.0d+00 - - Do i = 1, dimn - iu = indt(i) - - Do j = i, dimn - it = indt(j) - a = 0.0d+0 - b = 0.0d+0 - - Call dim1_density & - (it, iu, a, b) - - If(iu == it) then - sc(i,j) = 1 - DCMPLX(a,b) - Else - sc(i,j) = -DCMPLX(a,b) - Endif - - sc(j,i) = DCONJG(sc(i,j)) - -! write(*,*)i,j,sc(i,j) - - End do !j - End do !i - - End subroutine sEmat - - - -! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= -! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= - - SUBROUTINE bEmat (e0, dimn, sc, indt, bc) ! Assume C1 molecule, overlap matrix B in space E -! -! -! S(u,t) = d(ut) - <0|Etu|0> -! -! B(u,t) = Siguma_w [eps(w){d(tu)<0|Eww|0>-<0|EtuEww|0>}] + S(u,t)eps(t) -! -! = - Siguma_w [eps(w)<0|EtuEww|0>] + d(tu)e0 + S(u,t)eps(t) -! -! -! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= -! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= - - use four_caspt2_module - - Implicit NONE - - integer :: it, iu, iw, jt, ju, jw - integer :: i, j - - integer, intent(in) :: dimn, indt(dimn) - complex*16, intent(in) :: sc(dimn,dimn) - complex*16, intent(out) :: bc(dimn,dimn) - real*8, intent(in) :: e0 - - real*8 :: denr, deni - complex*16 :: den - - - bc(:,:) = 0.0d+00 - - write(*,*)'E space Bmat iroot=',iroot - - - Do i = 1, dimn - iu = indt(i) - ju = iu + ninact - - Do j = i, dimn - it = indt(j) - jt = it + ninact - - Do iw = 1, nact - jw = iw + ninact - -! = - Siguma_w [eps(w)<0|EtuEww|0>] + d(tu)e0 + S(u,t)eps(t) - - Call dim2_density & - (it, iu, iw, iw, denr, deni) - den = DCMPLX(denr, deni) - bc(i,j) = bc(i,j) - den*eps(jw) - - End do - - if(it == iu) bc(i, j) = bc(i, j) + e0 - - bc(i, j) = bc(i, j) + sc(i, j)*eps(jt) - -! write(*,*)'bc',i,j, bc(i,j) - - bc(j, i) = DCONJG(bc(i, j)) - - - End do !i - End do !j - - - write(*,*)'bEmat is ended' - - End subroutine bEmat - - - -! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= -! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= - - SUBROUTINE vEmat_ord (naij, iaij, v) -! -! V(t,ija) =[SIGUMA_p:active <0|Ept|0>{(ai|pj) - (aj|pi)}] + (aj|ti) - (ai|tj) -! -! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= -! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= - - use four_caspt2_module - - Implicit NONE - - integer, intent(in) :: naij, & - - & iaij(ninact+nact+1:ninact+nact+nsec,1:ninact,1:ninact) - - complex*16, intent(out) :: v(naij, ninact+1:ninact+nact) - - real*8 :: dr, di - complex*16 :: cint2, dens - - integer :: i, j, k, l, taij - integer :: it, jt, ik - - v = 0.0d+00 - -! V(t,ija) =[SIGUMA_p:active <0|Ept|0>{(ai|pj) - (aj|pi)}] - (ai|tj) + (aj|ti) i > j - - open(1, file ='Eint', status='old', form='unformatted') ! (31|21) stored - 30 read(1, err=10, end=20) i,j,k,l,cint2 - - if(j == l) goto 30 - - taij = iaij(i, j, l) - ik = k - ninact - -! write(*,*) i,j,k,l,taij,cint2 - - if (j < l) then - cint2 = -1.0d+00*cint2 - endif - - v(taij,k) = v(taij, k) - cint2 - - Do it = 1, nact - jt = ninact+it - Call dim1_density (it, ik, dr, di) ! ik corresponds to p in above formula - dens = DCMPLX(dr, di) - v(taij,jt) = v(taij, jt) + cint2*dens - End do ! it - - if (j < l) then - cint2 = -1.0d+00*cint2 ! data cint2 becomes initial values! - endif - -!! Take Kramers conjugate ! -! -! Call takekr( i, j, k, l, cint2) -! -! taij = iaij(i, j, l) -! ik = k - ninact -! -!! write(*,*) i,j,k,l,taij,cint2 -! -! if (j < l) then -! cint2 = -1.0d+00*cint2 -! endif -! -! v(taij,k) = v(taij, k) - cint2 -! -! Do it = 1, nact -! jt = ninact+it -! Call dim1_density (it, ik, dr, di) ! ik corresponds to p in above formula -! dens = DCMPLX(dr, di) -! v(taij,jt) = v(taij, jt) + cint2*dens -! End do ! it - - goto 30 - - 20 close(1) ; goto 100 - - 10 write(*,*) 'error while opening file Eint' ; goto 100 - - 100 write(*,*)'vEmat_ord is ended' - - end subroutine vEmat_ord - - - - diff --git a/src/solvall_E_ord_ty.f90 b/src/solvall_E_ord_ty.f90 index 6a3774ba..206599e2 100644 --- a/src/solvall_E_ord_ty.f90 +++ b/src/solvall_E_ord_ty.f90 @@ -487,6 +487,7 @@ SUBROUTINE vEmat_ord_ty(naij, iaij, v) ! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= use four_caspt2_module + use module_file_manager Implicit NONE #ifdef HAVE_MPI @@ -501,28 +502,26 @@ SUBROUTINE vEmat_ord_ty(naij, iaij, v) complex*16 :: cint2, dens integer :: i, j, k, l, taij - integer :: it, jt, ik, iostat + integer :: it, ik, iostat, twoint_unit integer :: datetmp0, datetmp1 real(8) :: tsectmp0, tsectmp1 + logical :: is_end_of_file if (rank == 0) print *, 'Enter vEmat. Please ignore timer under this line.' datetmp1 = date0; datetmp0 = date0 Call timing(date0, tsec0, datetmp0, tsectmp0) tsectmp1 = tsectmp0 v = 0.0d+00 + twoint_unit = default_unit ! V(t,ija) =[SIGUMA_p:active <0|Ept|0>{(ai|pj) - (aj|pi)}] - (ai|tj) + (aj|ti) i > j - open (1, file=eint, status='old', form='unformatted') ! (31|21) stored + call open_unformatted_file(unit=twoint_unit, file=eint, status='old', optional_action='read') ! (31|21) stored do - read (1, iostat=iostat) i, j, k, l, cint2 - ! Exit the loop if the end of the file is reached - if (iostat < 0) then - if (rank == 0) print *, 'End of Eint' + read (twoint_unit, iostat=iostat) i, j, k, l, cint2 + call check_iostat(iostat=iostat, file=eint, end_of_file_reached=is_end_of_file) + if (is_end_of_file) then exit - elseif (iostat > 0) then - ! If iostat is greater than 0, error detected in the input file, so exit the program - stop 'Error: Error in reading Eint' end if if (j == l) cycle ! Read the next 2-integral if j equal to l @@ -570,8 +569,8 @@ SUBROUTINE vEmat_ord_ty(naij, iaij, v) ! v(taij,jt) = v(taij, jt) + cint2*dens ! End do ! it end do + close (twoint_unit) - close (1) if (rank == 0) print *, 'vEmat_ord_ty is ended' #ifdef HAVE_MPI diff --git a/src/solvall_F_ord.f90 b/src/solvall_F_ord.f90 deleted file mode 100644 index 1bd5aafe..00000000 --- a/src/solvall_F_ord.f90 +++ /dev/null @@ -1,571 +0,0 @@ -! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= -! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= - - SUBROUTINE solvF_ord (e0, e2f) - -! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= -! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= - - use four_caspt2_module - - Implicit NONE - - real*8, intent(in) :: e0 - real*8, intent(out):: e2f - - - - integer :: dimn, dimm, count, dammy - - integer, allocatable :: indsym(:,:) - - real*8, allocatable :: sr(:,:), ur(:,:) - real*8, allocatable :: br(:,:), wsnew(:), ws(:), wb(:) - real*8, allocatable :: br0(:,:), br1(:,:) - real*8 :: e2(2*nsymrpa), alpha, e - - - complex*16, allocatable :: sc(:,:), uc(:,:), sc0(:,:) - complex*16, allocatable :: bc(:,:) - complex*16, allocatable :: bc0(:,:), bc1(:,:), v(:,:,:), vc(:), vc1(:) - - logical :: cutoff - integer :: j, i, k, syma, isym, i0, j0 - integer :: ia, it, ib, iu, ja, jt, jb, ju - - integer, allocatable :: ia0(:), ib0(:), iab(:,:) - integer :: nab - - - real*8 :: thresd - -! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= -! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= - -! SPACE F IS NOW CALCULATED -! -! EatEbu|0> -! -! DRAS1 =0 DRAS2 = -2 DRAS3 = +2 -! -! a > b t > u ( c > d, v > x) -! -! S(cvdx,atbu) = d(ac) d(bd) [ <0|EvtExu|0> - d(xt)<0|Evu|0>] <= S(vx,tu) -! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! S(vx, tu) = <0|EvtExu|0> - d(xt)<0|Evu|0> -! -! B(vx, tu) = Siguma_w [eps(w){ <0|EvtExuEww|0> - d(xt)<0|EvuEww|0>}] + S(u,t){-eps(u)-eps(t)} -! -! alpha(a, b) = + eps(a) + eps(b) - e0 -! -! where -! -! e0 = Siguma_w [eps(w)<0|Eww|0>] (<== calculated as e0 in calce0.f) -! -! V(tu,ab) = SIGUMA_p,q:active <0|EtpEuq|0>(ap|bq) - SIGUMA_p:active <0|Etp|0>(au|bp) -! -! E2 = SIGUMA_iab,t:dimm |V1(t,ab)|^2|/{(alpha(ab) + wb(t)} -! -! thresd = thres - thresd = 1.0D-08 - thres = 1.0D-08 - - e2 = 0.0d+00 - e2f= 0.0d+00 - dimn = 0 - syma = 0 - write(*,*)' ENTER solv F part' - write(*,*)' nsymrpa', nsymrpa - - i0 = 0 - Do ia = 1, nsec - Do ib = 1, ia-1 - i0 = i0 + 1 - End do - End do - - nab = i0 - Allocate(iab(ninact+nact+1:ninact+nact+nsec,ninact+nact+1:ninact+nact+nsec)) - iab = 0 - Allocate(ia0(nab)) - Allocate(ib0(nab)) - - i0 = 0 - Do ia = 1, nsec - ja = ia+ninact+nact - Do ib = 1, ia-1 - jb = ib+ninact+nact - i0 = i0 + 1 - iab(ja, jb) = i0 - iab(jb, ja) = i0 - ia0(i0) = ja - ib0(i0) = jb - End do - End do - - - Allocate(v(nab, ninact+1:ninact+nact, ninact+1:ninact+nact)) - v = 0.0d+00 - - Call vFmat_ord (nab, iab, v) - write(*,*)'come' - -!Iwamuro Modify - Do Isym = Nsymrpa+1, 2*Nsymrpa -! Do Isym = 1, Nsymrpa - - Dimn = 0 - Do it = 1, nact - jt = it + ninact -! Do iu = 1, nact - Do iu = 1, it-1 - ju = iu + ninact - - syma = nsymrpa + 1 - syma = MULTB2( irpmo(ju), syma) ! HERE ABELIAN IS ASSUMED. AT PRESENT I'M NOT SURE - syma = MULTB2( irpmo(jt), syma) ! THIS TREATMENT IS CORRECT. THE ORDER OF OPERATOR - ! MAY BE INAFFECTED TO TOTAL POINT GROUP SYMMETRY - if (nsymrpa == 1 .or. (nsymrpa /=1 .and. syma == isym)) then - dimn = dimn + 1 - End if - End do ! iu - End do ! it - - write(*,*)'isym, dimn',isym, dimn - - If(dimn == 0) goto 1000 - - Allocate(indsym(2, dimn)) - - dimn = 0 - Do it = 1, nact - jt = it + ninact -! Do iu = 1, nact - Do iu = 1, it-1 - ju = iu + ninact - - syma = nsymrpa + 1 - syma = MULTB2( irpmo(ju), syma) ! HERE ABELIAN IS ASSUMED. AT PRESENT I'M NOT SURE - syma = MULTB2( irpmo(jt), syma) ! THIS TREATMENT IS CORRECT. THE ORDER OF OPERATOR - ! MAY BE INAFFECTED TO TOTAL POINT GROUP SYMMETRY - if (nsymrpa == 1 .or. (nsymrpa /=1 .and. syma == isym)) then - dimn = dimn + 1 - indsym(1,dimn) = it - indsym(2,dimn) = iu - End if - End do ! iu - End do ! it - - - Allocate(sc(dimn,dimn)) - sc = 0.0d+00 ! sc N*N - - Call sFmat (dimn, indsym, sc) -! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - - write(*,*)'sc matrix is obtained normally' - - Allocate(ws(dimn)) - - cutoff = .TRUE. -! thresd = 1.0d-15 - - Allocate(sc0(dimn,dimn)) - sc0 = sc - - Call cdiag (sc, dimn, dimm, ws, thresd, cutoff) -! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - write(*,*)'after s cdiag, new dimension is', dimm - - - If(dimm == 0) then - deallocate(indsym) - deallocate(sc0) - deallocate(sc) - deallocate(ws) - goto 1000 - Endif - - - - If (debug) then - - write(*,*)'Check whether U*SU is diagonal' - - Call checkdgc(dimn, sc0, sc, ws) -! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - write(*,*)'Check whether U*SU is diagonal END' - - End if - - Allocate(bc(dimn,dimn)) ! bc N*N - bc = 0.0d+00 - - Call bFmat (dimn, sc0, indsym, bc) -! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - - write(*,*)'bc matrix is obtained normally' - - deallocate (sc0) - - write(*,*)'OK cdiag',dimn,dimm - - Allocate(uc(dimn,dimm)) ! uc N*M - Allocate(wsnew(dimm)) ! wnew M - uc(:,:) = 0.0d+00 - wsnew(:) = 0.0d+00 - - Call ccutoff (sc, ws, dimn, dimm, uc, wsnew) -! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - write(*,*)'OK ccutoff' - deallocate (ws) - deallocate (sc) - - Call ucramda_s_half (uc, wsnew, dimn, dimm) ! uc N*M matrix rewritten as uramda^(-1/2) -! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - deallocate(wsnew) - - write(*,*)'ucrams half OK' - Allocate(bc0(dimm, dimn)) ! bc0 M*N - bc0 = 0.0d+00 - bc0 = MATMUL(TRANSPOSE(DCONJG(uc)), bc) - Allocate(bc1(dimm, dimm)) ! bc1 M*M - bc1 = 0.0d+00 - bc1 = MATMUL(bc0, uc) - - If (debug) then - - write(*,*)'Check whether bc1 is hermite or not' - Do i = 1, dimm - Do j = i, dimm - if(ABS(bc1(i,j)-DCONJG(bc1(j,i))) > 1.0d-6) then - write(*,'(2I4,2E15.7)')i,j,bc1(i,j)-bc1(j,i) - End if - End do - End do - write(*,*)'Check whether bc1 is hermite or not END' - - End if - - deallocate (bc) - deallocate (bc0) - - cutoff = .FALSE. - - Allocate(wb(dimm)) - - write(*,*)'bC matrix is transrated to bc1(M*M matrix)!' - - Allocate(bc0(dimm,dimm)) - bc0 = bc1 - - Call cdiag(bc1, dimm, dammy, wb, thresd, cutoff) -! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - - If(debug) then - - write(*,*)'Check whether bc is really diagonalized or not' - - Call checkdgc(dimm, bc0, bc1, wb) -! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - write(*,*)'Check whether bc is really diagonalized or not END' - - End if - - deallocate(bc0) - - write(*,*)'bC1 matrix is diagonalized!' - - e2 = 0.0d+00 - - Do i0 = 1, nab - ja = ia0(i0) - jb = ib0(i0) - - syma = isym - syma = MULTB (irpmo(jb), syma) - syma = MULTB (irpmo(ja), syma) - - If(nsymrpa==1.or.(nsymrpa/=1.and.(syma == nsymrpa + 1))) then - - Allocate(vc(dimn)) - Do it = 1, dimn - vc(it) = v(i0,indsym(1,it)+ninact,indsym(2,it)+ninact) - Enddo - Allocate(vc1(dimm)) - vc1 = 0.0d+00 - - vc1(1:dimm) = MATMUL(TRANSPOSE(DCONJG(uc(1:dimn,1:dimm))),vc(1:dimn)) - Deallocate (vc) - - alpha = + eps(ja) + eps(jb) - e0 + eshift ! For Level Shift (2007/2/9) - - vc1(1:dimm) = MATMUL(TRANSPOSE(DCONJG(bc1(1:dimm,1:dimm))),vc1(1:dimm)) - - Do j = 1, dimm - e = (ABS(vc1(j))**2.0d+00)/(alpha+wb(j)) - sumc2local = sumc2local + e/(alpha+wb(j)) - e2(isym) = e2(isym) - e - End do - - deallocate(vc1) - - End if - - End do !i0 - - - deallocate(indsym) - deallocate(uc) - deallocate(wb) - Deallocate (bc1) - - 1000 write(*,'("e2f(",I3,") = ",E20.10,"a.u.")')isym,e2(isym) - e2f = e2f + e2(isym) - - End do ! isym - - write(*,'("e2f = ",E20.10,"a.u.")')e2f - - write(*,'("sumc2,f = ",E20.10)')sumc2local - sumc2 = sumc2 + sumc2local - - deallocate(iab) - deallocate(ia0) - deallocate(ib0) - deallocate(v) - - continue - write(*,*)'end solve_ord' - end - - - - - -! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= -! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= - - SUBROUTINE sFmat(dimn, indsym, sc) ! Assume C1 molecule, overlap matrix S in space F - - -! S(vx, tu) = <0|EvtExu|0> - d(xt)<0|Evu|0> -! -! v > x, t > u - -! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= -! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= - - use four_caspt2_module - - Implicit NONE - - integer, intent(in) :: dimn, indsym(2, dimn) - complex*16, intent(out) :: sc(dimn,dimn) - - real*8 :: a,b - - integer :: it, iu, iv, ix - integer :: i, j - integer :: count - - - - sc = 0.0d+00 - - Do i = 1, dimn - iv = indsym(1,i) - ix = indsym(2,i) - Do j = i, dimn - it = indsym(1,j) - iu = indsym(2,j) - - a = 0.0d+0 - b = 0.0d+0 - Call dim2_density (iv, it, ix, iu, a,b) - sc(i,j) = DCMPLX(a,b) - - if(ix == it) then - a = 0.0d+0 - b = 0.0d+0 - Call dim1_density (iv, iu, a,b) - sc(i,j) = sc(i,j) - DCMPLX(a,b) - End if - - sc(j,i) = DCONJG(sc(i,j)) - - End do !j - End do !i - - End subroutine sFmat - - - -! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= -! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= - - SUBROUTINE bFmat (dimn, sc, indsym, bc) ! Assume C1 molecule, overlap matrix B in space F -! -! B(vx, tu) = Siguma_w [eps(w){ <0|EvtExuEww|0> - d(xt)<0|EvuEww|0>}] + S(u,t){-eps(u)-eps(t)} -! -! v > x, t > u -! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= -! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= - - use four_caspt2_module - - Implicit NONE - - integer, intent(in) :: dimn, indsym(2,dimn) - complex*16, intent(in) :: sc(dimn,dimn) - complex*16, intent(out) :: bc(dimn,dimn) - - real*8 :: e, denr, deni - complex*16 :: den - - integer :: it, iu, iv, ix, iy, iz, iw - integer :: jt, ju, jv, jx, jw, i, j - - - bc(:,:) = 0.0d+00 - - write(*,*)'F space Bmat iroot=',iroot - - Do i = 1, dimn - - iv = indsym(1,i) - jv = iv + ninact - ix = indsym(2,i) - jx = ix + ninact - - Do j = i, dimn - - it = indsym(1,j) - jt = it + ninact - iu = indsym(2,j) - ju = iu + ninact - -! B(vx, tu) = Siguma_w [eps(w){ <0|EvtExuEww|0> - d(xt)<0|EvuEww|0>}] + S(u,t){-eps(u)-eps(t)} - - e = -eps(ju) - eps(jt) - - Do iw = 1, nact - jw = iw + ninact - - Call dim3_density & - (iv, it, ix, iu, iw, iw, denr, deni) - den = DCMPLX(denr, deni) - bc(i,j) = bc(i,j) + den*eps(jw) - - If(ix == it) then - - Call dim2_density & - (iv, iu, iw, iw, denr, deni) - den = DCMPLX(denr, deni) - bc(i,j) = bc(i,j) - den*eps(jw) - - End if - - End do - - bc(i, j) = bc(i, j) + sc(i, j)*e - - bc(j, i) = DCONJG(bc(i, j)) - - - End do !i - End do !j - - - write(*,*)'bFmat is ended' - - End subroutine bFmat - - - -! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= -! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= - - SUBROUTINE vFmat_ord (nab, iab, v) -! -! V(tu, ab) = SIGUMA_p,q:active <0|EtpEuq|0>(ap|bq) - SIGUMA_p:active <0|Etp|0>(au|bp) -! -! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= -! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= - - use four_caspt2_module - - Implicit NONE - - - integer, intent(in) :: nab, & - - & iab(ninact+nact+1:ninact+nact+nsec,ninact+nact+1:ninact+nact+nsec) - - complex*16, intent(out) :: v(nab,ninact+1:ninact+nact,ninact+1:ninact+nact) - - real*8 :: dr, di - complex*16 :: cint2, dens - - integer :: i, j, k, l, tab, ip, iq, save - integer :: it, jt, ju, iu - - v = 0.0d+00 - -! V(ab,t,u) = SIGUMA_p,q:active <0|EtpEuq|0>(ap|bq) - SIGUMA_p:active <0|Etp|0>(au|bp) - - open(1, file ='Fint', status='old', form='unformatted') ! (32|32) stored a > b - 30 read(1, err=10, end=20) i,j,k,l,cint2 - - if(i <= k) goto 30 - - tab = iab(i, k) - -! if (i < k ) then ! indices exchange i<=>k j<=>l -! save = i -! i = k -! k = save -! save = j -! j = l -! l = save -! endif - -! write(*,'(4I4,2E20.10)') i,j,k,l,cint2 - - ip = j - ninact - iq = l - ninact - -! V(ab,t,u) = SIGUMA_p,q:active <0|EtpEuq|0>(ap|bq) - SIGUMA_p:active <0|Etp|0>(au|bp) -! <0|EtjEul|0>(ij|kl) (ij|kl) -! -! p=j, q=l loop for t and u u=j, p=l loop for t -! - Do it = 1, nact - jt = it + ninact - Do iu = 1, it-1 - ju = iu + ninact - - Call dim2_density (it, ip, iu, iq, dr, di) - dens = DCMPLX(dr, di) - v(tab,jt,ju) = v(tab,jt,ju) + cint2*dens - End do ! iu - - Call dim1_density (it, iq, dr, di) - dens = DCMPLX(dr, di) - v(tab, jt, j) = v(tab, jt, j) - cint2*dens - - End do ! ip - - goto 30 - - 20 close(1) ; goto 100 - - 10 write(*,*) 'error while opening file Fint' ; goto 100 - - 100 write(*,*)'vFmat_ord is ended' - - - end subroutine vFmat_ord - - - diff --git a/src/solvall_F_ord_ty.f90 b/src/solvall_F_ord_ty.f90 index 581fb19d..47c31c66 100644 --- a/src/solvall_F_ord_ty.f90 +++ b/src/solvall_F_ord_ty.f90 @@ -511,6 +511,7 @@ SUBROUTINE vFmat_ord(nab, iab, v) ! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= use four_caspt2_module + use module_file_manager Implicit NONE #ifdef HAVE_MPI @@ -524,35 +525,31 @@ SUBROUTINE vFmat_ord(nab, iab, v) real*8 :: dr, di complex*16 :: cint2, dens - integer :: i, j, k, l, tab, ip, iq - integer :: it, jt, ju, iu, iostat + integer :: i, j, k, l, tab + integer :: it, iu, iostat, twoint_unit integer :: datetmp0, datetmp1 real(8) :: tsectmp0, tsectmp1 + logical :: is_end_of_file if (rank == 0) print *, 'Enter vFmat. Please ignore timer under this line.' datetmp1 = date0; datetmp0 = date0 Call timing(date0, tsec0, datetmp0, tsectmp0) tsectmp1 = tsectmp0 v = 0.0d+00 + twoint_unit = default_unit ! V(ab,t,u) = SIGUMA_p,q:active <0|EtpEuq|0>(ap|bq) - SIGUMA_p:active <0|Etp|0>(au|bp) - open (1, file=fint, status='old', form='unformatted') ! (32|32) stored a > b + call open_unformatted_file(unit=twoint_unit, file=fint, status='old', optional_action='read') ! (32|32) stored a > b do - read (1, iostat=iostat) i, j, k, l, cint2 - ! Exit the loop if the end of the file is reached - if (iostat < 0) then - if (rank == 0) print *, 'End of Eint' + read (twoint_unit, iostat=iostat) i, j, k, l, cint2 + call check_iostat(iostat=iostat, file=fint, end_of_file_reached=is_end_of_file) + if (is_end_of_file) then exit - elseif (iostat > 0) then - ! If iostat is greater than 0, error detected in the input file, so exit the program - stop 'Error: Error in reading Eint' end if if (i <= k) cycle ! Read the next line if i is less than or equal to k tab = iab(i, k) - ! ip = j - ninact - ! iq = l - ninact ! V(ab,t,u) = SIGUMA_p,q:active <0|EtpEuq|0>(ap|bq) - SIGUMA_p:active <0|Etp|0>(au|bp) ! <0|EtjEul|0>(ij|kl) (ij|kl) @@ -571,11 +568,10 @@ SUBROUTINE vFmat_ord(nab, iab, v) dens = DCMPLX(dr, di) v(tab, it, j) = v(tab, it, j) - cint2*dens - End do ! ip + End do ! it !$OMP end parallel do end do - - close (1) + close (twoint_unit) if (rank == 0) print *, 'vFmat_ord is ended' diff --git a/src/solvall_G_ord.f90 b/src/solvall_G_ord.f90 deleted file mode 100644 index b20b0c16..00000000 --- a/src/solvall_G_ord.f90 +++ /dev/null @@ -1,525 +0,0 @@ -! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= -! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= - - SUBROUTINE solvG_ord (e0, e2g) - -! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= -! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= - - use four_caspt2_module - - Implicit NONE - - real*8, intent(in) :: e0 - real*8, intent(out):: e2g - - - - integer :: dimn, dimm, count, dammy - - integer, allocatable :: indsym(:,:) - - real*8, allocatable :: sr(:,:), ur(:,:) - real*8, allocatable :: br(:,:), wsnew(:), ws(:), wb(:) - real*8, allocatable :: br0(:,:), br1(:,:) - real*8 :: e2(2*nsymrpa), alpha, e - - - complex*16, allocatable :: sc(:,:), uc(:,:), sc0(:,:) - complex*16, allocatable :: bc(:,:) - complex*16, allocatable :: bc0(:,:), bc1(:,:), v(:,:), vc(:), vc1(:) - - logical :: cutoff - integer :: j, i, k, i0, syma, isym, indt(1:nact) - integer :: ia, it, ib, ii, ja, jt, jb, ji - integer, allocatable :: ia0(:), ib0(:), ii0(:), iabi(:,:,:) - integer :: nabi - - - real*8 :: thresd - -! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= -! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= - -! SPACE G IS NOW CALCULATED -! -! EaiEbt|0> -! -! DRAS1 =-1 DRAS2 = -1 DRAS3 = +2 -! -! c > d, a > b, and impose that c >= a (or a >= c) -! -! S(cjdu,aibt) = d(ac) d(bd) d(ij) <0|Eut|0> <= S(u,t) -! ~~~~~~~~~ -! S(u,t) = <0|Eut|0> -! -! B(u,t) = Siguma_w [eps(w)<0|EutEww|0>] + S(u,t)(-eps(t)) -! -! alpha(i,a,b) = -eps(i) + eps(a) + eps(b) - e0 -! -! where -! -! e0 = Siguma_w [eps(w)<0|Eww|0>] (<== calculated as e0 in calce0.f) -! -! V(t,iab) = [SIGUMA_p:active <0|Etp|0>{(ai|bp)-(ap|bi)}] -! -! -! E2 = SIGUMA_iab, dimm |V1(t,iab)|^2|/{(alpha(iab) + wb(t)} -! -! thresd = thres - thresd = 1.0D-08 - thres = 1.0D-08 - - e2 = 0.0d+00 - e2g= 0.0d+00 - dimn = 0 - syma = 0 - indt=0 - write(*,*)' ENTER solv G part' - write(*,*)' nsymrpa', nsymrpa - - - i0 = 0 - Do ia = 1, nsec - ja = ia+ninact+nact - Do ib = 1, ia-1 - jb = ib+ninact+nact - Do ii = 1, ninact - ji = ii - i0 = i0 + 1 - End do - End do - End do - - nabi = i0 - Allocate(iabi(ninact+nact+1:ninact+nact+nsec,ninact+nact+1:ninact+nact+nsec,1:ninact)) - iabi = 0 - Allocate(ia0(nabi)) - Allocate(ib0(nabi)) - Allocate(ii0(nabi)) - - i0 = 0 - Do ia = 1, nsec - ja = ia+ninact+nact - Do ib = 1, ia-1 - jb = ib+ninact+nact - Do ii = 1, ninact - ji = ii - i0 = i0 + 1 - iabi(ja, jb, ji) = i0 - iabi(jb, ja, ji) = i0 - ia0(i0) = ja - ib0(i0) = jb - ii0(i0) = ji - End do - End do - End do - - Allocate(v(nabi, ninact+1:ninact+nact)) - v = 0.0d+00 - - write(*,*)'come' - Call vGmat_ord (nabi, iabi, v) - -!Iwamuro modify - Do i = 1, nabi - Do j = ninact+1, ninact+nact - if (abs(v(i,j)) > 1.0E-08) then - write(*,'("i,j,V_g ",2I4,2E15.7)') i,j,v(i,j) - Endif - Enddo - Enddo - - Do isym = 1, nsymrpa - - dimn = 0 - Do it = 1, nact - jt = it + ninact - if (irpmo(jt) == isym) then - dimn = dimn + 1 - indt(dimn) = it - End if - End do ! it - - write(*,*)'isym, dimn',isym, dimn - - If (dimn == 0) goto 1000 - - Allocate(sc(dimn,dimn)) - sc = 0.0d+00 ! sc N*N - - Call sGmat (dimn, indt(1:dimn), sc) -! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - write(*,*)'sG matrix is obtained normally' - - Allocate(ws(dimn)) - - cutoff = .TRUE. -! thresd = 1.0d-15 - - Allocate(sc0(dimn,dimn)) - sc0 = sc - - Call cdiag (sc, dimn, dimm, ws, thresd, cutoff) -! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - write(*,*)'after s cdiag, new dimension is', dimm - - If(dimm == 0) then - deallocate(sc0) - deallocate(sc) - deallocate(ws) - goto 1000 - Endif - - If(debug) then - - write(*,*)'Check whether U*SU is diagonal' - - Call checkdgc(dimn, sc0, sc, ws) -! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - write(*,*)'Check whether U*SU is diagonal END' - - End if - - Allocate(bc(dimn,dimn)) ! bc N*N - bc = 0.0d+00 - - Call bGmat (dimn, sc0, indt(1:dimn), bc) -! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - - write(*,*)'bC matrix is obtained normally' - - deallocate (sc0) - - write(*,*)'OK cdiag',dimn,dimm - - Allocate(uc(dimn,dimm)) ! uc N*M - Allocate(wsnew(dimm)) ! wnew M - uc(:,:) = 0.0d+00 - wsnew(:) = 0.0d+00 - - Call ccutoff (sc, ws, dimn, dimm, uc, wsnew) -! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - write(*,*)'OK ccutoff' - deallocate (ws) - deallocate (sc) - - Call ucramda_s_half (uc, wsnew, dimn, dimm) ! uc N*M matrix rewritten as uramda^(-1/2) -! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - deallocate(wsnew) - - write(*,*)'ucrams half OK' - Allocate(bc0(dimm, dimn)) ! bc0 M*N - bc0 = 0.0d+00 - bc0 = MATMUL(TRANSPOSE(DCONJG(uc)), bc) - Allocate(bc1(dimm, dimm)) ! bc1 M*M - bc1 = 0.0d+00 - bc1 = MATMUL(bc0, uc) - - If (debug) then - - write(*,*)'Check whether bc1 is hermite or not' - Do i = 1, dimm - Do j = i, dimm - if(ABS(bc1(i,j)-DCONJG(bc1(j,i))) > 1.0d-6) then - write(*,'(2I4,2E15.7)')i,j,bc1(i,j)-bc1(j,i) - End if - End do - End do - write(*,*)'Check whether bc1 is hermite or not END' - - End if - - deallocate (bc) - deallocate (bc0) - - cutoff = .FALSE. - - Allocate(wb(dimm)) - - write(*,*)'bC matrix is transrated to bc1(M*M matrix)!' - - Allocate(bc0(dimm,dimm)) - bc0 = bc1 - - Call cdiag(bc1, dimm, dammy, wb, thresd, cutoff) -! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - If (debug) then - - write(*,*)'Check whether bc is really diagonalized or not' - - Call checkdgc(dimm, bc0, bc1, wb) -! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - write(*,*)'Check whether bc is really diagonalized or not END' - - End if - - deallocate(bc0) - - write(*,*)'bC1 matrix is diagonalized!' - - e2 = 0.0d+00 - - write(*,*) " nabi", nabi - - Do i0 = 1, nabi - ja = ia0(i0) - jb = ib0(i0) - ji = ii0(i0) - - syma = MULTB2(isym, nsymrpa + 1) - syma = MULTB(irpmo(jb), syma) - syma = MULTB2(irpmo(ji), syma) - syma = MULTB(irpmo(ja), syma) - - If(nsymrpa==1.or.(nsymrpa/=1.and.(syma == nsymrpa + 1))) then - - Allocate(vc(dimn)) - - Do it = 1, dimn - vc(it) = v(i0,indt(it)+ninact) - Enddo - - Allocate(vc1(dimm)) - vc1 = 0.0d+00 - - vc1(1:dimm) = MATMUL(TRANSPOSE(DCONJG(uc(1:dimn,1:dimm))),vc(1:dimn)) - Deallocate (vc) - - alpha = -eps(ji) + eps(ja) + eps(jb) - e0 + eshift ! For Level Shift (2007/2/9) - - vc1(1:dimm) = MATMUL(TRANSPOSE(DCONJG(bc1(1:dimm,1:dimm))),vc1(1:dimm)) - - Do j = 1, dimm - e = (ABS(vc1(j))**2.0d+00)/(alpha+wb(j)) - sumc2local = sumc2local + e/(alpha+wb(j)) - e2(isym) = e2(isym) - e -!Iwamuro modify - write(*,'("j, vc1(j), alpha, wb(j) ",I4,4E15.7)') j, vc1(j), alpha, wb(j) - End do - -!Iwamuro modify -! write(*,*) 'e', e - - deallocate(vc1) - - End if - - End do - - - - deallocate(uc) - deallocate(wb) - Deallocate (bc1) - - 1000 write(*,'("e2g(",I3,") = ",E20.10,"a.u.")')isym,e2(isym) - e2g = e2g + e2(isym) - - End do ! isym - - write(*,'("e2g = ",E20.10,"a.u.")')e2g - - write(*,'("sumc2,g = ",E20.10)')sumc2local - sumc2 = sumc2 + sumc2local - - - deallocate(iabi) - deallocate(ia0) - deallocate(ib0) - deallocate(ii0) - deallocate(v) - - - - continue - write(*,*)'end solvg_ord' - end - - - - - -! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= -! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= - - SUBROUTINE sGmat(dimn, indt, sc) ! Assume C1 molecule, overlap matrix S in space C - - -! S(u,t) = <0|Eut|0> -! -! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= -! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= - - use four_caspt2_module - - Implicit NONE - - integer, intent(in) :: dimn, indt(dimn) - complex*16, intent(out) :: sc(dimn,dimn) - - real*8 ::a,b - - integer :: it, iu - integer :: i, j - - - - sc = 0.0d+00 - - Do i = 1, dimn - it = indt(i) - - Do j = i, dimn - iu = indt(j) - a = 0.0d+0 - b = 0.0d+0 - - Call dim1_density & - (it, iu, a, b) - - sc(i,j) = DCMPLX(a,b) - sc(j,i) = DCMPLX(a,-b) -! write(*,*)i,j,sc(i,j) - End do !j - End do !i - - End subroutine sGmat - - - -! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= -! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= - - SUBROUTINE bGmat (dimn, sc, indt, bc) ! Assume C1 molecule, overlap matrix B in space C -! -! -! S(u,t) = <0|Eut|0> -! -! B(u,t) = Siguma_w [eps(w)<0|EutEww|0>] + S(u,t)(-eps(t)) -! -! -! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= -! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= - - use four_caspt2_module - - Implicit NONE - - integer :: it, iu, iw, jt, ju, jw - integer :: i, j - - integer, intent(in) :: dimn, indt(dimn) - complex*16, intent(in) :: sc(dimn,dimn) - complex*16, intent(out) :: bc(dimn,dimn) - - real*8 :: denr, deni - complex*16 :: den - - - bc(:,:) = 0.0d+00 - - write(*,*)'G space Bmat iroot=',iroot - - - Do i = 1, dimn - iu = indt(i) - ju = iu + ninact - - Do j = i, dimn - it = indt(j) - jt = it + ninact - -! B(u,t) = Siguma_w [eps(w)<0|EutEww|0>] + S(u,t)(-eps(t)) - - Do iw = 1, nact - jw = iw + ninact - - Call dim2_density & - (iu, it, iw, iw, denr, deni) - den = DCMPLX(denr, deni) - bc(i,j) = bc(i,j) + den*eps(jw) - - End do - -! bc(i, j) = bc(i, j) - sc(i, j)*eps(jt) - bc(i, j) = bc(i, j) - sc(i, j)*eps(ju) - -! write(*,*)'bc',i,j, bc(i,j) - bc(j, i) = DCONJG(bc(i, j)) - - - End do !i - End do !j - - - write(*,*)'bGmat is ended' - - End subroutine bGmat - - - -! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= -! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= - - SUBROUTINE vGmat_ord (nabi, iabi, v) -! -! V(t,iab) = [SIGUMA_p:active <0|Etp|0>{(ai|bp)-(ap|bi)}] -! -! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= -! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= - - use four_caspt2_module - - Implicit NONE - - - integer, intent(in) :: nabi, & - - & iabi(ninact+nact+1:ninact+nact+nsec,ninact+nact+1:ninact+nact+nsec,1:ninact) - - complex*16, intent(out) :: v(nabi, ninact+1:ninact+nact) - - real*8 :: dr, di, signij, signkl - complex*16 :: cint2, dens - - integer :: i, j, k, l, tabi - integer :: it, jt, il - - v = 0.0d+00 - -! V(t,iab) = [SIGUMA_p:active <0|Etp|0>{(ai|bp)-(ap|bi)}] a > b - - open(1, file ='Gint', status='old', form='unformatted') ! (31|32) stored - 30 read(1, err=10, end=20) i,j,k,l,cint2 - - if(i == k) goto 30 -! write(*,*) i,j,k,l,tabi,cint2 - - tabi = iabi(i, k, j) - - if (i < k) then - cint2 = -1.0d+00*cint2 - endif - - il = l - ninact - - Do it = 1, nact - jt = ninact+it - Call dim1_density (it, il, dr, di) - dens = DCMPLX(dr, di) - v(tabi,jt) = v(tabi, jt) + cint2*dens - End do ! it - - goto 30 - - 20 close(1) ; goto 100 - - 10 write(*,*) 'error while opening file Gint' ; goto 100 - - 100 write(*,*)'vGmat_ord is ended' - - end subroutine vGmat_ord - - - diff --git a/src/solvall_G_ord_original.f90 b/src/solvall_G_ord_original.f90 deleted file mode 100644 index 99eec2ac..00000000 --- a/src/solvall_G_ord_original.f90 +++ /dev/null @@ -1,512 +0,0 @@ -! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= -! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= - - SUBROUTINE solvG_ord (e0, e2g) - -! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= -! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= - - use four_caspt2_module - - Implicit NONE - - real*8, intent(in) :: e0 - real*8, intent(out):: e2g - - - - integer :: dimn, dimm, count, dammy - - integer, allocatable :: indsym(:,:) - - real*8, allocatable :: sr(:,:), ur(:,:) - real*8, allocatable :: br(:,:), wsnew(:), ws(:), wb(:) - real*8, allocatable :: br0(:,:), br1(:,:) - real*8 :: e2(2*nsymrpa), alpha, e - - - complex*16, allocatable :: sc(:,:), uc(:,:), sc0(:,:) - complex*16, allocatable :: bc(:,:) - complex*16, allocatable :: bc0(:,:), bc1(:,:), v(:,:), vc(:), vc1(:) - - logical :: cutoff - integer :: j, i, k, i0, syma, isym, indt(1:nact) - integer :: ia, it, ib, ii, ja, jt, jb, ji - integer, allocatable :: ia0(:), ib0(:), ii0(:), iabi(:,:,:) - integer :: nabi - - - real*8 :: thresd - -! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= -! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= - -! SPACE G IS NOW CALCULATED -! -! EaiEbt|0> -! -! DRAS1 =-1 DRAS2 = -1 DRAS3 = +2 -! -! c > d, a > b, and impose that c >= a (or a >= c) -! -! S(cjdu,aibt) = d(ac) d(bd) d(ij) <0|Eut|0> <= S(u,t) -! ~~~~~~~~~ -! S(u,t) = <0|Eut|0> -! -! B(u,t) = Siguma_w [eps(w)<0|EutEww|0>] + S(u,t)(-eps(t)) -! -! alpha(i,a,b) = -eps(i) + eps(a) + eps(b) - e0 -! -! where -! -! e0 = Siguma_w [eps(w)<0|Eww|0>] (<== calculated as e0 in calce0.f) -! -! V(t,iab) = [SIGUMA_p:active <0|Etp|0>{(ai|bp)-(ap|bi)}] -! -! -! E2 = SIGUMA_iab, dimm |V1(t,iab)|^2|/{(alpha(iab) + wb(t)} -! -! thresd = thres - thresd = 1.0D-08 - thres = 1.0D-08 - - e2 = 0.0d+00 - e2g= 0.0d+00 - dimn = 0 - syma = 0 - indt=0 - write(*,*)' ENTER solv G part' - write(*,*)' nsymrpa', nsymrpa - - - i0 = 0 - Do ia = 1, nsec - ja = ia+ninact+nact - Do ib = 1, ia-1 - jb = ib+ninact+nact - Do ii = 1, ninact - ji = ii - i0 = i0 + 1 - End do - End do - End do - - nabi = i0 - Allocate(iabi(ninact+nact+1:ninact+nact+nsec,ninact+nact+1:ninact+nact+nsec,1:ninact)) - iabi = 0 - Allocate(ia0(nabi)) - Allocate(ib0(nabi)) - Allocate(ii0(nabi)) - - i0 = 0 - Do ia = 1, nsec - ja = ia+ninact+nact - Do ib = 1, ia-1 - jb = ib+ninact+nact - Do ii = 1, ninact - ji = ii - i0 = i0 + 1 - iabi(ja, jb, ji) = i0 - iabi(jb, ja, ji) = i0 - ia0(i0) = ja - ib0(i0) = jb - ii0(i0) = ji - End do - End do - End do - - Allocate(v(nabi, ninact+1:ninact+nact)) - v = 0.0d+00 - - write(*,*)'come' - Call vGmat_ord (nabi, iabi, v) - - - Do isym = 1, nsymrpa - - dimn = 0 - Do it = 1, nact - jt = it + ninact - if (irpmo(jt) == isym) then - dimn = dimn + 1 - indt(dimn) = it - End if - End do ! it - - write(*,*)'isym, dimn',isym, dimn - - If (dimn == 0) goto 1000 - - Allocate(sc(dimn,dimn)) - sc = 0.0d+00 ! sc N*N - - Call sGmat (dimn, indt(1:dimn), sc) -! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - write(*,*)'sG matrix is obtained normally' - - Allocate(ws(dimn)) - - cutoff = .TRUE. -! thresd = 1.0d-15 - - Allocate(sc0(dimn,dimn)) - sc0 = sc - - Call cdiag (sc, dimn, dimm, ws, thresd, cutoff) -! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - write(*,*)'after s cdiag, new dimension is', dimm - - If(dimm == 0) then - deallocate(sc0) - deallocate(sc) - deallocate(ws) - goto 1000 - Endif - - If(debug) then - - write(*,*)'Check whether U*SU is diagonal' - - Call checkdgc(dimn, sc0, sc, ws) -! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - write(*,*)'Check whether U*SU is diagonal END' - - End if - - Allocate(bc(dimn,dimn)) ! bc N*N - bc = 0.0d+00 - - Call bGmat (dimn, sc0, indt(1:dimn), bc) -! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - - write(*,*)'bC matrix is obtained normally' - - deallocate (sc0) - - write(*,*)'OK cdiag',dimn,dimm - - Allocate(uc(dimn,dimm)) ! uc N*M - Allocate(wsnew(dimm)) ! wnew M - uc(:,:) = 0.0d+00 - wsnew(:) = 0.0d+00 - - Call ccutoff (sc, ws, dimn, dimm, uc, wsnew) -! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - write(*,*)'OK ccutoff' - deallocate (ws) - deallocate (sc) - - Call ucramda_s_half (uc, wsnew, dimn, dimm) ! uc N*M matrix rewritten as uramda^(-1/2) -! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - deallocate(wsnew) - - write(*,*)'ucrams half OK' - Allocate(bc0(dimm, dimn)) ! bc0 M*N - bc0 = 0.0d+00 - bc0 = MATMUL(TRANSPOSE(DCONJG(uc)), bc) - Allocate(bc1(dimm, dimm)) ! bc1 M*M - bc1 = 0.0d+00 - bc1 = MATMUL(bc0, uc) - - If (debug) then - - write(*,*)'Check whether bc1 is hermite or not' - Do i = 1, dimm - Do j = i, dimm - if(ABS(bc1(i,j)-DCONJG(bc1(j,i))) > 1.0d-6) then - write(*,'(2I4,2E15.7)')i,j,bc1(i,j)-bc1(j,i) - End if - End do - End do - write(*,*)'Check whether bc1 is hermite or not END' - - End if - - deallocate (bc) - deallocate (bc0) - - cutoff = .FALSE. - - Allocate(wb(dimm)) - - write(*,*)'bC matrix is transrated to bc1(M*M matrix)!' - - Allocate(bc0(dimm,dimm)) - bc0 = bc1 - - Call cdiag(bc1, dimm, dammy, wb, thresd, cutoff) -! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - If (debug) then - - write(*,*)'Check whether bc is really diagonalized or not' - - Call checkdgc(dimm, bc0, bc1, wb) -! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - write(*,*)'Check whether bc is really diagonalized or not END' - - End if - - deallocate(bc0) - - write(*,*)'bC1 matrix is diagonalized!' - - e2 = 0.0d+00 - - - - Do i0 = 1, nabi - ja = ia0(i0) - jb = ib0(i0) - ji = ii0(i0) - - syma = MULTB2(isym, nsymrpa + 1) - syma = MULTB(irpmo(jb), syma) - syma = MULTB2(irpmo(ji), syma) - syma = MULTB(irpmo(ja), syma) - - If(nsymrpa==1.or.(nsymrpa/=1.and.(syma == nsymrpa + 1))) then - - Allocate(vc(dimn)) - - Do it = 1, dimn - vc(it) = v(i0,indt(it)+ninact) - Enddo - - Allocate(vc1(dimm)) - vc1 = 0.0d+00 - - vc1(1:dimm) = MATMUL(TRANSPOSE(DCONJG(uc(1:dimn,1:dimm))),vc(1:dimn)) - Deallocate (vc) - - alpha = -eps(ji) + eps(ja) + eps(jb) - e0 + eshift ! For Level Shift (2007/2/9) - - vc1(1:dimm) = MATMUL(TRANSPOSE(DCONJG(bc1(1:dimm,1:dimm))),vc1(1:dimm)) - - Do j = 1, dimm - e = (ABS(vc1(j))**2.0d+00)/(alpha+wb(j)) - sumc2local = sumc2local + e/(alpha+wb(j)) - e2(isym) = e2(isym) - e - End do - - deallocate(vc1) - - End if - - End do - - - - deallocate(uc) - deallocate(wb) - Deallocate (bc1) - - 1000 write(*,'("e2g(",I3,") = ",E20.10,"a.u.")')isym,e2(isym) - e2g = e2g + e2(isym) - - End do ! isym - - write(*,'("e2g = ",E20.10,"a.u.")')e2g - - write(*,'("sumc2,g = ",E20.10)')sumc2local - sumc2 = sumc2 + sumc2local - - - deallocate(iabi) - deallocate(ia0) - deallocate(ib0) - deallocate(ii0) - deallocate(v) - - - - continue - write(*,*)'end solvg_ord' - end - - - - - -! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= -! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= - - SUBROUTINE sGmat(dimn, indt, sc) ! Assume C1 molecule, overlap matrix S in space C - - -! S(u,t) = <0|Eut|0> -! -! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= -! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= - - use four_caspt2_module - - Implicit NONE - - integer, intent(in) :: dimn, indt(dimn) - complex*16, intent(out) :: sc(dimn,dimn) - - real*8 ::a,b - - integer :: it, iu - integer :: i, j - - - - sc = 0.0d+00 - - Do i = 1, dimn - it = indt(i) - - Do j = i, dimn - iu = indt(j) - a = 0.0d+0 - b = 0.0d+0 - - Call dim1_density & - (it, iu, a, b) - - sc(i,j) = DCMPLX(a,b) - sc(j,i) = DCMPLX(a,-b) -! write(*,*)i,j,sc(i,j) - End do !j - End do !i - - End subroutine sGmat - - - -! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= -! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= - - SUBROUTINE bGmat (dimn, sc, indt, bc) ! Assume C1 molecule, overlap matrix B in space C -! -! -! S(u,t) = <0|Eut|0> -! -! B(u,t) = Siguma_w [eps(w)<0|EutEww|0>] + S(u,t)(-eps(t)) -! -! -! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= -! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= - - use four_caspt2_module - - Implicit NONE - - integer :: it, iu, iw, jt, ju, jw - integer :: i, j - - integer, intent(in) :: dimn, indt(dimn) - complex*16, intent(in) :: sc(dimn,dimn) - complex*16, intent(out) :: bc(dimn,dimn) - - real*8 :: denr, deni - complex*16 :: den - - - bc(:,:) = 0.0d+00 - - write(*,*)'G space Bmat iroot=',iroot - - - Do i = 1, dimn - iu = indt(i) - ju = iu + ninact - - Do j = i, dimn - it = indt(j) - jt = it + ninact - -! B(u,t) = Siguma_w [eps(w)<0|EutEww|0>] + S(u,t)(-eps(t)) - - Do iw = 1, nact - jw = iw + ninact - - Call dim2_density & - (iu, it, iw, iw, denr, deni) - den = DCMPLX(denr, deni) - bc(i,j) = bc(i,j) + den*eps(jw) - - End do - -! bc(i, j) = bc(i, j) - sc(i, j)*eps(jt) - bc(i, j) = bc(i, j) - sc(i, j)*eps(ju) - -! write(*,*)'bc',i,j, bc(i,j) - bc(j, i) = DCONJG(bc(i, j)) - - - End do !i - End do !j - - - write(*,*)'bGmat is ended' - - End subroutine bGmat - - - -! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= -! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= - - SUBROUTINE vGmat_ord (nabi, iabi, v) -! -! V(t,iab) = [SIGUMA_p:active <0|Etp|0>{(ai|bp)-(ap|bi)}] -! -! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= -! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= - - use four_caspt2_module - - Implicit NONE - - - integer, intent(in) :: nabi, & - - & iabi(ninact+nact+1:ninact+nact+nsec,ninact+nact+1:ninact+nact+nsec,1:ninact) - - complex*16, intent(out) :: v(nabi, ninact+1:ninact+nact) - - real*8 :: dr, di, signij, signkl - complex*16 :: cint2, dens - - integer :: i, j, k, l, tabi - integer :: it, jt, il - - v = 0.0d+00 - -! V(t,iab) = [SIGUMA_p:active <0|Etp|0>{(ai|bp)-(ap|bi)}] a > b - - open(1, file ='Gint', status='old', form='unformatted') ! (31|32) stored - 30 read(1, err=10, end=20) i,j,k,l,cint2 - - if(i == k) goto 30 -! write(*,*) i,j,k,l,tabi,cint2 - - tabi = iabi(i, k, j) - - if (i < k) then - cint2 = -1.0d+00*cint2 - endif - - il = l - ninact - - Do it = 1, nact - jt = ninact+it - Call dim1_density (it, il, dr, di) - dens = DCMPLX(dr, di) - v(tabi,jt) = v(tabi, jt) + cint2*dens - End do ! it - - goto 30 - - 20 close(1) ; goto 100 - - 10 write(*,*) 'error while opening file Gint' ; goto 100 - - 100 write(*,*)'vGmat_ord is ended' - - end subroutine vGmat_ord - - - diff --git a/src/solvall_G_ord_ty.f90 b/src/solvall_G_ord_ty.f90 index 0e4b44d2..2323f96c 100644 --- a/src/solvall_G_ord_ty.f90 +++ b/src/solvall_G_ord_ty.f90 @@ -486,6 +486,7 @@ SUBROUTINE vGmat_ord_ty(nabi, iabi, v) ! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= use four_caspt2_module + use module_file_manager Implicit NONE #ifdef HAVE_MPI @@ -500,27 +501,25 @@ SUBROUTINE vGmat_ord_ty(nabi, iabi, v) complex*16 :: cint2, dens integer :: i, j, k, l, tabi - integer :: it, jt, il, iostat + integer :: it, iostat, twoint_unit integer :: datetmp0, datetmp1 real(8) :: tsectmp0, tsectmp1 + logical :: is_end_of_file if (rank == 0) print *, 'Enter vGmat. Please ignore timer under this line.' datetmp1 = date0; datetmp0 = date0 Call timing(date0, tsec0, datetmp0, tsectmp0) v = 0.0d+00 + twoint_unit = default_unit ! V(t,iab) = [SIGUMA_p:active <0|Etp|0>{(ai|bp)-(ap|bi)}] a > b - open (1, file=gint, status='old', form='unformatted') ! (31|32) stored + call open_unformatted_file(unit=twoint_unit, file=gint, status='old', optional_action='read') ! (31|32) stored do - read (1, iostat=iostat) i, j, k, l, cint2 - ! Exit the loop if the end of the file is reached - if (iostat < 0) then - if (rank == 0) print *, 'End of Gint' + read (twoint_unit, iostat=iostat) i, j, k, l, cint2 + call check_iostat(iostat=iostat, file=gint, end_of_file_reached=is_end_of_file) + if (is_end_of_file) then exit - elseif (iostat > 0) then - ! If iostat is greater than 0, error detected in the input file, so exit the program - stop 'Error: Error in reading Gint' end if if (i == k) cycle ! Go to the next line if i == k @@ -529,7 +528,6 @@ SUBROUTINE vGmat_ord_ty(nabi, iabi, v) if (i < k) then cint2 = -1.0d+00*cint2 end if - ! il = l - ninact Do it = 1, nact Call dim1_density(it, l, dr, di) @@ -538,8 +536,8 @@ SUBROUTINE vGmat_ord_ty(nabi, iabi, v) End do ! it end do + close (twoint_unit) - close (1) if (rank == 0) print *, 'vGmat_ord_ty is ended' #ifdef HAVE_MPI call MPI_Allreduce(MPI_IN_PLACE, v(1, 1), nabi*nact, MPI_COMPLEX16, MPI_SUM, MPI_COMM_WORLD, ierr) diff --git a/src/solvall_H_ord.f90 b/src/solvall_H_ord.f90 deleted file mode 100644 index baeb5b61..00000000 --- a/src/solvall_H_ord.f90 +++ /dev/null @@ -1,201 +0,0 @@ -! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= -! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= - - SUBROUTINE solvH_ord (e0, e2h) - -! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= -! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= - - use four_caspt2_module - - Implicit NONE - - real*8, intent(in) :: e0 - real*8, intent(out):: e2h - - Integer :: ia, ib, ii, ij, syma, sym1, sym2, i, j, k, l - Integer :: i0, j0, tab, nab, tij, nij, count - Integer,allocatable :: ia0(:), ib0(:), ii0(:), ij0(:), iab(:,:), iij(:,:) - Complex*16 :: cint2 - Complex*16,allocatable :: v(:,:) - Real*8 :: e, signij, signkl - Integer :: iii, jjj - - real*8 :: thresd - -! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= -! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= - -! SPACE H IS NOW CALCULATED -! -! EaiEbj|0> a > b, i > j -! -! DRAS1 =-2 DRAS2 = 0 DRAS3 = +2 -! -! -! S(ckdl,aibj) = d(ac)d(bd)d(lj)d(ik) -! -! (H0-E0S)ckdl,aibj = d(ac)d(bd)d(lj)d(ik)(eps(a)+eps(b)-eps(i)-eps(j)) = e(a,b,i,j) -! -! V(aibj) = (ai|bj) - (aj|bi) -! -! E2h = V(aibj)/e(a,b,i,j) - - -! thresd = 1.0D-08 -! thres = 1.0D-08 - - e2h = 0.0d+00 - e = 0.0d+00 - - i0 = 0 - Do ia = ninact+nact+1, ninact+nact+nsec - Do ib = ninact+nact+1, ia-1 - i0 = i0 + 1 - Enddo - Enddo - - nab = i0 - - Allocate(iab(ninact+nact+1:ninact+nact+nsec,ninact+nact+1:ninact+nact+nsec)) - Allocate(ia0(nab)) - Allocate(ib0(nab)) - iab = 0 - - i0 = 0 - Do ia = ninact+nact+1, ninact+nact+nsec - Do ib = ninact+nact+1, ia-1 - i0 = i0 + 1 - iab(ia, ib) = i0 - iab(ib, ia) = i0 - ia0(i0) = ia - ib0(i0) = ib - Enddo - Enddo - - i0 = 0 - Do ii =1, ninact - Do ij =1, ii-1 - i0 = i0 + 1 - Enddo - Enddo - - nij = i0 - Allocate(iij(1:ninact,1:ninact)) - Allocate(ii0(nij)) - Allocate(ij0(nij)) - iij = 0 - - i0 = 0 - Do ii =1, ninact - Do ij =1, ii-1 - i0 = i0 + 1 - iij(ii, ij) = i0 - iij(ij, ii) = i0 - ii0(i0) = ii - ij0(i0) = ij - Enddo - Enddo - - Allocate (v(nab, nij)) - v = 0.0d+00 - - open(1, file ='Hint', status='old', form='unformatted') - 30 read(1, err=10, end=20) i,j,k,l,cint2 - count = 0 - - 40 if(i<=k .or. j==l) goto 30 - -! write(*,*)i,j,k,l,cint2 - - tab = iab(i, k) - tij = iij(j, l) - -! write(*,*)tab,iab(i,k),i,k -! V(aibj) = (ai|bj) - (aj|bi) i > j, a > b - - if ( i > k .and. j > l) then - v(tab, tij) = v(tab, tij) + cint2 - - elseif( i > k .and. j < l) then - v(tab, tij) = v(tab, tij) - cint2 - - elseif( i < k .and. j > l) then ! (kl|ij) l > j + ; l < j - - v(tab, tij) = v(tab, tij) - cint2 - - elseif( i < k .and. j < l) then - v(tab, tij) = v(tab, tij) + cint2 - - endif - - goto 30 - -!Iwamuro modify - Do iii = 1, tab - Do jjj = 1, tij - IF(abs(v(iii, jjj)) > 1.0E-08)then - write(*,'("i,j,V_h ",2I4,2E15.7)') iii, jjj, v(iii, jjj) - Endif - Enddo - Enddo - - 20 close(1) - - write(*,*)'reading int2 is over' - - Do i0 = 1, nab - ia = ia0(i0) - ib = ib0(i0) - sym1 = MULTB(irpmo(ia), nsymrpa+1) - sym1 = MULTB(irpmo(ib), sym1) - Do j0 = 1, nij - ii = ii0(j0) - ij = ij0(j0) - sym2 = MULTB2(irpmo(ii), sym1) - sym2 = MULTB2(irpmo(ij), sym2) -!Iwamuro modify -! sym1 = MULTB2(irpmo(ia), nsymrpa+1) -! sym1 = MULTB(irpmo(ii), sym1) -! sym2 = MULTB2(irpmo(ij),nsymrpa+1) -! sym2 = MULTB(irpmo(ib), sym2) - - if(sym2 == nsymrpa+1) then -!Iwamuro modify -! if(sym1 == sym2) then - - e = eps(ia) + eps(ib) - eps(ii) - eps(ij) + eshift ! For Level Shift (2007/2/9) - - coeff1 = v(i0, j0)/e - sumc2local = sumc2local + ABS(coeff1)**2 - - e2h = e2h - DCONJG(v(i0, j0))*v(i0, j0)/e - endif - End do - End do - - write(*,'("e2h = ",E20.10,"a.u.")')e2h - - write(*,'("sumc2,h = ",E20.10)')sumc2local - sumc2 = sumc2 + sumc2local - - - - deallocate(v) - deallocate(iab) - deallocate(ia0) - deallocate(ib0) - deallocate(iij) - deallocate(ii0) - deallocate(ij0) - - - 10 continue !write(*,*)'error about opening Hint file' ;stop - 100 continue - write(*,*)'end solvh_ord' - End SUBROUTINE solvH_ord - - - - - - diff --git a/src/solvall_H_ord_ty.f90 b/src/solvall_H_ord_ty.f90 index 43003817..e4214e1e 100644 --- a/src/solvall_H_ord_ty.f90 +++ b/src/solvall_H_ord_ty.f90 @@ -7,6 +7,7 @@ SUBROUTINE solvH_ord_ty(e0, e2h) ! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= use four_caspt2_module + use module_file_manager Implicit NONE #ifdef HAVE_MPI @@ -14,12 +15,13 @@ SUBROUTINE solvH_ord_ty(e0, e2h) #endif real*8, intent(in) :: e0 real*8, intent(out):: e2h - Integer :: ia, ib, ii, ij, syma, symb, i, j, k, l - Integer :: i0, j0, tab, nab, tij, nij, iostat + Integer :: ia, ib, ii, ij, syma, symb, i, j, k, l + Integer :: i0, j0, tab, nab, tij, nij, iostat, twoint_unit Integer, allocatable :: ia0(:), ib0(:), ii0(:), ij0(:), iab(:, :), iij(:, :) - Complex*16 :: cint2 + Complex*16 :: cint2 Complex*16, allocatable :: v(:, :) - Real*8 :: e + Real*8 :: e + logical :: is_end_of_file ! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= ! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= @@ -44,6 +46,7 @@ SUBROUTINE solvH_ord_ty(e0, e2h) e2h = 0.0d+00 e = 0.0d+00 + twoint_unit = default_unit i0 = 0 Do ia = ninact + nact + 1, ninact + nact + nsec @@ -97,16 +100,12 @@ SUBROUTINE solvH_ord_ty(e0, e2h) Allocate (v(nab, nij)) v = 0.0d+00 - open (1, file=hint, status='old', form='unformatted') + call open_unformatted_file(unit=twoint_unit, file=hint, status='old', optional_action='read') do - read (1, iostat=iostat) i, j, k, l, cint2 - ! Exit the loop if the end of the file is reached - if (iostat < 0) then - if (rank == 0) print *, 'End of Eint' + read (twoint_unit, iostat=iostat) i, j, k, l, cint2 + call check_iostat(iostat=iostat, file=hint, end_of_file_reached=is_end_of_file) + if (is_end_of_file) then exit - elseif (iostat > 0) then - ! If iostat is greater than 0, error detected in the input file, so exit the program - stop 'Error: Error in reading Eint' end if if (i <= k .or. j == l) cycle ! Read the next line if i <= k or j == l @@ -128,12 +127,12 @@ SUBROUTINE solvH_ord_ty(e0, e2h) end if end do + close (twoint_unit) - close (1) #ifdef HAVE_MPI call MPI_Allreduce(MPI_IN_PLACE, v(1, 1), nab*nij, MPI_COMPLEX16, MPI_SUM, MPI_COMM_WORLD, ierr) #endif - if (rank == 0) print *, 'reading int2 is over' + if (rank == 0) print *, 'reading Hint is over' Do i0 = 1, nab ia = ia0(i0) diff --git a/src/trac.f90 b/src/trac.f90 index 9975c273..884bb9ad 100644 --- a/src/trac.f90 +++ b/src/trac.f90 @@ -29,18 +29,14 @@ SUBROUTINE traci(fa) ! Transform CI matrix for new spinor basis Do i0 = 1, ndet i = 0 ok = 0 - Do j0 = 0, 31 - if (btest(idet(i0), j0)) then + Do j0 = 0, 63 ! 64 bits integer are possible with 64 spinors + if (btest(idet(i0), j0)) then ! This condition should be true nelec times i = i + 1 - Do ii = 1, nact - if (ii == j0 + 1) then ! j0+1 means occupied spinor labeled by casci - occ(i, i0) = ii ! This is energetic order inside active spinor! - ok = ok + 1 - goto 200 - End if - End do - -200 end if + if (j0 + 1 <= nact) then ! j0+1 means occupied spinor labeled by casci + occ(i, i0) = j0 + 1 ! This is energetic order inside active spinor! + ok = ok + 1 + End if + end if End do End do @@ -203,6 +199,7 @@ SUBROUTINE tracic(fac) ! Transform CI matrix for new spinor basis ! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= use four_caspt2_module + use module_file_manager Implicit NONE #ifdef HAVE_MPI @@ -211,7 +208,7 @@ SUBROUTINE tracic(fac) ! Transform CI matrix for new spinor basis complex*16, intent(in) :: fac(ninact + 1:ninact + nact, ninact + 1:ninact + nact) integer :: i0, j0, i, info - integer :: ii, ok + integer :: ok, newcicoeff_unit integer :: occ(nelec, ndet) integer, allocatable :: IPIV(:) @@ -230,18 +227,14 @@ SUBROUTINE tracic(fac) ! Transform CI matrix for new spinor basis Do i0 = 1, ndet i = 0 ok = 0 - Do j0 = 0, 31 - if (btest(idet(i0), j0)) then + Do j0 = 0, 63 ! 64 bits integer are possible with 64 spinors + if (btest(idet(i0), j0)) then ! This condition should be true nelec times i = i + 1 - Do ii = 1, nact - if (ii == j0 + 1) then ! j0+1 means occupied spinor labeled by casci - occ(i, i0) = ii ! This is energetic order inside active spinor! - ok = ok + 1 - goto 200 - End if - End do - -200 end if + if (j0 + 1 <= nact) then ! j0+1 means occupied spinor labeled by casci + occ(i, i0) = j0 + 1 ! This is energetic order inside active spinor! + ok = ok + 1 + End if + end if End do End do if (rank == 0) print *, 'Before allocate a matrix named ds' @@ -362,13 +355,13 @@ SUBROUTINE tracic(fac) ! Transform CI matrix for new spinor basis cir(1:ndet, selectroot) = DBLE(ci(1:ndet)) cii(1:ndet, selectroot) = DIMAG(ci(1:ndet)) if (rank == 0) then ! Only master ranks are allowed to create files used by CASPT2 except for MDCINTNEW. - open (5, file='NEWCICOEFF', status='unknown', form='unformatted') - write (5) ci(1:ndet) - close (5) + newcicoeff_unit = default_unit + call open_unformatted_file(unit=newcicoeff_unit, file="NEWCICOEFF", status='replace', optional_action='write') + write (newcicoeff_unit) ci(1:ndet) + close (newcicoeff_unit) end if Deallocate (ci) - Deallocate (ds) End subroutine tracic diff --git a/src/tramo.f90 b/src/tramo.f90 deleted file mode 100644 index 3928f7c2..00000000 --- a/src/tramo.f90 +++ /dev/null @@ -1,201 +0,0 @@ -! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= -! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= - - SUBROUTINE tramo1 ( i, j, int1) - -! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= -! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= - - use four_caspt2_module - - Implicit NONE - integer, intent(in) :: i, j - complex*16, intent(out) :: int1 - - - integer :: i0, j0, sym1, sym2 - integer :: n(2,2), mo(2) - - -! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= -! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= - - - int1 = 0.0d+00 - n(:,:)= 0 - sym1 = irpamo(i) - sym2 = irpamo(j) - - If(sym1 == sym2) then - - mo(1) = i - mo(2) = j - - Do i0 = 1, 2 - if( mo(i0) <= ninact ) then - n(i0,1) = 1 - n(i0,2) = ninact - elseif( mo(i0) >= ninact+1 .and. mo(i0) <= ninact+nact ) then - n(i0,1) = ninact+1 - n(i0,2) = ninact+nact - elseif( mo(i0) >= ninact+nact+1 .and. mo(i0) <= ninact+nact+nsec ) then - n(i0,1) = ninact+nact+1 - n(i0,2) = ninact+nact+nsec - endif - End do ! i0 - - do i0 = n(1,1), n(1,2) - do j0 = n(2,1), n(2,2) - If(irpamo(i0) ==sym1 .and. irpamo(j0) ==sym2) then - int1 = int1 + DCONJG(f(i0,i))*CMPLX(oner(i0,j0),onei(i0,j0),16)*f(j0,j) - Endif - end do - end do - - Endif - - End subroutine tramo1 - - - - -! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= -! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= - - SUBROUTINE tramo2 ( i, j, k, l, int2) - -! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= -! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= - - use four_caspt2_module - - Implicit NONE - integer, intent(in) :: i, j, k, l - - complex*16,intent(out) :: int2 - - - integer :: i0, j0, k0, l0, sym1, sym2, sym3, sym4, sym5, sym6 - integer :: n(4,2), mo(4) - integer :: nint, tcount, count - - real*8 :: i2r, i2i, nsign - complex*16 :: cmplxint - -! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= -! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= - - - int2 = 0.0d+00 - cmplxint = 0.0d+00 - n = 0 - sym1 = irpamo(i) - sym2 = irpamo(j) - sym3 = irpamo(k) - sym4 = irpamo(l) - - sym5 = MULTB2(sym1,nsymrpa+1) - sym5 = MULTB (sym2, sym5) - sym6 = MULTB2(sym4,nsymrpa+1) - sym6 = MULTB (sym3, sym6) - -! if (i==1 .and. j==1.and. k==2.and.l==2) then -! write(*,*)"sym",sym1,sym2,sym3,sym4,sym5,sym6 -! endif - -! If(MULTB(sym1,sym2) == MULTB(sym3,sym4)) then - If(sym5 == sym6) then - -!Iwamuro modify -! if (i==1 .and. j==1.and. k==2.and.l==2) then -! write(*, *) "1122" -! endif - - mo(1) = i - mo(2) = j - mo(3) = k - mo(4) = l - - Do i0 = 1, 4 - - if( mo(i0) <= ninact ) then - - n(i0,1) = 1 - n(i0,2) = ninact - - elseif( mo(i0) >= ninact+1 .and. mo(i0) <= ninact+nact ) then - - n(i0,1) = ninact+1 - n(i0,2) = ninact+nact - - elseif( mo(i0) >= ninact+nact+1 .and. mo(i0) <= ninact+nact+nsec ) then - - n(i0,1) = ninact+nact+1 - n(i0,2) = ninact+nact+nsec - - - endif -! Iwamuro modify -! write(*,*) " mo(i0), n(i0,1), n(i0,2) =", mo(i0), n(i0,1), n(i0,2) -! if(debug) write(*,*) mo(i0), n(i0, 1), n(i0, 2) - - End do ! i0 - tcount = 0 - count = 0 - - - do i0 = n(1,1), n(1,2) - do j0 = n(2,1), n(2,2) - do k0 = n(3,1), n(3,2) - do l0 = n(4,1), n(4,2) - tcount = tcount + 1 - - If(irpamo(i0) == sym1 .and. irpamo(j0) == sym2 .and. & - & irpamo(k0) == sym3 .and. irpamo(l0) == sym4 ) then - -! if (i==1 .and. j==1.and. k==2.and.l==2) then -! write(*, '("1122",4I4,10E15.5)') i0, j0, k0, l0, i2r, i2i, (f(i0,i)),(f(k0,k)),(j0,j),f(l0,l) -! endif - -! if (i==1 .and. j==1.and. k==1.and.l==1) then -! write(*, '("1111",4I4,10E15.5)') i0, j0, k0, l0, i2r, i2i, (f(i0,i)),(f(k0,k)),f(j0,j),f(l0,l) -! endif - - count = count +1 - cmplxint = 0.0d+00 - - nint = ABS(indtwr(i0,j0,k0,l0)) - nsign = SIGN(1,indtwr(i0,j0,k0,l0)) - i2r = int2r(nint)*nsign - nsign = SIGN(1,indtwi(i0,j0,k0,l0)) - i2i = int2i(nint)*nsign - - cmplxint = CMPLX(i2r, i2i, 16) - - int2 = int2 + DCONJG(f(i0,i))*DCONJG(f(k0,k))*f(j0,j)*f(l0,l)*cmplxint - -!Iwamuro modify -! write(*,*) "nint, nsign, i2r =", nint, nsign, i2r -! write(*,*) "i2i, cmplxint =", i2i, cmplxint -! write(*,'(4I4, 2E15.5)') i0, j0, k0, l0, i2r, i2i -! write(*,'(4I4,8E15.5)') i0, j0, k0, l0, f(i0,i),f(j0,j),f(k0,k),f(l0,l) -! write(*,'(4I4,4E15.5)') i0, j0, k0, l0, int2, cmplxint -! write(*,'(8E10.4)') f(i0,i),f(j0,j),f(k0,k),f(l0,l) - - - - Endif - - end do - end do - end do - end do - -! Iwamuro modify -! write(*,*) "tcount, count =", tcount, count - - Endif - - End subroutine tramo2 - - diff --git a/src/utchem.makeconfig b/src/utchem.makeconfig deleted file mode 100644 index 614d1273..00000000 --- a/src/utchem.makeconfig +++ /dev/null @@ -1,82 +0,0 @@ -/home/minori/PROGRAMS/utchem_rq37_new/utchem/config/makeconfig - -# ##################################### -# FROM general.makeconfig.in -# ##################################### - - UTCHEM_TOP = /home/minori/PROGRAMS/utchem_rq37_new/utchem - LAPACK_COMP = YES - LAPACK95_COMP = YES - BLAS_COMP = YES - LAPACKLIB = /home/minori/PROGRAMS/utchem_rq37_new/utchem/lib/LINUX64/liblapack.a - LAPACK95LIB = /home/minori/PROGRAMS/utchem_rq37_new/utchem/lib/LINUX64/liblapack95.a - BLASLIB = /home/minori/PROGRAMS/utchem_rq37_new/utchem/lib/LINUX64/libblas.a - HOSTTYPE = linux_ifc - GADIR = ga4-0-2 - - BIN = /home/minori/PROGRAMS/utchem_rq37_new/utchem/bin/$(TARGET) - LIB = /home/minori/PROGRAMS/utchem_rq37_new/utchem/lib/$(TARGET) - INCLUDE = /home/minori/PROGRAMS/utchem_rq37_new/utchem/include - LOCALBIN = . - LOCALLIB = . - LOCALINC = . - - PYTHON = /usr/bin/python - - LDFLAGS_NOMAIN = -# ##################################### -# FROM linux_intel8.makeconfig.in -# ##################################### - - TARGET = LINUX64 - - USE_INTEGER4 = - USE_INTEGER8 = yes - - LARGE_FILES = yes - - DMACRO = -# DMACRO+=-DSUPPORT_R16 -# DMACRO+=-DHAVE_ERF - - INC = -I$(INCLUDE) -I$(LOCALINC) - MOD = -module $(LOCALINC) - INCMOD = $(INC) $(MOD) - -# FCONVERT = - - F77C = ifort - F77FLAGS = $(DMACRO) $(INCMOD) -FI -cm -w90 -w95 -pad -O2 -mp1 -i8 -integer_size 64 -prefetch -unroll - F77FLAGSNOOPT = $(DMACRO) $(INCMOD) -FI -cm -w90 -w95 -pad -O0 -i8 -integer_size 64 - - F90C = ifort - F90FLAGS = $(DMACRO) $(INCMOD) -FR -cm -w90 -w95 -pad -O2 -mp1 -i8 -integer_size 64 -prefetch -unroll - F90FLAGSNOOPT = $(DMACRO) $(INCMOD) -FR -cm -w90 -w95 -pad -O0 -i8 -integer_size 64 - - MODSUFFIX = mod - - CC = gcc - CFLAGS = $(INC) -O2 -funroll-loops -DLINUX -DEXT_INT - - CXX = g++ - CXXFLAGS = $(INC) -O2 -funroll-loops -DLINUX -DEXT_INT - - LD = ifort - LDFLAGS = -DIFC8 -L$(LIB) -L$(LOCALLIB) -i8 -integer_size 64 - LDFLAGS_NOMAIN = -nofor_main - - AR = ar - ARFLAGS = cr - RANLIB = ranlib - - MAKE = gmake - - SHELL = /bin/sh - MV = /bin/mv -f - RM = /bin/rm -f - CP = /bin/cp -f - MKDIR = /bin/mkdir - LN = /bin/ln - - GALIBS = -lglobal -lma -larmci -ltcgmsg -lpario -~ diff --git a/test/conftest.py b/test/conftest.py index b88bf30e..0659c782 100644 --- a/test/conftest.py +++ b/test/conftest.py @@ -15,6 +15,7 @@ def pytest_addoption(parser): help="run tests in parallel processes", ) + @pytest.fixture def the_number_of_process(request): return request.config.getoption("--parallel") diff --git a/test/h2/test_h2.py b/test/h2/test_h2.py index 12523d8c..72891ac4 100644 --- a/test/h2/test_h2.py +++ b/test/h2/test_h2.py @@ -11,7 +11,7 @@ ) -def test_h2o(the_number_of_process: int) -> None: +def test_h2(the_number_of_process: int) -> None: # Set file names ref_filename = "reference.H2.out" # Reference diff --git a/test/h2o/sh_new b/test/h2o/sh_new deleted file mode 100644 index e2df5d33..00000000 --- a/test/h2o/sh_new +++ /dev/null @@ -1,8 +0,0 @@ -#!/bin/sh - -casci=/home/noda/rel-caspt2/bin/r4dcascicoexe -caspt2=/home/noda/rel-caspt2/bin/r4dcaspt2ocoexe - -$casci > H2O.caspt2.out -$caspt2 >> H2O.caspt2.out - diff --git a/test/lower_MPI_h2/decimal.py b/test/lower_MPI_h2/decimal.py deleted file mode 100644 index d1ebc1ed..00000000 --- a/test/lower_MPI_h2/decimal.py +++ /dev/null @@ -1,3 +0,0 @@ -a = 1e-8 -print(a) - diff --git a/test/module_testing.py b/test/module_testing.py index 233d966c..159c90a6 100644 --- a/test/module_testing.py +++ b/test/module_testing.py @@ -12,31 +12,28 @@ def delete_scratch_files(delete_files: "list[str]", test_path: str) -> None: def is_binary_file_exist(binary_file: str) -> None: if not os.path.exists(binary_file): - error_message = ( - f"ERROR: {binary_file} is not exist.\nPlease build {binary_file} first." - ) + error_message = f"ERROR: {binary_file} is not exist.\nPlease build {binary_file} first." raise Exception(error_message) def create_test_command(the_number_of_process: int, binaries: "list[str]") -> str: + test_command = "" if the_number_of_process > 1: # If the number of process is greater than 1, use MPI for idx, binary in enumerate(binaries): if idx == 0: test_command = f"mpirun -np {the_number_of_process} {binary}" else: - test_command += f" && mpirun -np {the_number_of_process} {binary}" + test_command = f"{test_command} && mpirun -np {the_number_of_process} {binary}" else: # If the number of process is 1, use serial for idx, binary in enumerate(binaries): if idx == 0: test_command = f"{binary}" else: - test_command += f" && {binary}" + test_command = f"{test_command} && {binary}" return test_command -def run_test( - test_command: str, output_file_path: str -) -> "subprocess.CompletedProcess[str]": +def run_test(test_command: str, output_file_path: str) -> "subprocess.CompletedProcess[str]": with open(output_file_path, "w") as file_output: process = subprocess.run( test_command, @@ -49,18 +46,14 @@ def run_test( def check_test_returncode(process: "subprocess.CompletedProcess[str]") -> None: if process.returncode != 0: - raise Exception( - "ERROR: Process failed. return code status : " + str(process.returncode) - ) + raise Exception("ERROR: Process failed. return code status : " + str(process.returncode)) def get_caspt2_energy_from_output_file(file_path: str) -> float: with open(file_path, encoding="utf-8", mode="r") as output_file: try: # (e.g. ['Total energy is -1.117672932144052 a.u.']) - grep_str: list[str] = [ - s.strip() for s in output_file.readlines() if "Total energy is" in s - ] + grep_str: list[str] = [s.strip() for s in output_file.readlines() if "Total energy is" in s] caspt2_energy = float(grep_str[-1].split()[-2]) # (e.g. -1.117672932144052) return caspt2_energy except Exception as error: # Failed to get the reference data @@ -72,8 +65,7 @@ def get_stripped_string_from_output_file(file_path: str) -> str: with open(file_path, encoding="utf-8", mode="r") as output_file: try: string = output_file.read() - string = string.strip() - return string + return string.strip() except Exception as error: # Failed to get the reference data error_message = f"{error}\nERROR: Failed to get the data from the reference file {file_path}." raise Exception(error_message) @@ -83,8 +75,7 @@ def get_split_string_list_from_output_file(file_path: str) -> "list[str]": with open(file_path, encoding="utf-8", mode="r") as output_file: try: string = output_file.read() - string = string.strip().split() - return string + return string.strip().split() except Exception as error: # Failed to get the reference data error_message = f"{error}\nERROR: Failed to get the data from the reference file {file_path}." raise Exception(error_message) diff --git a/test/lower_MPI_h2/MDCINT b/test/multiple_mdcint_h2/MDCINT similarity index 100% rename from test/lower_MPI_h2/MDCINT rename to test/multiple_mdcint_h2/MDCINT diff --git a/test/lower_MPI_h2/MDCINXXXX1 b/test/multiple_mdcint_h2/MDCINXXXX1 similarity index 100% rename from test/lower_MPI_h2/MDCINXXXX1 rename to test/multiple_mdcint_h2/MDCINXXXX1 diff --git a/test/lower_MPI_h2/MDCINXXXX2 b/test/multiple_mdcint_h2/MDCINXXXX2 similarity index 100% rename from test/lower_MPI_h2/MDCINXXXX2 rename to test/multiple_mdcint_h2/MDCINXXXX2 diff --git a/test/lower_MPI_h2/MRCONEE b/test/multiple_mdcint_h2/MRCONEE similarity index 100% rename from test/lower_MPI_h2/MRCONEE rename to test/multiple_mdcint_h2/MRCONEE diff --git a/test/lower_MPI_h2/active.inp b/test/multiple_mdcint_h2/active.inp similarity index 100% rename from test/lower_MPI_h2/active.inp rename to test/multiple_mdcint_h2/active.inp diff --git a/test/lower_MPI_h2/reference.H2.out b/test/multiple_mdcint_h2/reference.H2.out similarity index 100% rename from test/lower_MPI_h2/reference.H2.out rename to test/multiple_mdcint_h2/reference.H2.out diff --git a/test/lower_MPI_h2/test_lower_MPI_h2.py b/test/multiple_mdcint_h2/test_multiple_mdcint_h2.py similarity index 97% rename from test/lower_MPI_h2/test_lower_MPI_h2.py rename to test/multiple_mdcint_h2/test_multiple_mdcint_h2.py index 12523d8c..20be1596 100644 --- a/test/lower_MPI_h2/test_lower_MPI_h2.py +++ b/test/multiple_mdcint_h2/test_multiple_mdcint_h2.py @@ -11,7 +11,7 @@ ) -def test_h2o(the_number_of_process: int) -> None: +def test_multiple_mdcint_h2(the_number_of_process: int) -> None: # Set file names ref_filename = "reference.H2.out" # Reference diff --git a/test/unit_test/lowercase/CMakeLists.txt b/test/unit_test/lowercase/CMakeLists.txt index 52cf7213..91f5d96e 100644 --- a/test/unit_test/lowercase/CMakeLists.txt +++ b/test/unit_test/lowercase/CMakeLists.txt @@ -5,6 +5,7 @@ set(CMAKE_RUNTIME_OUTPUT_DIRECTORY ${CMAKE_CURRENT_SOURCE_DIR}) add_executable(test_lowercase_exe ${CMAKE_SOURCE_DIR}/src/four_caspt2_module.f90 ${CMAKE_SOURCE_DIR}/src/mem.f90 + ${CMAKE_SOURCE_DIR}/src/module_file_manager.f90 ${CMAKE_SOURCE_DIR}/src/module_sort_swap.f90 ${CMAKE_SOURCE_DIR}/src/read_input_module.f90 test_lowercase.f90 diff --git a/test/unit_test/lowercase/test_lowercase.f90 b/test/unit_test/lowercase/test_lowercase.f90 index 57b23935..f6b6c2df 100644 --- a/test/unit_test/lowercase/test_lowercase.f90 +++ b/test/unit_test/lowercase/test_lowercase.f90 @@ -1,16 +1,18 @@ program main + use module_file_manager use read_input_module implicit none character(100) :: input character(:), allocatable :: string - integer :: count - count = 1 - open (5, file='input', form='formatted') - read (5, '(a)') input + integer :: count, new_unit + count = 1; new_unit = 20 + call open_formatted_file(unit=new_unit, file='input', status="old", optional_action='read') + read (new_unit, '(a)') input string = trim(input) - close (5) + close(new_unit) + call lowercase(string) - open (2, file='result.out', form="formatted") - write (2, *) string - close (2) + call open_formatted_file(unit=new_unit, file='result.out', status="replace", optional_action='write') + write (new_unit, *) string + close (new_unit) end program main diff --git a/test/unit_test/ras3_bitcheck/CMakeLists.txt b/test/unit_test/ras3_bitcheck/CMakeLists.txt index d39922a0..e69de29b 100644 --- a/test/unit_test/ras3_bitcheck/CMakeLists.txt +++ b/test/unit_test/ras3_bitcheck/CMakeLists.txt @@ -1,16 +0,0 @@ -cmake_minimum_required(VERSION 3.7) - -message(STATUS "CMAKE_SOURCE_DIR =${CMAKE_SOURCE_DIR}") -message(STATUS "CMAKE_BINARY_DIR =${CMAKE_BINARY_DIR}") -message(STATUS "CMAKE_CURRENT_BINARY_DIR=${CMAKE_CURRENT_BINARY_DIR}") - -set(CMAKE_RUNTIME_OUTPUT_DIRECTORY ${CMAKE_CURRENT_SOURCE_DIR}) - -add_executable(ras3_bitcheck_exe - ${CMAKE_SOURCE_DIR}/src/four_caspt2_module.f90 - ${CMAKE_SOURCE_DIR}/src/mem.f90 - ${CMAKE_SOURCE_DIR}/src/module_sort_swap.f90 - ${CMAKE_SOURCE_DIR}/src/read_input_module.f90 - ${CMAKE_SOURCE_DIR}/src/ras_det_check.f90 - test_ras3_bitcheck.f90 -) diff --git a/test/unit_test/ras3_bitcheck/test_ras3_bitcheck.f90 b/test/unit_test/ras3_bitcheck/test_ras3_bitcheck.f90 index 7ba9733a..28d9561d 100644 --- a/test/unit_test/ras3_bitcheck/test_ras3_bitcheck.f90 +++ b/test/unit_test/ras3_bitcheck/test_ras3_bitcheck.f90 @@ -1,19 +1,24 @@ program ras3_bitcheck use four_caspt2_module + use module_file_manager use read_input_module use ras_det_check implicit none - integer :: i + integer :: i, new_unit logical :: is_allow - call read_input - open (10, file="result", form="formatted") + new_unit = 20 + call open_formatted_file(unit=new_unit, file='active.inp', status="old", optional_action='read') + call read_input(new_unit) + close (new_unit) + + call open_formatted_file(unit=new_unit, file='result', status="old", optional_action='write') do i = 1, 2**nact - 1 is_allow = ras3_det_check(i, ras3_max_elec) if (is_allow) then print '(i4,b20)', i, i - write (10, '(i4,b20)'), i, i + write (new_unit, '(i4,b20)') i, i end if end do - close (10) + close (new_unit) end program ras3_bitcheck diff --git a/test/unit_test/ras_input_reader/CMakeLists.txt b/test/unit_test/ras_input_reader/CMakeLists.txt index 8864cb68..6ac97820 100644 --- a/test/unit_test/ras_input_reader/CMakeLists.txt +++ b/test/unit_test/ras_input_reader/CMakeLists.txt @@ -5,6 +5,7 @@ set(CMAKE_RUNTIME_OUTPUT_DIRECTORY ${CMAKE_CURRENT_SOURCE_DIR}) add_executable(test_ras_input_reader_exe ${CMAKE_SOURCE_DIR}/src/four_caspt2_module.f90 ${CMAKE_SOURCE_DIR}/src/mem.f90 + ${CMAKE_SOURCE_DIR}/src/module_file_manager.f90 ${CMAKE_SOURCE_DIR}/src/module_sort_swap.f90 ${CMAKE_SOURCE_DIR}/src/read_input_module.f90 test_ras_input_reader.f90 diff --git a/test/unit_test/ras_input_reader/test_ras_input_reader.f90 b/test/unit_test/ras_input_reader/test_ras_input_reader.f90 index 835576e3..28acfa0c 100644 --- a/test/unit_test/ras_input_reader/test_ras_input_reader.f90 +++ b/test/unit_test/ras_input_reader/test_ras_input_reader.f90 @@ -1,11 +1,13 @@ program main use four_caspt2_module, only: ras3_list + use module_file_manager use read_input_module implicit none - open (5, file='input', form='formatted') - call ras_read(ras3_list, 3) - close (5) - open (2, file='result.out', form="formatted") - write (2, *) ras3_list - close (2) + integer :: new_unit = 20 + call open_formatted_file(unit=new_unit, file='input', status='old', optional_action='read') + call ras_read(new_unit, ras3_list, 3) + close (new_unit) + call open_formatted_file(unit=new_unit, file='result.out', status='old', optional_action='write') + write (new_unit, *) ras3_list + close (new_unit) end program main diff --git a/test/unit_test/ras_input_reader/test_ras_input_reader.py b/test/unit_test/ras_input_reader/test_ras_input_reader.py index 904ae9f1..e6d5c6ec 100644 --- a/test/unit_test/ras_input_reader/test_ras_input_reader.py +++ b/test/unit_test/ras_input_reader/test_ras_input_reader.py @@ -29,16 +29,13 @@ def test_ras_input_reader(): latest_passed_path = os.path.abspath(os.path.join(test_path, latest_passed_output)) exe_file_path = os.path.abspath(os.path.join(test_path, exe_filename)) - test_command = create_test_command( - the_number_of_process=1, binaries=[exe_file_path] - ) + test_command = create_test_command(the_number_of_process=1, binaries=[exe_file_path]) process = run_test(test_command, output_file_path) check_test_returncode(process) string_ref = get_split_string_list_from_output_file(ref_file_path) ref_int_list = convert_string_list_to_integer_list(string_ref) - string_result = get_split_string_list_from_output_file(output_file_path) result_int_list = convert_string_list_to_integer_list(string_result) diff --git a/test/unit_test/sort_test/CMakeLists.txt b/test/unit_test/sort_test/CMakeLists.txt index fa84d91d..1dce4dad 100644 --- a/test/unit_test/sort_test/CMakeLists.txt +++ b/test/unit_test/sort_test/CMakeLists.txt @@ -3,18 +3,30 @@ cmake_minimum_required(VERSION 3.7) set(CMAKE_RUNTIME_OUTPUT_DIRECTORY ${CMAKE_CURRENT_SOURCE_DIR}) add_executable(test_sort_int_exe + ${CMAKE_SOURCE_DIR}/src/four_caspt2_module.f90 + ${CMAKE_SOURCE_DIR}/src/module_file_manager.f90 ${CMAKE_SOURCE_DIR}/src/module_sort_swap.f90 + ${CMAKE_SOURCE_DIR}/src/read_input_module.f90 test_sort_int.f90 ) add_executable(test_sort_int_reverse_exe + ${CMAKE_SOURCE_DIR}/src/four_caspt2_module.f90 + ${CMAKE_SOURCE_DIR}/src/module_file_manager.f90 ${CMAKE_SOURCE_DIR}/src/module_sort_swap.f90 + ${CMAKE_SOURCE_DIR}/src/read_input_module.f90 test_sort_int_reverse.f90 ) add_executable(test_sort_real_exe + ${CMAKE_SOURCE_DIR}/src/four_caspt2_module.f90 + ${CMAKE_SOURCE_DIR}/src/module_file_manager.f90 ${CMAKE_SOURCE_DIR}/src/module_sort_swap.f90 + ${CMAKE_SOURCE_DIR}/src/read_input_module.f90 test_sort_real.f90 ) add_executable(test_sort_real_reverse_exe + ${CMAKE_SOURCE_DIR}/src/four_caspt2_module.f90 + ${CMAKE_SOURCE_DIR}/src/module_file_manager.f90 ${CMAKE_SOURCE_DIR}/src/module_sort_swap.f90 + ${CMAKE_SOURCE_DIR}/src/read_input_module.f90 test_sort_real_reverse.f90 ) diff --git a/test/unit_test/sort_test/test_sort.py b/test/unit_test/sort_test/test_sort.py index ac54a380..f80231cc 100644 --- a/test/unit_test/sort_test/test_sort.py +++ b/test/unit_test/sort_test/test_sort.py @@ -29,9 +29,7 @@ def test_int_sort(): latest_passed_path = os.path.abspath(os.path.join(test_path, latest_passed_output)) exe_file_path = os.path.abspath(os.path.join(test_path, exe_filename)) - test_command = create_test_command( - the_number_of_process=1, binaries=[exe_file_path] - ) + test_command = create_test_command(the_number_of_process=1, binaries=[exe_file_path]) process = run_test(test_command, output_file_path) check_test_returncode(process) @@ -91,9 +89,7 @@ def test_int_sort_reverse(): latest_passed_path = os.path.abspath(os.path.join(test_path, latest_passed_output)) exe_file_path = os.path.abspath(os.path.join(test_path, exe_filename)) - test_command = create_test_command( - the_number_of_process=1, binaries=[exe_file_path] - ) + test_command = create_test_command(the_number_of_process=1, binaries=[exe_file_path]) process = run_test(test_command, output_file_path) check_test_returncode(process) @@ -122,9 +118,7 @@ def test_int_sort_reverse(): 156, 189, ] - reference_list.sort( - reverse=True - ) # 189,175,174,173,172,171,170,169,156,16,15,14,13,12,11,10,9,8,5,3,1 + reference_list.sort(reverse=True) # 189,175,174,173,172,171,170,169,156,16,15,14,13,12,11,10,9,8,5,3,1 string_result = get_split_string_list_from_output_file(output_file_path) result_int_list = convert_string_list_to_integer_list(string_result) @@ -155,9 +149,7 @@ def test_real_sort(): latest_passed_path = os.path.abspath(os.path.join(test_path, latest_passed_output)) exe_file_path = os.path.abspath(os.path.join(test_path, exe_filename)) - test_command = create_test_command( - the_number_of_process=1, binaries=[exe_file_path] - ) + test_command = create_test_command(the_number_of_process=1, binaries=[exe_file_path]) process = run_test(test_command, output_file_path) check_test_returncode(process) @@ -181,9 +173,7 @@ def test_real_sort(): def test_real_sort_reverse(): # Set file names - output_filename = ( - "real_reverse.out" # Output (This file is compared with Reference) - ) + output_filename = "real_reverse.out" # Output (This file is compared with Reference) latest_passed_output = "latest_passed.real_reverse.out" # latest passed output (After test, the output file is moved to this) exe_filename = "test_sort_real_reverse_exe" # Executable file @@ -197,18 +187,14 @@ def test_real_sort_reverse(): latest_passed_path = os.path.abspath(os.path.join(test_path, latest_passed_output)) exe_file_path = os.path.abspath(os.path.join(test_path, exe_filename)) - test_command = create_test_command( - the_number_of_process=1, binaries=[exe_file_path] - ) + test_command = create_test_command(the_number_of_process=1, binaries=[exe_file_path]) process = run_test(test_command, output_file_path) check_test_returncode(process) # Reference data reference_list: list[float] = [8.1, -9.2, 10000.58, -897, 123456789, 0.0000000010] - reference_list.sort( - reverse=True - ) # 123456789, 10000.58, 8.1, 0.0000000010, -9.2, -897 + reference_list.sort(reverse=True) # 123456789, 10000.58, 8.1, 0.0000000010, -9.2, -897 string_result = get_split_string_list_from_output_file(output_file_path) result_real_list = convert_string_list_to_float_list(string_result) diff --git a/test/unit_test/sort_test/test_sort_int.f90 b/test/unit_test/sort_test/test_sort_int.f90 index b39516bb..ac76e15b 100644 --- a/test/unit_test/sort_test/test_sort_int.f90 +++ b/test/unit_test/sort_test/test_sort_int.f90 @@ -1,9 +1,11 @@ program main + use module_file_manager use module_sort_swap implicit none integer :: want_to_sort(21) = (/8, 9, 10, 11, 12, 13, 14, 15, 16, 169, 170, 171, 172, 173, 174, 175, 1, 3, 5, 156, 189/) + integer :: new_unit = 20 call heapSort(want_to_sort, .false.) - open (1, file='int.out', form='formatted') - write (1, *) want_to_sort - close (1) + call open_formatted_file(unit=new_unit, file="int.out",status='replace' ,optional_action="write") + write (new_unit, *) want_to_sort + close (new_unit) end program main diff --git a/test/unit_test/sort_test/test_sort_int_reverse.f90 b/test/unit_test/sort_test/test_sort_int_reverse.f90 index c17d5ed1..5f7d26b4 100644 --- a/test/unit_test/sort_test/test_sort_int_reverse.f90 +++ b/test/unit_test/sort_test/test_sort_int_reverse.f90 @@ -1,9 +1,11 @@ program main + use module_file_manager use module_sort_swap implicit none integer :: want_to_sort(21) = (/8, 9, 10, 11, 12, 13, 14, 15, 16, 169, 170, 171, 172, 173, 174, 175, 1, 3, 5, 156, 189/) + integer :: new_unit = 20 call heapSort(want_to_sort, .true.) - open (1, file='int_reverse.out', form='formatted') - write (1, *) want_to_sort - close (1) + call open_formatted_file(unit=new_unit, file="int_reverse.out",status='replace' ,optional_action="write") + write (new_unit, *) want_to_sort + close (new_unit) end program main diff --git a/test/unit_test/sort_test/test_sort_real.f90 b/test/unit_test/sort_test/test_sort_real.f90 index 1cc12773..5fadcc56 100644 --- a/test/unit_test/sort_test/test_sort_real.f90 +++ b/test/unit_test/sort_test/test_sort_real.f90 @@ -1,10 +1,12 @@ program main + use module_file_manager use module_sort_swap implicit none real(8) :: want_to_sort_real(6) = (/8.1, -9.2, 10000.58, -897.0, 123456789.0, 0.0000000010/) + integer :: new_unit = 20 call heapSort(want_to_sort_real, .false.) - open (1, file='real.out', form='formatted') + call open_formatted_file(unit=new_unit, file="real.out",status='replace' ,optional_action="write") print *, want_to_sort_real - write (1, *) want_to_sort_real - close (1) + write (new_unit, *) want_to_sort_real + close (new_unit) end program main diff --git a/test/unit_test/sort_test/test_sort_real_reverse.f90 b/test/unit_test/sort_test/test_sort_real_reverse.f90 index aa8c74d7..b43154cc 100644 --- a/test/unit_test/sort_test/test_sort_real_reverse.f90 +++ b/test/unit_test/sort_test/test_sort_real_reverse.f90 @@ -1,10 +1,12 @@ program main + use module_file_manager use module_sort_swap implicit none real(8) :: want_to_sort_real(6) = (/8.1, -9.2, 10000.58, -897.0, 123456789.0, 0.0000000010/) + integer :: new_unit = 20 call heapSort(want_to_sort_real, .true.) - open (1, file='real_reverse.out', form='formatted') + call open_formatted_file(unit=new_unit, file="real_reverse.out",status='replace' ,optional_action="write") print *, want_to_sort_real - write (1, *) want_to_sort_real - close (1) + write (new_unit, *) want_to_sort_real + close (new_unit) end program main diff --git a/test/unit_test/uppercase/CMakeLists.txt b/test/unit_test/uppercase/CMakeLists.txt index 4c0e4bcb..cf630d22 100644 --- a/test/unit_test/uppercase/CMakeLists.txt +++ b/test/unit_test/uppercase/CMakeLists.txt @@ -9,6 +9,7 @@ set(CMAKE_RUNTIME_OUTPUT_DIRECTORY ${CMAKE_CURRENT_SOURCE_DIR}) add_executable(test_uppercase_exe ${CMAKE_SOURCE_DIR}/src/four_caspt2_module.f90 ${CMAKE_SOURCE_DIR}/src/mem.f90 + ${CMAKE_SOURCE_DIR}/src/module_file_manager.f90 ${CMAKE_SOURCE_DIR}/src/module_sort_swap.f90 ${CMAKE_SOURCE_DIR}/src/read_input_module.f90 test_uppercase.f90 diff --git a/test/unit_test/uppercase/test_uppercase.f90 b/test/unit_test/uppercase/test_uppercase.f90 index af3c8954..879bfd63 100644 --- a/test/unit_test/uppercase/test_uppercase.f90 +++ b/test/unit_test/uppercase/test_uppercase.f90 @@ -1,14 +1,16 @@ program main + use module_file_manager use read_input_module implicit none character(100) :: input character(:), allocatable :: string - open (5, file='input', form='formatted') - read (5, '(a)') input + integer :: new_unit = 20 + call open_formatted_file(unit=new_unit, file="input", status='old', optional_action='read') + read (new_unit, '(a)') input string = trim(input) - close (5) + close (new_unit) call uppercase(string) - open (2, file='result.out', form="formatted") - write (2, *) string - close (2) + call open_formatted_file(unit=new_unit, file="result.out", status='old', optional_action='write') + write (new_unit, *) string + close (new_unit) end program main