From d20e7b5a61171b7501b7d8c30f7c7d0601cdffa3 Mon Sep 17 00:00:00 2001 From: Kohei Noda <103017367+kohei-noda-qcrg@users.noreply.github.com> Date: Thu, 28 Jul 2022 18:37:48 +0900 Subject: [PATCH 1/4] Create RASCI (#34) --- src/CMakeLists.txt | 7 +- src/calce0.f90 | 14 +- src/casci_ty.f90 | 69 +- src/casdet_ty.f90 | 64 +- src/casmat.f90 | 33 +- src/casmat_modified.f90 | 267 ---- src/checkdgc.f90 | 24 +- src/create_binmdcint.f90 | 302 ++--- src/cutoff.f90 | 27 +- src/diag.f90 | 150 +-- src/e0after_tra_ty.f90 | 106 +- src/e0test_v2.f90 | 54 +- src/fockcasci_ty.f90 | 16 +- src/fockdiag_ty.f90 | 37 +- src/fockhf1_ty.f90 | 28 +- src/four_caspt2_module.f90 | 2 +- src/get_filename.f90 | 8 +- src/intra.f90 | 528 +++++--- src/prtoutfock.f90 | 26 +- src/r4dcasci_co.f90 | 189 ++- src/r4dcaspt2_tra_co.f90 | 218 ++- src/ras_det_check.f90 | 59 + src/read1mo_co.f90 | 59 +- src/read_input_module.f90 | 45 +- src/readint2_casci_co.f90 | 613 +++++---- src/readint2_ord_co.f90 | 1193 +++++++++-------- src/readorb_enesym_co.f90 | 482 +++---- src/solvall_A_ord_ty.f90 | 262 ++-- src/solvall_B_ord_ty.f90 | 223 ++- src/solvall_C_ord_ty.f90 | 270 ++-- src/solvall_D_ord_ty.f90 | 280 ++-- src/solvall_E_ord_ty.f90 | 175 +-- src/solvall_F_ord_ty.f90 | 184 +-- src/solvall_G_ord_ty.f90 | 179 +-- src/solvall_H_ord_ty.f90 | 58 +- src/timing.f90 | 13 +- src/trac.f90 | 100 +- test/h2/test_h2.py | 104 +- test/h2o/.gitignore | 1 + test/h2o/test_h2o.py | 102 +- test/lower_MPI_h2/test_lower_MPI_h2.py | 104 +- test/module_testing.py | 106 ++ test/unit_test/CMakeLists.txt | 1 + test/unit_test/lowercase/test_lowercase.py | 46 +- test/unit_test/ras3_bitcheck/.gitignore | 3 + test/unit_test/ras3_bitcheck/CMakeLists.txt | 16 + test/unit_test/ras3_bitcheck/active.inp | 30 + test/unit_test/ras3_bitcheck/expected | 227 ++++ .../ras3_bitcheck/test_ras3_bitcheck.f90 | 19 + .../ras3_bitcheck/test_ras3_bitcheck.py | 48 + test/unit_test/ras_input_reader/expected | 2 +- test/unit_test/ras_input_reader/input | 2 +- .../ras_input_reader/test_ras_input_reader.py | 54 +- test/unit_test/sort_test/test_sort.py | 121 +- test/unit_test/uppercase/test_uppercase.py | 45 +- 55 files changed, 3535 insertions(+), 3860 deletions(-) delete mode 100644 src/casmat_modified.f90 create mode 100644 src/ras_det_check.f90 create mode 100644 test/h2o/.gitignore create mode 100644 test/module_testing.py create mode 100644 test/unit_test/ras3_bitcheck/.gitignore create mode 100644 test/unit_test/ras3_bitcheck/CMakeLists.txt create mode 100644 test/unit_test/ras3_bitcheck/active.inp create mode 100644 test/unit_test/ras3_bitcheck/expected create mode 100644 test/unit_test/ras3_bitcheck/test_ras3_bitcheck.f90 create mode 100644 test/unit_test/ras3_bitcheck/test_ras3_bitcheck.py diff --git a/src/CMakeLists.txt b/src/CMakeLists.txt index 9a69e34c..d6689ddb 100644 --- a/src/CMakeLists.txt +++ b/src/CMakeLists.txt @@ -4,7 +4,6 @@ add_executable(r4dcascicoexe four_caspt2_module.f90 module_sort_swap.f90 read_input_module.f90 - readvec.f90 read1mo_co.f90 readorb_enesym_co.f90 one_e_exct.f90 @@ -22,11 +21,9 @@ add_executable(r4dcascicoexe calce0.f90 fockdiag_ty.f90 takekr.f90 - intmo_ty.f90 timing.f90 mem.f90 uramda_s_half.f90 - nrintread.f90 checkdgc.f90 e0test_v2.f90 casci_ty.f90 @@ -35,14 +32,13 @@ add_executable(r4dcascicoexe r4dcasci_co.f90 create_binmdcint.f90 get_filename.f90 - casmat_modified.f90 + ras_det_check.f90 ) add_executable(r4dcaspt2ocoexe four_caspt2_module.f90 module_sort_swap.f90 read_input_module.f90 - readvec.f90 readorb_enesym_co.f90 read1mo_co.f90 readint2_ord_co.f90 @@ -68,5 +64,6 @@ add_executable(r4dcaspt2ocoexe checkdgc.f90 e0test_v2.f90 r4dcaspt2_tra_co.f90 + ras_det_check.f90 get_filename.f90 ) diff --git a/src/calce0.f90 b/src/calce0.f90 index 270d9d31..db8742c8 100644 --- a/src/calce0.f90 +++ b/src/calce0.f90 @@ -21,9 +21,7 @@ SUBROUTINE calce0(e0) e0 = 0.0d+00 dr = 0.0d+00 di = 0.0d+00 - if (rank == 0) then ! Process limits for output - write (*, *) iroot, 'iroot' - end if + if (rank == 0) print *, iroot, 'iroot' Do i = 1, nact ii = i @@ -32,14 +30,14 @@ SUBROUTINE calce0(e0) e0 = e0 + dr*eps(i + ninact) Else Call dim1_density(ii, ii, dr, di) - if (ABS(di) > 1.0d-10 .and. rank == 0) write (*, *) '1dim density is complex! strange', i, di + if (ABS(di) > 1.0d-10 .and. rank == 0) print *, '1dim density is complex! strange', i, di e0 = e0 + dr*eps(i + ninact) End if End do - if (rank == 0) write (*, *) 'e0 = Siguma_w(w:active) eps(w)Dww is ', e0 - -1000 continue - if (rank == 0) write (*, *) 'end' + if (rank == 0) then + print *, 'e0 = Siguma_w(w:active) eps(w)Dww is ', e0 + print *, 'end' + end if end subroutine calce0 diff --git a/src/casci_ty.f90 b/src/casci_ty.f90 index db49d96e..d97d7644 100644 --- a/src/casci_ty.f90 +++ b/src/casci_ty.f90 @@ -21,57 +21,48 @@ SUBROUTINE casci_ty real(8) :: tsectmp0, tsectmp1 ndet = comb(nact, nelec) - if (rank == 0) then ! Process limits for output - write (*, *) 'ndet', ndet - end if + if (rank == 0) print *, 'ndet', ndet Call casdet_ty if (rank == 0) then - write (*, *) "before allocate mat(ndet,ndet)" - write (*, '("Current Memory is ",F10.2,"MB")') tmem/1024/1024 - write (*, *) 'kind of complex16 array named mat is ', kind(mat) + print *, "before allocate mat(ndet,ndet)" + print '("Current Memory is ",F10.2,"MB")', tmem/1024/1024 + print *, 'kind of complex16 array named mat is ', kind(mat) expected_mem = tmem + (ndet**2)*16 - write (*, *) 'expected used memory after allocate mat is ', expected_mem/1024/1024, 'MB' + print *, 'expected used memory after allocate mat is ', expected_mem/1024/1024, 'MB' end if #ifdef HAVE_MPI call MPI_Barrier(MPI_COMM_WORLD, ierr) #endif Allocate (mat(ndet, ndet)); Call memplus(KIND(mat), SIZE(mat), 2) - if (rank == 0) then - write (*, *) "end allocate mat(ndet,ndet)" - write (*, '("Current Memory is ",F10.2,"MB")') tmem/1024/1024 - end if + if (rank == 0) print *, "end allocate mat(ndet,ndet)" Call casmat(mat) - if (rank == 0) then ! Process limits for output - write (*, *) 'before allocate ecas(ndet)' - end if + if (rank == 0) print *, 'before allocate ecas(ndet)' Allocate (ecas(ndet)) - if (rank == 0) then ! Process limits for output - write (*, *) 'allocate ecas(ndet)' - end if + if (rank == 0) print *, 'allocate ecas(ndet)' ecas = 0.0d+00 thresd = 1.0d-15 cutoff = .FALSE. - if (rank == 0) write (*, *) 'Start mat cdiag' + if (rank == 0) print *, 'Start mat cdiag' datetmp1 = date0; datetmp0 = date0 Call timing(date0, tsec0, datetmp0, tsectmp0) tsectmp1 = tsectmp0 - if (rank == 0) write (*, *) 'Noda ndet before cdiag', ndet + if (rank == 0) print *, 'ndet before cdiag', ndet Call cdiag(mat, ndet, ndet, ecas, thresd, cutoff) #ifdef HAVE_MPI call MPI_Barrier(MPI_COMM_WORLD, ierr) #endif - if (rank == 0) write (*, *) 'End mat cdiag' + if (rank == 0) print *, 'End mat cdiag' Call timing(datetmp1, tsectmp1, datetmp0, tsectmp0) datetmp1 = datetmp0 tsectmp1 = tsectmp0 ! Print out CI matrix! if (rank == 0) then ! Only master ranks are allowed to create files used by CASPT2 except for MDCINTNEW. - write (*, *) 'debug1' + print *, 'debug1' cimat = 10 filename = 'CIMAT' open (10, file='CIMAT', status='unknown', form='unformatted') @@ -86,7 +77,7 @@ SUBROUTINE casci_ty ! Print out CI matrix! - write (*, *) 'debug2' + print *, 'debug2' cimat = 10 filename = 'CIMAT1' @@ -99,9 +90,7 @@ SUBROUTINE casci_ty end if ! Print out C1 matrix! - if (rank == 0) then ! Process limits for output - write (*, *) 'debug3' - end if + if (rank == 0) print *, 'debug3' Allocate (cir(ndet, selectroot:selectroot)); Call memplus(KIND(cir), SIZE(cir), 1) Allocate (cii(ndet, selectroot:selectroot)); Call memplus(KIND(cii), SIZE(cii), 1) Allocate (eigen(nroot)); Call memplus(KIND(eigen), SIZE(eigen), 1) @@ -113,27 +102,27 @@ SUBROUTINE casci_ty cir(1:ndet, selectroot) = DBLE(mat(1:ndet, selectroot)) cii(1:ndet, selectroot) = DIMAG(mat(1:ndet, selectroot)) Deallocate (ecas) - if (rank == 0) then ! Process limits for output - write (*, *) 'debug4' + if (rank == 0) then + print *, 'debug4' - write (*, '("CASCI ENERGY FOR ",I2," STATE")') totsym + print '("CASCI ENERGY FOR ",I2," STATE")', totsym Do irec = 1, nroot - write (*, '(I4,F30.15)') irec, eigen(irec) + print '(I4,F30.15)', irec, eigen(irec) End do - - do j = 1, ndet - if (ABS(DIMAG(mat(j, selectroot))) > thres) then - realcvec = .false. - end if - end do - + end if + do j = 1, ndet + if (ABS(DIMAG(mat(j, selectroot))) > thres) then + realcvec = .false. + end if + end do + if (rank == 0) then do irec = 1, nroot - write (*, '("Root = ",I4)') irec + print '("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)') & + print *, (btest(i0, j0), j0=0, nact - 1) + print '(I4,2(3X,E14.7)," Weights ",E14.7)', & & j, mat(j, irec), & & ABS(mat(j, irec))**2 end if @@ -141,7 +130,7 @@ SUBROUTINE casci_ty end do end if Deallocate (mat); Call memminus(KIND(mat), SIZE(mat), 2) -1000 end subroutine casci_ty +end subroutine casci_ty ! ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ diff --git a/src/casdet_ty.f90 b/src/casdet_ty.f90 index 7fda2a12..91a5d11b 100644 --- a/src/casdet_ty.f90 +++ b/src/casdet_ty.f90 @@ -5,15 +5,31 @@ SUBROUTINE casdet_ty ! ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ use four_caspt2_module - + use ras_det_check Implicit NONE integer :: i, isym integer, allocatable :: idet0(:) - - if (rank == 0) then ! Process limits for output - write (*, *) 'Enter casdet_ty' - end if + integer :: upper_allowed_hole, allow_det_num + logical :: is_det_allow + upper_allowed_hole = 1 ! RAS1の許容されるホール数 + + ! e.g. RAS1が4spinorの場合RAS1のビット表現であるras1_bitはどのように表せるか? + ! -> 00001111のようなものが表せていれば良い + ! 00001111は10進数で15(=2^0+2^1+2^+2^3)であるので + ! ras1_bit = 15 + + ! <一般のspinor数nのとき> + ! 4spinorのときの例からras1_bitは等比数列の和となるので + ! 等比数列の和の公式 a(1-r^n)/(1-r) (ここでa:初項,n:項数,r:公比)より + ! 一般のspinor数n(ただしnは自然数)についてras1_bitは + ! ras1_bit = 1*(1-2^n)/(1-2) = 2^n - 1 となる + ! 実際に4spinorのときを確かめると + ! ras1_bit = 2^4 - 1 = 16 - 1 = 15 となり上の4spinorの例と一致する + + ! ras1_bit = 2**2 - 1 ! RAS1のビット表現 + allow_det_num = 0 + if (rank == 0) print *, 'Enter casdet_ty' Allocate (idet0(ndet)) Allocate (idetr(2**nact - 1)); call memplus(kind(idetr), size(idetr), 1) idet0 = 0 @@ -22,12 +38,25 @@ SUBROUTINE casdet_ty ! 67108864* 8 / (1024^2) = 500MB, 26 spinor Do i = 1, 2**nact - 1 if (POPCNT(i) == nelec) then + is_det_allow = .true. + if (is_ras1_configured) then + is_det_allow = ras1_det_check(i, ras1_max_hole) + if (.not. is_det_allow) cycle + end if + + if (is_ras3_configured) then + is_det_allow = ras3_det_check(i, ras3_max_elec) + if (.not. is_det_allow) cycle + end if + + allow_det_num = allow_det_num + 1 if (trim(ptgrp) == 'C1') then ndet = ndet + 1 idet0(ndet) = i idetr(i) = ndet else Call detsym_ty(i, isym) + if (rank == 0) print '(a,L,a,i20,a,b50)', 'is_det_allow', is_det_allow, ",i:", i, "bit(i)", i if (isym == totsym) then ndet = ndet + 1 idet0(ndet) = i @@ -39,14 +68,15 @@ SUBROUTINE casdet_ty Allocate (idet(ndet)) idet(1:ndet) = idet0(1:ndet) - if (rank == 0) then ! Process limits for output - write (*, *) 'totsym = ', totsym - write (*, *) 'ndet = ', ndet + if (rank == 0) then + print *, 'allow = ', allow_det_num + print *, 'totsym = ', totsym + print *, 'ndet = ', ndet end if -! write(*,*)idet(1:ndet) +! print *,idet(1:ndet) Deallocate (idet0) -1000 end subroutine casdet_ty +end subroutine casdet_ty ! ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ @@ -72,23 +102,17 @@ SUBROUTINE detsym_ty(ii, isym) jsym = irpamo(j) if (mod(ielec, 2) == 1) then isym1 = MULTB_DS(jsym, isym) ! isym will be double irrep: odd number of electron - if (rank == 0) then ! Process limits for output - if (isym1 > nsymrp) write (*, *) 'ielec, ii, isym, jsym, isym1', ielec, ii, isym, jsym + 1, isym1 - end if isym = isym1 + if (isym1 > nsymrp .and. rank == 0) print *, 'ielec, ii, isym, jsym, isym1', ielec, ii, isym, jsym + 1, 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 (rank == 0) then ! Process limits for output - if (isym1 > nsymrp) write (*, *) 'ielec, ii, isym, jsym+1, isym1', ielec, ii, isym, jsym + 1, isym1 - end if isym = isym1 + if (isym1 > nsymrp .and. rank == 0) print *, 'ielec, ii, isym, jsym+1, isym1', ielec, ii, isym, jsym + 1, isym1 else isym1 = MULTB_D(jsym - 1, isym) ! isym will be single irrep: even number of electron - if (rank == 0) then ! Process limits for output - if (isym1 > nsymrp) write (*, *) 'ielec, ii, isym, jsym-1, isym1', ielec, ii, isym, jsym - 1, isym1 - end if isym = isym1 + if (isym1 > nsymrp .and. rank == 0) print *, 'ielec, ii, isym, jsym-1, isym1', ielec, ii, isym, jsym - 1, isym1 end if end if @@ -96,4 +120,4 @@ SUBROUTINE detsym_ty(ii, isym) End do If (mod(ielec, 2) == 0) isym = isym + nsymrp ! even number electronic system -1000 end subroutine detsym_ty +end subroutine detsym_ty diff --git a/src/casmat.f90 b/src/casmat.f90 index 23663c3e..4b387dd1 100644 --- a/src/casmat.f90 +++ b/src/casmat.f90 @@ -22,14 +22,10 @@ SUBROUTINE casmat(mat) mat = 0.0d+00 - if (rank == 0) then ! Process limits for output - write (*, *) 'Cas mat enter' - end if + if (rank == 0) print *, 'Cas mat enter' Allocate (oc(nelec)) Allocate (vi(nact - nelec)) - if (rank == 0) then ! Process limits for output - write (*, *) 'allocated oc and vi' - end if + if (rank == 0) print *, 'allocated oc and vi' Do i = rank + 1, ndet, nprocs ! MPI parallelization (Distributed loop: static scheduling, per nprocs) occ = 0 @@ -47,11 +43,6 @@ SUBROUTINE casmat(mat) End if End do -! write(*,*) 'i, idet(i)',i, idet(i) -! write(*,*) occ, oc(1:occ) -! write(*,*) vir, vi(1:vir) -! write(*,*) ' ' - !! IDENTICAL DETERMINANT => DIAGONAL TERM ! diagonal term is same as Hartree-Fock's expression @@ -94,27 +85,21 @@ SUBROUTINE casmat(mat) i2r = inttwr(ir, ir, is, is) i2i = inttwi(ir, ir, is, is) cmplxint = CMPLX(i2r, i2i, 16) -! write(*,*)ir,is,cmplxint mat0 = mat0 + 0.5d+00*cmplxint -! mat(i,i) = mat(i,i) + 0.5d+00*cmplxint ! two electron integral : (ir, is | is, ir) i2r = inttwr(ir, is, is, ir) i2i = inttwi(ir, is, is, ir) cmplxint = CMPLX(i2r, i2i, 16) -! write(*,*)ir,is,cmplxint mat0 = mat0 - 0.5d+00*cmplxint -! mat(i,i) = mat(i,i) - 0.5d+00*cmplxint End do End do mat(i, i) = mat(i, i) + mat0 + DCONJG(mat0) -! write(*,*)'mat(',i,',',i,') = ',mat(i,i) - !! ONE SPINOR DIFFERENCE Do i0 = 1, nelec @@ -129,10 +114,7 @@ SUBROUTINE casmat(mat) j = idetr(newidet1) -! write(*,*)'j=',j - If (j > i) then - ! if (rank == 0) write (*, '(A,I5,A,I5)') 'Noda ijorder i:', i, ' j:', j cmplxint = CMPLX(oner(ir, ia), onei(ir, ia), 16) mat(i, j) = mat(i, j) + cmplxint Do l0 = 1, ninact @@ -190,7 +172,6 @@ SUBROUTINE casmat(mat) inds = oc(j0) ir = indr + ninact is = inds + ninact -! write(*,*)'ir,indr,is,inds',ir,indr,is,inds Do k0 = 1, nact - nelec Do l0 = k0 + 1, nact - nelec @@ -205,7 +186,6 @@ SUBROUTINE casmat(mat) j = idetr(newidet2) If (j > i) then - ! if (rank == 0) write (*, '(A,I5,A,I5)') 'Noda ijorder 2diff i:', i, ' j:', j if (mod(phase1 + phase2, 2) == 0) phase = 1.0d+00 if (mod(phase1 + phase2, 2) == 1) phase = -1.0d+00 @@ -237,11 +217,12 @@ SUBROUTINE casmat(mat) Deallocate (oc) Deallocate (vi) - if (rank == 0) then ! Process limits for output - write (*, *) 'end casmat' - write (*, *) 'Reduce mat(:,:)' + if (rank == 0) then + print *, 'end casmat' + print *, 'Reduce mat(:,:)' end if #ifdef HAVE_MPI call MPI_Allreduce(MPI_IN_PLACE, mat(1, 1), ndet**2, MPI_COMPLEX16, MPI_SUM, MPI_COMM_WORLD, ierr) + if (rank == 0) print *, 'end allreduce mat(:,:)' #endif -1000 end subroutine casmat +end subroutine casmat diff --git a/src/casmat_modified.f90 b/src/casmat_modified.f90 deleted file mode 100644 index dad556fc..00000000 --- a/src/casmat_modified.f90 +++ /dev/null @@ -1,267 +0,0 @@ -! ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ - -SUBROUTINE casmat_modified(not_zero_count) - -! ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ - - use four_caspt2_module - - Implicit NONE -#ifdef HAVE_MPI - include 'mpif.h' -#endif -! complex*16, intent(out) :: mat(ndet, ndet) - - integer :: occ, vir, indr, inds, inda, indb - integer :: ir, is, ia, ib, imo - integer :: i0, j0, k0, l0, i, j, newidet1, newidet2 - integer :: phase, phase1, phase2 - real*8 :: i2r, i2i - complex*16 :: cmplxint, mat0 - - integer, allocatable :: oc(:), vi(:) - complex*16 :: matval - character(50) :: matfilename, chr_rank - integer, parameter :: mat_unit_num = 1000 - integer, intent(out) :: not_zero_count - - if (rank == 0) then ! Process limits for output - write (*, *) 'Cas mat enter' - end if - Allocate (oc(nelec)) - Allocate (vi(nact - nelec)) - if (rank == 0) then ! Process limits for output - write (*, *) 'allocated oc and vi' - end if - write (chr_rank, *) rank - matfilename = "mat"//trim(adjustl(chr_rank)) - open (mat_unit_num, file=matfilename, form='unformatted', status='unknown') - not_zero_count = 0 - Do i = rank + 1, ndet, nprocs ! MPI parallelization (Distributed loop: static scheduling, per nprocs) - - occ = 0 - oc(:) = 0 - vir = 0 - vi(:) = 0 - matval = 0.0d+00 - Do imo = 1, nact - If (BTEST(idet(i), imo - 1)) then - occ = occ + 1 - oc(occ) = imo - Else - vir = vir + 1 - vi(vir) = imo - End if - End do - -!! IDENTICAL DETERMINANT => DIAGONAL TERM -! diagonal term is same as Hartree-Fock's expression - - Do i0 = 1, ninact - ir = i0 - cmplxint = CMPLX(oner(ir, ir), onei(ir, ir), 16) -! mat(i, i) = mat(i, i) + cmplxint - matval = matval + cmplxint - End do - - Do i0 = 1, nelec - indr = oc(i0) - ir = indr + ninact - cmplxint = CMPLX(oner(ir, ir), onei(ir, ir), 16) -! mat(i, i) = mat(i, i) + cmplxint - matval = matval + cmplxint - End do - - mat0 = 0.0d+00 - - Do i0 = 1, ninact + nelec - - if (i0 <= ninact) then - ir = i0 - Else - indr = i0 - ninact - indr = oc(indr) - ir = indr + ninact - End if - Do j0 = i0 + 1, ninact + nelec - - if (j0 <= ninact) then - is = j0 - Else - inds = j0 - ninact - inds = oc(inds) - is = inds + ninact - End if - -! two electron integral : (ir, ir | is, is) - i2r = inttwr(ir, ir, is, is) - i2i = inttwi(ir, ir, is, is) - cmplxint = CMPLX(i2r, i2i, 16) -! write(*,*)ir,is,cmplxint - - mat0 = mat0 + 0.5d+00*cmplxint -! mat(i,i) = mat(i,i) + 0.5d+00*cmplxint - -! two electron integral : (ir, is | is, ir) - i2r = inttwr(ir, is, is, ir) - i2i = inttwi(ir, is, is, ir) - cmplxint = CMPLX(i2r, i2i, 16) -! write(*,*)ir,is,cmplxint - - mat0 = mat0 - 0.5d+00*cmplxint -! mat(i,i) = mat(i,i) - 0.5d+00*cmplxint - - End do - End do - -! mat(i, i) = mat(i, i) + mat0 + DCONJG(mat0) - matval = matval + mat0 + DCONJG(mat0) - if (matval /= 0.0d+00) then - not_zero_count = not_zero_count + 1 - ! if (rank == 0) write (*, '(A,I5,A,I5,A,E20.10)') 'Noda ijorder2 i:', i, ' j:', i, " mat", real(matval) - write (mat_unit_num) i, i, matval - end if -! write(*,*)'mat(',i,',',i,') = ',mat(i,i) - -!! ONE SPINOR DIFFERENCE - - Do i0 = 1, nelec - indr = oc(i0) - ir = indr + ninact - - Do k0 = 1, nact - nelec - inda = vi(k0) - ia = inda + ninact - - Call one_e_exct(idet(i), inda, indr, newidet1, phase1) - - j = idetr(newidet1) - matval = 0.0d+00 -! write(*,*)'j=',j - - If (j > i) then - cmplxint = CMPLX(oner(ir, ia), onei(ir, ia), 16) -! mat(i, j) = mat(i, j) + cmplxint - matval = matval + cmplxint - Do l0 = 1, ninact - is = l0 - -! two electron integral : (ir, ia | is, is) - i2r = inttwr(ir, ia, is, is) - i2i = inttwi(ir, ia, is, is) - cmplxint = CMPLX(i2r, i2i, 16) - -! mat(i, j) = mat(i, j) + cmplxint - matval = matval + cmplxint - -! two electron integral : (ir, is | is, ia) - i2r = inttwr(ir, is, is, ia) - i2i = inttwi(ir, is, is, ia) - cmplxint = CMPLX(i2r, i2i, 16) - -! mat(i, j) = mat(i, j) - cmplxint - matval = matval - cmplxint - - End do !l0 - - Do l0 = 1, nelec - inds = oc(l0) - is = inds + ninact - -! two electron integral : (ir, ia | is, is) - i2r = inttwr(ir, ia, is, is) - i2i = inttwi(ir, ia, is, is) - cmplxint = CMPLX(i2r, i2i, 16) - -! mat(i, j) = mat(i, j) + cmplxint - matval = matval + cmplxint - -! two electron integral : (ir, is | is, ia) - i2r = inttwr(ir, is, is, ia) - i2i = inttwi(ir, is, is, ia) - cmplxint = CMPLX(i2r, i2i, 16) - -! mat(i, j) = mat(i, j) - cmplxint - matval = matval - cmplxint - End do !l0 - - ! if (mod(phase1, 2) == 0) phase = 1.0d+00 - ! if (mod(phase1, 2) == 1) phase = -1.0d+00 - phase = (-1)**(mod(phase1, 2)) - -! mat(i, j) = phase*mat(i, j) - matval = phase*matval - if (matval /= 0.0d+00) then - not_zero_count = not_zero_count + 2 - write (mat_unit_num) i, j, matval - end if - - End if - - End do ! k0 - End do ! i0 -!! TWO ELECTRON DIFFERNT CASE - - Do i0 = 1, nelec - Do j0 = i0 + 1, nelec - indr = oc(i0) - inds = oc(j0) - ir = indr + ninact - is = inds + ninact -! write(*,*)'ir,indr,is,inds',ir,indr,is,inds - - Do k0 = 1, nact - nelec - Do l0 = k0 + 1, nact - nelec - inda = vi(k0) - indb = vi(l0) - ia = inda + ninact - ib = indb + ninact - - Call one_e_exct(idet(i), inda, indr, newidet1, phase1) - Call one_e_exct(newidet1, indb, inds, newidet2, phase2) - - j = idetr(newidet2) - matval = 0.0d+00 - If (j > i) then - ! if (rank == 0) write (*, '(A,I5,A,I5)') 'Noda ijorder 2diff i:', i, ' j:', j - ! if (mod(phase1 + phase2, 2) == 0) phase = 1.0d+00 - ! if (mod(phase1 + phase2, 2) == 1) phase = -1.0d+00 - phase = (-1)**mod(phase1 + phase2, 2) - -! two electron integral : (ir, ia | is, ib) - i2r = inttwr(ir, ia, is, ib) - i2i = inttwi(ir, ia, is, ib) - cmplxint = CMPLX(i2r, i2i, 16) - -! mat(i, j) = cmplxint - matval = cmplxint -! two electron integral : (ir, ib | is, ia) - i2r = inttwr(ir, ib, is, ia) - i2i = inttwi(ir, ib, is, ia) - cmplxint = CMPLX(i2r, i2i, 16) - -! mat(i, j) = mat(i, j) - cmplxint -! mat(i, j) = phase*mat(i, j) - matval = matval - cmplxint - matval = phase*matval - if (matval /= 0.0d+00) then - not_zero_count = not_zero_count + 2 - write (mat_unit_num) i, j, matval - end if - End if - - End do ! l0 - End do ! k0 - End do ! j0 - End do ! i0 - - End do ! i - - Deallocate (oc) - Deallocate (vi) - if (rank == 0) then ! Process limits for output - write (*, *) 'end casmat' - write (*, *) 'Reduce mat(:,:)' - end if - close (mat_unit_num) -1000 end subroutine casmat_modified diff --git a/src/checkdgc.f90 b/src/checkdgc.f90 index 627aaf3d..db6c5ead 100644 --- a/src/checkdgc.f90 +++ b/src/checkdgc.f90 @@ -19,20 +19,16 @@ SUBROUTINE checkdgc(n, old, tra, w) mat = MATMUL(TRANSPOSE(DCONJG(tra)), old) mat = MATMUL(mat, tra) - - Do i = 1, n - If (ABS(mat(i, i) - w(i)) > 1.0d-08) then - if (rank == 0) then - write (*, '(I4,4E15.7)') i, mat(i, i), mat(i, i) - w(i) - end if - End if - Do j = 1, n - If ((i /= j) .and. ABS(mat(i, j)) > 1.d-08) then - if (rank == 0) then - write (*, '(2I4,2E15.7)') i, j, mat(i, j) - end if + if (rank == 0) then + Do i = 1, n + If (ABS(mat(i, i) - w(i)) > 1.0d-08) then + print '(I4,4E15.7)', i, mat(i, i), mat(i, i) - w(i) End if + Do j = 1, n + If ((i /= j) .and. ABS(mat(i, j)) > 1.d-08) then + print '(2I4,2E15.7)', i, j, mat(i, j) + End if + End do End do - End do - + end if end subroutine checkdgc diff --git a/src/create_binmdcint.f90 b/src/create_binmdcint.f90 index 63aba092..81b41eaf 100644 --- a/src/create_binmdcint.f90 +++ b/src/create_binmdcint.f90 @@ -20,7 +20,8 @@ Subroutine create_newmdcint ! 2 Electorn Integrals In Mdcint ! Iwamuro modify real :: cutoff integer :: nnkr, iiit, jjjt, kkkt, lllt - integer :: nkr, nz, file_idx + integer :: nkr, nz, file_idx, iostat + integer, parameter :: mdcint_unit_num = 100, mdcintnew_unit_num = 200 logical :: is_file_exist Call timing(date1, tsec1, date0, tsec0) @@ -40,35 +41,32 @@ Subroutine create_newmdcint ! 2 Electorn Integrals In Mdcint Allocate (rklr(nmo**2)) Allocate (rkli(nmo**2)) - if (rank == 0) then ! Process limits for output - write (*, *) "allocate successed." - end if #ifdef HAVE_MPI ! Broadcast kr and other data that are not included in the MDCINXXX files call MPI_Bcast(datex, sizeof(datex), MPI_CHARACTER, 0, MPI_COMM_WORLD, ierr) - if (rank == 0) then ! Process limits for output - write (*, *) "datex broadcast" - write (*, *) "if ierr == 0, datex broadcast successed. ierr=", ierr + if (rank == 0) then + print *, "datex broadcast" + print *, "if ierr == 0, datex broadcast successed. ierr=", ierr end if call MPI_Bcast(timex, sizeof(timex), MPI_CHARACTER, 0, MPI_COMM_WORLD, ierr) - if (rank == 0) then ! Process limits for output - write (*, *) "timex broadcast" - write (*, *) "if ierr == 0, timex broadcast successed. ierr=", ierr + if (rank == 0) then + print *, "timex broadcast" + print *, "if ierr == 0, timex broadcast successed. ierr=", ierr end if call MPI_Bcast(nkr, 1, MPI_INTEGER8, 0, MPI_COMM_WORLD, ierr) - if (rank == 0) then ! Process limits for output - write (*, *) "nkr broadcast" - write (*, *) "if ierr == 0, nkr broadcast successed. ierr=", ierr + if (rank == 0) then + print *, "nkr broadcast" + print *, "if ierr == 0, nkr broadcast successed. ierr=", ierr end if call MPI_Bcast(kr(-nmo/2), nmo + 1, MPI_INTEGER8, 0, MPI_COMM_WORLD, ierr) - if (rank == 0) then ! Process limits for output - write (*, *) "kr broadcast" - write (*, *) "if ierr == 0, kr broadcast successed. ierr=", ierr + if (rank == 0) then + print *, "kr broadcast" + print *, "if ierr == 0, kr broadcast successed. ierr=", ierr end if call MPI_Bcast(indmor(1), nmo, MPI_INTEGER8, 0, MPI_COMM_WORLD, ierr) - if (rank == 0) then ! Process limits for output - write (*, *) "datex broadcast" - write (*, *) "if ierr == 0, datex broadcast successed. ierr=", ierr + if (rank == 0) then + print *, "datex broadcast" + print *, "if ierr == 0, datex broadcast successed. ierr=", ierr end if #endif nnkr = 0 @@ -82,8 +80,8 @@ Subroutine create_newmdcint ! 2 Electorn Integrals In Mdcint ! First, All process write header information to MDCINTNEWrank call get_mdcint_filename(file_idx) - open (200, file=mdcintNew, form='unformatted', status='replace') - write (200) datex, timex, nkr, (kr(i0), kr(-1*i0), i0=1, nkr) + 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) is_file_exist = .true. do while (is_file_exist) ! Continue reading 2-electron integrals until mdcint_filename doesn't exist. @@ -91,36 +89,50 @@ 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 (100, file=mdcint_filename, form='unformatted', status='unknown') - read (100) - - read (100, ERR=200) ikr, jkr, nz, (indk(inz), indl(inz), rklr(inz), rkli(inz), inz=1, nz) - goto 201 - -200 realonly = .true. - if (rank == 0) then ! Process limits for output - write (*, *) "realonly = ", realonly + open (mdcint_unit_num, file=mdcint_filename, form='unformatted', status='unknown') + read (mdcint_unit_num) + + read (mdcint_unit_num, 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 -201 close (100) + close (mdcint_unit_num) - open (100, file=mdcint_filename, form='unformatted', status='unknown') - read (100) + open (mdcint_unit_num, file=mdcint_filename, form='unformatted', status='unknown') + read (mdcint_unit_num) nnkr = nkr rkli = 0.0d+00 !Iwamuro debug - ! write(*,*) "new_ikr1", datex, timex, nkr, (kr(i0),kr(-1*i0),i0=1,nkr) - ! write(*,*) Filename - -100 if (realonly) then - read (100, end=1000) ikr, jkr, nz, & - (indk(inz), indl(inz), inz=1, nz), & - (rklr(inz), inz=1, nz) - else - read (100, end=1000) ikr, jkr, nz, & - (indk(inz), indl(inz), inz=1, nz), & - (rklr(inz), rkli(inz), inz=1, nz) - end if + ! print *, "new_ikr1", datex, timex, nkr, (kr(i0),kr(-1*i0),i0=1,nkr) + ! print *, Filename + + ! 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, & + (indk(inz), indl(inz), inz=1, nz), & + (rklr(inz), inz=1, nz) + else + read (mdcint_unit_num, 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." + 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 !------------------------------! ! Create new ikr for UTChem ! @@ -131,113 +143,96 @@ Subroutine create_newmdcint ! 2 Electorn Integrals In Mdcint ! kkr = kkkr ! lkr = llkr - - - if (ikr == 0) then - if (rank == 0) then ! Process limits for output - write (*, *) ikr, jkr, nz, mdcint_debug + if (ikr == 0) then + if (rank == 0) print *, ikr, jkr, nz, mdcint_debug + exit mdcint_file_read ! End of file end if - go to 1000 - end if - n = 1 -10 select case (n) - case (1) - ikr = ikr - jkr = jkr - indk(:) = indk(:) - indl(:) = indl(:) - rklr(:) = rklr(:) - rkli(:) = rkli(:) - case (2) - ikr = -ikr - jkr = -jkr - indk(:) = -indk(:) - indl(:) = -indl(:) - rklr(:) = -rklr(:)*sign(1, ikr*jkr*indk(:)*indl(:)) - rkli(:) = rkli(:)*sign(1, ikr*jkr*indk(:)*indl(:)) - end select - ! !$OMP parallel do private(iii,jjj,kkk,lll,iikr,jjkr,kkkr,llkr,iiit,jjjt,kkkt,lllt,ii,jj,kk,ll) - Do inz = 1, nz - - - iii = indmor(kr(ikr)) - jjj = indmor(kr(jkr)) - kkk = indmor(kr(indk(inz))) - lll = indmor(kr(indl(inz))) - - 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 - ! end if -! Debug output end (if write(*,*)) + do n = 1, 2 + select case (n) + case (1) + ikr = ikr + jkr = jkr + indk(:) = indk(:) + indl(:) = indl(:) + rklr(:) = rklr(:) + rkli(:) = rkli(:) + case (2) + ikr = -ikr + jkr = -jkr + indk(:) = -indk(:) + indl(:) = -indl(:) + rklr(:) = -rklr(:)*sign(1, ikr*jkr*indk(:)*indl(:)) + rkli(:) = rkli(:)*sign(1, ikr*jkr*indk(:)*indl(:)) + end select + ! !$OMP parallel do private(iii,jjj,kkk,lll,iikr,jjkr,kkkr,llkr,iiit,jjjt,kkkt,lllt,ii,jj,kk,ll) + Do inz = 1, nz + + iii = indmor(kr(ikr)) + jjj = indmor(kr(jkr)) + kkk = indmor(kr(indk(inz))) + lll = indmor(kr(indl(inz))) + + 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 !------------------------------------------------------------ - 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. (ii < kk .or. (ii == kk .and. jj <= ll))) .or. & - (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)) - end if - end if - - Else if (iikr > 0 .and. jjkr < 0 .and. kkkr > 0 .and. llkr < 0) then !TYPE2 - 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)) - end if - end if - - Else if (iikr > 0 .and. jjkr < 0 .and. kkkr < 0 .and. llkr > 0) then !TYPE3 - 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)) - end if - end if - - 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 (200) iiit, jjjt, nnz, kkkt, lllt, rklr(inz), -(rkli(inz)) - end if - end if - End if - End do - - If (n == 1) then - n = 2 - go to 10 - else - go to 100 - end if - + 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. (ii < kk .or. (ii == kk .and. jj <= ll))) .or. & + (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)) + end if + end if + + Else if (iikr > 0 .and. jjkr < 0 .and. kkkr > 0 .and. llkr < 0) then !TYPE2 + 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)) + end if + end if + + Else if (iikr > 0 .and. jjkr < 0 .and. kkkr < 0 .and. llkr > 0) then !TYPE3 + 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)) + end if + end if + + 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 (200) iiit, jjjt, nnz, kkkt, lllt, rklr(inz), -(rkli(inz)) + end if + end if + End if + End do + end do + end do mdcint_file_read !--------------------------------- UTChem integral translation------------------------------------ !TYPE1 If( ((p10<=p20.and.p30<=p40.and.(p10= thres) then + if (w(i0) >= thres) then j0 = j0 + 1 uc(:, j0) = sc(:, 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(*,*) uc(:,i0) -!!! end do - -1000 continue end subroutine ccutoff diff --git a/src/diag.f90 b/src/diag.f90 index abadc5f5..3c31689f 100644 --- a/src/diag.f90 +++ b/src/diag.f90 @@ -54,16 +54,14 @@ SUBROUTINE rdiag(sr, dimn, dimm, w, thresd, cutoff) deallocate (work) - if (info /= 0 .and. rank == 0) then - write (*, *) 'error in diagonalization, info = ', info - goto 1000 + if (info /= 0) then + if (rank == 0) print *, 'error in diagonalization, info = ', info + return end if if (cutoff) then - if (rank == 0) then ! Process limits for output - write (*, *) 'cut off threshold is ', thresd - end if + if (rank == 0) print *, 'cut off threshold is ', thresd j0 = 0 do i0 = 1, dimn if (w(i0) >= thresd) then @@ -110,9 +108,7 @@ SUBROUTINE cdiag(c, dimn, dimm, w, thresd, cutoff) real*8, allocatable :: rwork(:) integer :: j0, i0 - if (rank == 0) then ! Process limits for output - write (*, *) 'Enter cdiagonal part' - end if + if (rank == 0) print *, 'Enter cdiagonal part' w(:) = 0.0d+00 jobz = 'V' ! calculate eigenvectors @@ -206,14 +202,10 @@ SUBROUTINE cdiag(c, dimn, dimm, w, thresd, cutoff) deallocate (work) deallocate (rwork) - if (rank == 0) then ! Process limits for output - write (*, *) 'Finish zheev info = ', info - end if + if (rank == 0) print *, 'Finish zheev info = ', info if (info /= 0) then - if (rank == 0) then ! Process limits for output - write (*, *) 'error in diagonalization, info = ', info - end if - goto 1000 + if (rank == 0) print *, 'error in diagonalization, info = ', info + return end if ! Do i0 = 1, dimn @@ -222,13 +214,11 @@ SUBROUTINE cdiag(c, dimn, dimm, w, thresd, cutoff) if (cutoff) then - if (rank == 0) then ! Process limits for output - write (*, *) 'cut off threshold is ', thresd - end if + if (rank == 0) print *, 'cut off threshold is ', thresd j0 = 0 do i0 = 1, dimn - if (ABS(w(i0)) >= thresd) then + if (w(i0) >= thresd) then j0 = j0 + 1 end if end do @@ -239,10 +229,7 @@ SUBROUTINE cdiag(c, dimn, dimm, w, thresd, cutoff) dimm = dimn end if - if (rank == 0) then ! Process limits for output - write (*, *) "end cdiag" - end if -1000 continue + if (rank == 0) print *, "end cdiag" end subroutine cdiag ! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= @@ -273,9 +260,7 @@ SUBROUTINE rdiag0(n, n0, n1, fa, w) ! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= ! DAIAGONALIZATION OF A COMPLEX HERMITIAN MATRIX - if (rank == 0) then ! Process limits for output - write (*, *) 'rdiag0 start' - end if + if (rank == 0) print *, 'rdiag0 start' w = 0.0d+00 cutoff = .FALSE. @@ -288,9 +273,7 @@ SUBROUTINE rdiag0(n, n0, n1, fa, w) ncount = 0 - if (rank == 0) then ! Process limits for output - write (*, *) 'nsymrp', nsymrp - end if + if (rank == 0) print *, 'nsymrp', nsymrp Do sym = 1, nsymrp Do i = n0, n1 @@ -304,9 +287,7 @@ SUBROUTINE rdiag0(n, n0, n1, fa, w) End do - if (rank == 0) then ! Process limits for output - write (*, *) 'sym,ncount(sym)', (ncount(sym), sym=1, nsymrp) - end if + if (rank == 0) print *, 'sym,ncount(sym)', (ncount(sym), sym=1, nsymrp) Do sym = 1, nsymrp Allocate (fasym(ncount(sym), ncount(sym))) @@ -344,31 +325,24 @@ SUBROUTINE rdiag0(n, n0, n1, fa, w) mat = MATMUL(mat, f) mat = MATMUL(mat, fa) - if (rank == 0) then ! Process limits for output - write (*, *) 'OFF DIAGONAL TERM OF U*FU' - end if + if (rank == 0) print *, 'OFF DIAGONAL TERM OF U*FU' do i = 1, n do j = 1, n if ((i /= j) .and. (ABS(mat(i, j)) > 1.0d-10)) then - if (rank == 0) then ! Process limits for output - write (*, '(2E13.5,2I3)') mat(i, j), i, j - end if + if (rank == 0) print '(2E13.5,2I3)', mat(i, j), i, j end if end do end do - if (rank == 0) then ! Process limits for output - write (*, *) 'DIAGONAL TERM OF U*FU, W AND THEIR DIFFERENCE' + if (rank == 0) then + print *, 'DIAGONAL TERM OF U*FU, W AND THEIR DIFFERENCE' do i = 1, n - write (*, '(4E13.5)') mat(i, i), w(i), ABS(mat(i, i) - w(i)) + print '(4E13.5)', mat(i, i), w(i), ABS(mat(i, i) - w(i)) end do - write (*, '(/)') end if deallocate (mat) - if (rank == 0) then ! Process limits for output - write (*, *) 'rdiag0 end' - end if + if (rank == 0) print *, 'rdiag0 end' end subroutine rdiag0 ! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= @@ -399,9 +373,9 @@ SUBROUTINE cdiag0(n, n0, n1, fac, wc) ! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= ! DAIAGONALIZATION OF A COMPLEX HERMITIAN MATRIX - if (rank == 0) then ! Process limits for output - write (*, *) 'cdiag0 start' - write (*, *) 'nsymrpa', nsymrpa + if (rank == 0) then + print *, 'cdiag0 start' + print *, 'nsymrpa', nsymrpa end if ! nsymrp = nsymrpa @@ -415,9 +389,7 @@ SUBROUTINE cdiag0(n, n0, n1, fac, wc) End do End do - if (rank == 0) then ! Process limits for output - write (*, *) 'fi', fi - end if + if (rank == 0) print *, 'fi', fi fac(n0:n1, n0:n1) = 0.0d+00 @@ -440,11 +412,11 @@ SUBROUTINE cdiag0(n, n0, n1, fac, wc) ind(ncount(sym), sym) = i End if End do -! write(*,*)(ind(j,sym),j=1,ncount(sym)) +! print *,(ind(j,sym),j=1,ncount(sym)) End do -! write(*,*)'sym,ncount(sym)',(ncount(sym),sym=1,nsymrpa) +! print *,'sym,ncount(sym)',(ncount(sym),sym=1,nsymrpa) Do sym = 1, nsymrpa @@ -474,23 +446,21 @@ SUBROUTINE cdiag0(n, n0, n1, fac, wc) facsym = DCONJG(facsym) facsymo = MATMUL(facsymo, facsym) - Do i = 1, dimn - Do j = 1, dimn - If (i /= j .and. ABS(facsymo(i, j)) > 1.0d-10) then - if (rank == 0) then ! Process limits for output - write (*, '("sym=",3I4,2E20.10)') sym, i, j, facsymo(i, j) - end if + ! Check facsymo + if (rank == 0) then + Do i = 1, dimn + Do j = 1, dimn + If (i /= j .and. ABS(facsymo(i, j)) > 1.0d-10) then + print '("sym=",3I4,2E20.10)', sym, i, j, facsymo(i, j) + End if + End do + End do + Do i = 1, dimn + If (ABS(facsymo(i, i) - wcsym(i)) > 1.0d-10) then + print '("sym=",2I4,3E20.10)', sym, i, facsymo(i, i), wcsym(i) End if End do - End do - - Do i = 1, dimn - If (ABS(facsymo(i, i) - wcsym(i)) > 1.0d-10) then - if (rank == 0) then ! Process limits for output - write (*, '("sym=",2I4,3E20.10)') sym, i, facsymo(i, i), wcsym(i) - end if - End if - End do + end if Deallocate (facsymo) @@ -520,35 +490,25 @@ SUBROUTINE cdiag0(n, n0, n1, fac, wc) fac = DCONJG(fac) matc = MATMUL(matc, fac) - if (rank == 0) then ! Process limits for output - write (*, *) 'OFF DIAGONAL TERM OF U*FU' - end if - do i = n0, n1 - do j = n0, n1 - if ((i /= j) .and. (ABS(matc(i, j)) > 1.0d-10)) then - if (rank == 0) then ! Process limits for output - write (*, '(2E13.5,2I3)') matc(i, j), i, j + ! Check U*FU + if (rank == 0) then + print *, 'OFF DIAGONAL TERM OF U*FU' + do i = n0, n1 + do j = n0, n1 + if ((i /= j) .and. (ABS(matc(i, j)) > 1.0d-10)) then + print '(2E13.5,2I3)', matc(i, j), i, j end if - end if + end do + end do + print *, 'DIAGONAL TERM OF U*FU, W AND THEIR DIFFERENCE' + do i = n0, n1 + if (ABS(matc(i, i) - wc(i)) > 1.0d-10) then + print '(4E13.5)', matc(i, i), wc(i), ABS(matc(i, i) - wc(i)) + End if end do - end do - - if (rank == 0) then ! Process limits for output - write (*, *) 'DIAGONAL TERM OF U*FU, W AND THEIR DIFFERENCE' - end if - do i = n0, n1 - if (ABS(matc(i, i) - wc(i)) > 1.0d-10) then - if (rank == 0) then ! Process limits for output - write (*, '(4E13.5)') matc(i, i), wc(i), ABS(matc(i, i) - wc(i)) - end if - End if - end do - if (rank == 0) then ! Process limits for output - write (*, '(/)') end if + deallocate (matc) - if (rank == 0) then ! Process limits for output - write (*, *) 'cdiag0 end' - end if + if (rank == 0) print *, 'cdiag0 end' end subroutine cdiag0 diff --git a/src/e0after_tra_ty.f90 b/src/e0after_tra_ty.f90 index ec4e964a..cc8aca0e 100644 --- a/src/e0after_tra_ty.f90 +++ b/src/e0after_tra_ty.f90 @@ -20,7 +20,7 @@ SUBROUTINE e0aftertra_ty ! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= ! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= - write (*, *) 'EIGEN(1)', eigen(1) + print *, 'EIGEN(1)', eigen(1) Allocate (energy(nroot, 4)) energy(1:nroot, 1:4) = 0.0d+00 @@ -30,10 +30,10 @@ SUBROUTINE e0aftertra_ty ! thres = 0.0d+00 if (rank == 0) then open (5, file='e0after', status='unknown', form='unformatted') - end if ! AT PRESENT, CODE OF COMPLEX TYPE EXISTS ! - write (*, *) 'iroot = ', iroot + print *, 'iroot = ', iroot + end if ! Do iroot = 1, nroot @@ -60,7 +60,7 @@ SUBROUTINE e0aftertra_ty end do -! write(*,*)'energyHF(1)',energyHF(1) +! print *,'energyHF(1)',energyHF(1) !CCCCCCCCCCCCCCCCCCCCCCCCCCCCC! ! energy HF2 ! @@ -89,7 +89,7 @@ SUBROUTINE e0aftertra_ty energyHF(2) = energyHF(2) + CONJG(energyHF(2)) -! write(*,*)'energyHF(2)',energyHF(2) +! print *,'energyHF(2)',energyHF(2) !CCCCCCCCCCCCCCCCCCCCCCCCCCCCC! ! energy 1 ! @@ -209,7 +209,7 @@ SUBROUTINE e0aftertra_ty 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 +! debug = .TRUE. ; print *, i,j,k,l ! else ! debug = .FALSE. ! endif @@ -239,7 +239,8 @@ SUBROUTINE e0aftertra_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. + ! 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) energy(iroot, 4) = energy(iroot, 4) & + (0.5d+00)*dens*cmplxint @@ -283,26 +284,25 @@ SUBROUTINE e0aftertra_ty ! if(ABS(eigen(iroot)-ecore & ! -(energy(iroot,1)+energy(iroot,2)+energy(iroot,3)+energy(iroot,4))) & ! > 1.0d-5 ) then + if (rank == 0) then + print *, 'energy 1 =', energy(iroot, 1) + print *, 'energy 2 =', energy(iroot, 2) + print *, 'energy 3 =', energy(iroot, 3) + print *, 'energy 4 =', energy(iroot, 4) - 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) + print *, iroot, 't-energy(1-4)', & + energy(iroot, 1) + energy(iroot, 2) + energy(iroot, 3) + energy(iroot, 4) - write (*, *) 'C the error ', & - eigen(iroot) - ecore & - - (energy(iroot, 1) + energy(iroot, 2) + energy(iroot, 3) + energy(iroot, 4)) + print *, iroot, 't-energy', & + eigen(iroot) - ecore + print *, iroot, 'eigen e0', & + eigen(iroot) + print *, 'C the error ', & + eigen(iroot) - ecore & + - (energy(iroot, 1) + energy(iroot, 2) + energy(iroot, 3) + energy(iroot, 4)) ! else -! write(*,*)'C the error ', & +! print *,'C the error ', & ! eigen(iroot)-ecore & ! -(energy(iroot,1)+energy(iroot,2)+energy(iroot,3)+energy(iroot,4)) ! end if @@ -313,7 +313,8 @@ SUBROUTINE e0aftertra_ty !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - write (*, *) 'energy HF =', energyHF(1) + energyHF(2) + ecore + print *, 'energy HF =', energyHF(1) + energyHF(2) + ecore + end if !!### end do ! about type if (rank == 0) then ! Only master ranks are allowed to create files used by CASPT2 except for MDCINTNEW. @@ -321,7 +322,7 @@ SUBROUTINE e0aftertra_ty end if 1000 continue deallocate (energy) - write (*, *) 'e0aftertra end' + print *, 'e0aftertra end' End subroutine e0aftertra_ty ! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= @@ -356,11 +357,8 @@ SUBROUTINE e0aftertrac_ty ! 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') - end if ! AT PRESENT, CODE OF COMPLEX TYPE EXISTS ! - - if (rank == 0) then ! Process limits for output - write (*, *) 'iroot = ', iroot + print *, 'iroot = ', iroot end if ! Do iroot = 1, nroot @@ -389,9 +387,7 @@ SUBROUTINE e0aftertrac_ty #ifdef HAVE_MPI call MPI_Allreduce(MPI_IN_PLACE, energyHF(1), 1, MPI_COMPLEX16, MPI_SUM, MPI_COMM_WORLD, ierr) #endif - if (rank == 0) then ! Process limits for output - write (*, *) 'energyHF(1)', energyHF(1) - end if + if (rank == 0) print *, 'energyHF(1)', energyHF(1) ! do i = 1, ninact ! ! cmplxint = 0.0d+00 @@ -401,7 +397,7 @@ SUBROUTINE e0aftertrac_ty ! ! end do ! -! write(*,*)'energyHF(1)',energyHF(1) +! print *,'energyHF(1)',energyHF(1) ! ! do i = ninact+1, ninact+nelec ! @@ -412,7 +408,7 @@ SUBROUTINE e0aftertrac_ty ! ! end do ! -! write(*,*)'energyHF(1)',energyHF(1) +! print *,'energyHF(1)',energyHF(1) !CCCCCCCCCCCCCCCCCCCCCCCCCCCCC! ! energy HF2 ! @@ -444,14 +440,10 @@ SUBROUTINE e0aftertrac_ty #ifdef HAVE_MPI call MPI_Allreduce(MPI_IN_PLACE, energyHF(2), 1, MPI_COMPLEX16, MPI_SUM, MPI_COMM_WORLD, ierr) #endif - if (rank == 0) then ! Process limits for output - write (*, *) 'energyHF(2)', energyHF(2) - end if + if (rank == 0) print *, 'energyHF(2)', energyHF(2) !Iwamuro modify - if (rank == 0) then ! Process limits for output - write (*, *) 'Iwamuro modify' - end if + if (rank == 0) print *, 'Iwamuro modify' !CCCCCCCCCCCCCCCCCCCCCCCCCCCCC! ! energy 1 ! @@ -575,7 +567,7 @@ SUBROUTINE e0aftertrac_ty 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 +! debug = .TRUE. ; print *, i,j,k,l ! else ! debug = .FALSE. ! endif @@ -656,29 +648,29 @@ SUBROUTINE e0aftertrac_ty call MPI_Allreduce(MPI_IN_PLACE, energy(iroot, 4), 1, MPI_COMPLEX16, MPI_SUM, MPI_COMM_WORLD, ierr) #endif - if (rank == 0) then ! Process limits for output - write (*, *) 'energy 1 =', energy(iroot, 1) - write (*, *) 'energy 2 =', energy(iroot, 2) - write (*, *) 'energy 3 =', energy(iroot, 3) - write (*, *) 'energy 4 =', energy(iroot, 4) + if (rank == 0) then + print *, 'energy 1 =', energy(iroot, 1) + print *, 'energy 2 =', energy(iroot, 2) + print *, 'energy 3 =', energy(iroot, 3) + print *, 'energy 4 =', energy(iroot, 4) - write (*, *) iroot, 't-energy(1-4)', & + print *, iroot, 't-energy(1-4)', & energy(iroot, 1) + energy(iroot, 2) + energy(iroot, 3) + energy(iroot, 4) - write (*, *) iroot, 't-energy', & + print *, iroot, 't-energy', & eigen(iroot) - ecore - write (*, *) iroot, 'eigen e0', & + print *, iroot, 'eigen e0', & eigen(iroot) - write (*, *) 'C the error ', & + print *, 'C the error ', & eigen(iroot) - ecore & - (energy(iroot, 1) + energy(iroot, 2) + energy(iroot, 3) + energy(iroot, 4)) ! Iwamuro modify - write (*, *) 'Iwamuro modify' + print *, 'Iwamuro modify' ! else -! write(*,*)'C the error ', & +! print *,'C the error ', & ! eigen(iroot)-ecore & ! -(energy(iroot,1)+energy(iroot,2)+energy(iroot,3)+energy(iroot,4)) ! end if @@ -689,8 +681,8 @@ SUBROUTINE e0aftertrac_ty !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - write (*, *) 'CAUTION! HF energy may not be obtained correctly ' - write (*, *) 'energy HF =', energyHF(1) + energyHF(2) + ecore + print *, 'CAUTION! HF energy may not be obtained correctly ' + print *, 'energy HF =', energyHF(1) + energyHF(2) + ecore end if !!### end do ! about type if (rank == 0) then ! Only master ranks are allowed to create files used by CASPT2 except for MDCINTNEW. @@ -698,9 +690,7 @@ SUBROUTINE e0aftertrac_ty end if 1000 continue deallocate (energy) -! write(*,*)'e0aftertrac end' +! print *,'e0aftertrac end' ! Iwamuro modify - if (rank == 0) then ! Process limits for output - write (*, *) 'e0aftertrac_ty end' - end if + if (rank == 0) print *, 'e0aftertrac_ty end' End subroutine e0aftertrac_ty diff --git a/src/e0test_v2.f90 b/src/e0test_v2.f90 index 6b82cd6f..595363bc 100644 --- a/src/e0test_v2.f90 +++ b/src/e0test_v2.f90 @@ -22,9 +22,7 @@ SUBROUTINE e0test_v2 ! test to calculate =Ei i is solution of the CASCI ! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= ! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= - if (rank == 0) then ! Process limits for output - write (*, *) "enter e0test" - end if + if (rank == 0) print *, "enter e0test" Allocate (energy(nroot, 4)); Call memplus(KIND(energy), SIZE(energy), 1) energy(:, :) = 0.0d+00 debug = .TRUE. @@ -52,9 +50,7 @@ SUBROUTINE e0test_v2 ! test to calculate =Ei i is solution of the CASCI end if end do - if (rank == 0) then ! Process limits for output - write (*, *) 'energy 1 =', energy(iroot, 1) - end if + if (rank == 0) print *, 'energy 1 =', energy(iroot, 1) !RRRRRRRRRRRRRRRRRRRRRRRRRRRRR! ! energy 2 ! @@ -79,9 +75,7 @@ SUBROUTINE e0test_v2 ! test to calculate =Ei i is solution of the CASCI end do end do - if (rank == 0) then ! Process limits for output - write (*, *) 'energy 2 =', energy(iroot, 2) - end if + if (rank == 0) print *, 'energy 2 =', energy(iroot, 2) !RRRRRRRRRRRRRRRRRRRRRRRRRRRRR! ! energy 3 ! @@ -127,9 +121,7 @@ SUBROUTINE e0test_v2 ! test to calculate =Ei i is solution of the CASCI end do end do - if (rank == 0) then ! Process limits for output - write (*, *) 'energy 3 =', energy(iroot, 3) - end if + if (rank == 0) print *, 'energy 3 =', energy(iroot, 3) !RRRRRRRRRRRRRRRRRRRRRRRRRRRRR! ! energy 4 ! @@ -185,16 +177,16 @@ SUBROUTINE e0test_v2 ! test to calculate =Ei i is solution of the CASCI end do ! jj end do ! ii - if (rank == 0) then ! Process limits for output - write (*, *) 'energy 4 =', energy(iroot, 4) + if (rank == 0) then + print *, 'energy 4 =', energy(iroot, 4) - write (*, *) iroot, 't-energy(1-4)', & + print *, iroot, 't-energy(1-4)', & energy(iroot, 1) + energy(iroot, 2) + energy(iroot, 3) + energy(iroot, 4) - write (*, *) iroot, 't-energy ', & + print *, iroot, 't-energy ', & eigen(iroot) - ecore - write (*, *) 'R the error ', eigen(iroot) - ecore & + print *, 'R the error ', eigen(iroot) - ecore & - (energy(iroot, 1) + energy(iroot, 2) + energy(iroot, 3) + energy(iroot, 4)) end if else @@ -258,7 +250,6 @@ SUBROUTINE e0test_v2 ! test to calculate =Ei i is solution of the CASCI energyHF(2) = energyHF(2) + DCONJG(energyHF(2)) - !CCCCCCCCCCCCCCCCCCCCCCCCCCCCC! ! energy 1 ! !"""""""""""""""""""""""""""""! @@ -445,7 +436,7 @@ SUBROUTINE e0test_v2 ! test to calculate =Ei i is solution of the CASCI end if -100 end do ! ll + end do ! ll end do ! kk end do ! jj end do ! ii @@ -459,30 +450,25 @@ SUBROUTINE e0test_v2 ! test to calculate =Ei i is solution of the CASCI call MPI_Allreduce(MPI_IN_PLACE, energyHF(2), 1, MPI_COMPLEX16, MPI_SUM, MPI_COMM_WORLD, ierr) #endif - if (rank == 0) then ! Process limits for output - write (*, *) 'energy 1 =', energy(iroot, 1) - write (*, *) 'energy 2 =', energy(iroot, 2) - write (*, *) 'energy 3 =', energy(iroot, 3) - write (*, *) 'energy 4 =', energy(iroot, 4) + if (rank == 0) then + print *, 'energy 1 =', energy(iroot, 1) + print *, 'energy 2 =', energy(iroot, 2) + print *, 'energy 3 =', energy(iroot, 3) + print *, 'energy 4 =', energy(iroot, 4) - write (*, *) iroot, 't-energy(1-4)', & + print *, iroot, 't-energy(1-4)', & energy(iroot, 1) + energy(iroot, 2) + energy(iroot, 3) + energy(iroot, 4) - write (*, *) iroot, 't-energy', & + print *, iroot, 't-energy', & eigen(iroot) - ecore - write (*, *) 'C the error ', & + print *, 'C the error ', & eigen(iroot) - ecore & - (energy(iroot, 1) + energy(iroot, 2) + energy(iroot, 3) + energy(iroot, 4)) end if - if (rank == 0) then ! Process limits for output - write (*, *) 'energy HF =', energyHF(1) + energyHF(2) + ecore - end if + if (rank == 0) print *, 'energy HF =', energyHF(1) + energyHF(2) + ecore end if -1000 continue deallocate (energy); Call memminus(KIND(energy), SIZE(energy), 1) - if (rank == 0) then ! Process limits for output - write (*, *) 'e0test end' - end if + if (rank == 0) print *, 'e0test end' End subroutine e0test_v2 diff --git a/src/fockcasci_ty.f90 b/src/fockcasci_ty.f90 index 16e12342..5411ed96 100644 --- a/src/fockcasci_ty.f90 +++ b/src/fockcasci_ty.f90 @@ -22,9 +22,7 @@ SUBROUTINE fockcasci_ty ! TO MAKE FOCK MATRIX for CASCI state !! NOW MAKE FOCK MATRIX FOR CASCI STATE !! fij = hij + SIGUMA_kl[<0|Ekl|0>{(ij|kl)-(il|kj)} - if (rank == 0) then ! Process limits for output - write (*, *) 'enter building fock matrix' - end if + if (rank == 0) print *, 'enter building fock matrix' datetmp0 = initdate tsectmp0 = inittime call timing(datetmp0, tsectmp0, datetmp1, tsectmp1) @@ -33,9 +31,7 @@ SUBROUTINE fockcasci_ty ! TO MAKE FOCK MATRIX for CASCI state f = 0.0d+00 - if (rank == 0) then ! Process limits for output - write (*, *) 'enter building fock matrix' - end if + if (rank == 0) print *, 'enter building fock matrix' !$OMP parallel private(i,j,k,l,dr,di,dens) !$OMP do schedule(dynamic,2) do i = rank + 1, ninact + nact, nprocs ! MPI parallelization (Distributed loop: static scheduling, per nprocs) @@ -97,16 +93,12 @@ SUBROUTINE fockcasci_ty ! TO MAKE FOCK MATRIX for CASCI state end do ! i !$OMP end do !$OMP end parallel - if (rank == 0) then ! Process limits for output - write (*, *) 'fockcasci before f allreduce' - end if + if (rank == 0) print *, 'fockcasci before f allreduce' call timing(datetmp0, tsectmp0, datetmp1, tsectmp1) datetmp0 = datetmp1 tsectmp0 = tsectmp1 #ifdef HAVE_MPI call MPI_Allreduce(MPI_IN_PLACE, f(1, 1), nmo**2, MPI_COMPLEX16, MPI_SUM, MPI_COMM_WORLD, ierr) #endif - if (rank == 0) then ! Process limits for output - write (*, *) 'fockcasci end' - end if + if (rank == 0) print *, 'fockcasci end' end subroutine fockcasci_ty diff --git a/src/fockdiag_ty.f90 b/src/fockdiag_ty.f90 index dfba7fa1..378faa00 100644 --- a/src/fockdiag_ty.f90 +++ b/src/fockdiag_ty.f90 @@ -18,9 +18,7 @@ SUBROUTINE fockdiag_ty ! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= ! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= - if (rank == 0) then ! Process limits for output - write (*, *) 'fockdiag start' - end if + if (rank == 0) print *, 'fockdiag start' REALF = .TRUE. Do i = 1, ninact + nact + nsec @@ -32,9 +30,7 @@ SUBROUTINE fockdiag_ty End do REALF = .FALSE. - if (rank == 0) then ! Process limits for output - write (*, *) 'REALF', REALF - end if + if (rank == 0) print *, 'REALF', REALF If (REALF) then ! real*8 Allocate (fa(nmo, nmo)); Call memplus(KIND(fa), SIZE(fa), 1) @@ -64,10 +60,10 @@ SUBROUTINE fockdiag_ty n1 = nspace(2, i0) n = nspace(3, i0) - if (rank == 0) then ! Process limits for output - 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 (rank == 0) then + if (i0 == 1) print *, 'FOR INACTIVE-INACTIVE ROTATION !' + if (i0 == 2) print *, 'FOR ACTIVE-ACTIVE ROTATION !' + if (i0 == 3) print *, 'FOR SECONDARY-SECONDARY ROTATION !' end if if (REALF) then @@ -75,18 +71,18 @@ SUBROUTINE fockdiag_ty write (5) n0, n1, n write (5) fa(n0:n1, n0:n1) - if (rank == 0) then ! Process limits for output - write (*, *) n0, n1, n + if (rank == 0) then + print *, n0, n1, n - write (*, *) 'fa ' + print *, 'fa ' do i = n0, n1 - write (*, '(30E13.5)') (fa(i, j), j=n0, n1) + print '(30E13.5)', (fa(i, j), j=n0, n1) end do - write (*, *) 'f ' + print *, 'f ' do i = n0, n1 - write (*, '(30E13.5)') (DBLE(f(i, j)), j=n0, n1) + print '(30E13.5)', (DBLE(f(i, j)), j=n0, n1) end do end if else @@ -125,12 +121,5 @@ SUBROUTINE fockdiag_ty close (5) end if - goto 1000 - if (rank == 0) then ! Process limits for output - write (*, *) 'reading err in orbcoeff' - end if -1000 continue - if (rank == 0) then ! Process limits for output - write (*, *) 'fockdiag end' - end if + if (rank == 0) print *, 'fockdiag end' end subroutine fockdiag_ty diff --git a/src/fockhf1_ty.f90 b/src/fockhf1_ty.f90 index bda97ea4..de5feec9 100644 --- a/src/fockhf1_ty.f90 +++ b/src/fockhf1_ty.f90 @@ -26,9 +26,9 @@ SUBROUTINE fockhf1_ty ! TO CALCULATE FOCK MATRIX OF HF STATE, A TEST !! 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. - if (rank == 0) then ! Process limits for output - write (*, *) ' ' - write (*, *) 'FOR TEST, FOCK MATRIX OF HF STATE IS CALCULATED ' + if (rank == 0) then + print *, ' ' + print *, 'FOR TEST, FOCK MATRIX OF HF STATE IS CALCULATED ' end if n = 0 f = 0.0d+00 @@ -67,26 +67,26 @@ SUBROUTINE fockhf1_ty ! TO CALCULATE FOCK MATRIX OF HF STATE, A TEST call MPI_Allreduce(MPI_IN_PLACE, f(1, 1), nmo**2, MPI_COMPLEX16, MPI_SUM, MPI_COMM_WORLD, ierr) #endif - if (rank == 0) then ! Process limits for output - write (*, *) ' ' - write (*, *) 'OFF DIAGONAL ELEMENTS OF FOCK MATRIX WHICH IS LARGER THAN 1.0d-06 ' - write (*, *) ' ' + if (rank == 0) then + print *, ' ' + print *, 'OFF DIAGONAL ELEMENTS OF FOCK MATRIX WHICH IS LARGER THAN 1.0d-06 ' + print *, ' ' do i = 1, ninact + nact + nsec do j = i, ninact + nact + nsec if ((i /= j) .and. (ABS(f(i, j)) > 1.0d-6)) then - write (*, '(2I4,2E20.10)') i, j, f(i, j) + print '(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) '& + print *, ' ' + print *, 'THESE DIAGONAL ELEMENTS SHOULD BE CORESPOND TO HF SPINOR ENERGY ' + print *, ' ' + print *, ' 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)) + print '(I4,4E20.10)', i, f(i, i), orbmo(i), orbmo(i) - dble(f(i, i)) end do - write (*, *) 'fockhf end' + print *, 'fockhf end' end if end SUBROUTINE fockhf1_ty diff --git a/src/four_caspt2_module.f90 b/src/four_caspt2_module.f90 index 08e53c3a..b56cd3d7 100644 --- a/src/four_caspt2_module.f90 +++ b/src/four_caspt2_module.f90 @@ -93,7 +93,7 @@ MODULE four_caspt2_module integer, allocatable :: irpmo(:), irpamo(:) ! symmetry number of the specific mo integer, allocatable :: indmo(:), indmor(:) ! index of MO real*8, allocatable :: oner(:, :), onei(:, :) ! one-electron integral (real,imaginal) - real*8, allocatable :: orbmo(:), orb(:) + real*8, allocatable :: orbmo(:), orb(:), sort_orb(:) real*8, allocatable :: orbmocas(:), orbcas(:) integer, allocatable ::multb_s(:, :), multb_d(:, :), multb_ds(:, :) ! This is for typart diff --git a/src/get_filename.f90 b/src/get_filename.f90 index 104022cd..1a0e6c7f 100644 --- a/src/get_filename.f90 +++ b/src/get_filename.f90 @@ -14,10 +14,10 @@ subroutine get_mdcint_filename(count) filename_idx = count*nprocs + rank mdcint_basename = "MDCIN" if (filename_idx >= 100000) then!! "ERROR": over six digit(can't assign) - write (*, *) "ERROR: Can't assign MDCINT file to ranks of over six digits. filename_idx:", filename_idx + print *, "ERROR: Can't assign MDCINT file to ranks of over six digits. filename_idx:", filename_idx stop else if (filename_idx < 0) then !! "ERROR": minus number filename_idx (can't assign) - write (*, *) "ERROR: Can't assign MDCINT file to negative number of ranks. filename_idx:", filename_idx + print *, "ERROR: Can't assign MDCINT file to negative number of ranks. filename_idx:", filename_idx stop else if (filename_idx < 10) then ! one digit (1~9) digit_x_padding = "XXXX" @@ -38,8 +38,8 @@ subroutine get_mdcint_filename(count) mdcint_int = "MDCINT_int"//TRIM(ADJUSTL(chr_rank)) end if end if - if (rank == 0) then ! Process limits for output - write (*, *) "get filename : ", trim(mdcint_filename), " ", & + if (rank == 0) then + print *, "get filename : ", trim(mdcint_filename), " ", & trim(mdcintnew), " ", trim(mdcint_debug), " ", trim(mdcint_int) end if end subroutine get_mdcint_filename diff --git a/src/intra.f90 b/src/intra.f90 index 7b225566..01414db8 100644 --- a/src/intra.f90 +++ b/src/intra.f90 @@ -22,10 +22,9 @@ SUBROUTINE intra_1(spi, spj, spk, spl, fname) complex*16 :: cint2 integer :: i, j, k, l, i1, j1, k1, l1, inew, jnew, knew, lnew - integer :: ii, ji, ki, li, ie, je, ke, le + integer :: ii, ji, ki, li, ie, je, ke, le, iostat integer :: nmx, ini(3), end(3), isp, isym, imo - logical :: is_opened thresd = 1.0d-15 ini(1) = 1 @@ -67,9 +66,7 @@ SUBROUTINE intra_1(spi, spj, spk, spl, fname) ! write(*,'("C1int",8I4)')ii,ie,ji,je,ki,ke,li,leE traint2 = 0.0d+00 - if (rank == 0) then ! Process limits for output - write (*, '("Current Memory is ",F10.2,"MB")') tmem/1024/1024 - end if + if (rank == 0) print '("Current Memory is ",F10.2,"MB")', tmem/1024/1024 !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~! ! Read intergals and first index transformation ! @@ -77,27 +74,36 @@ SUBROUTINE intra_1(spi, spj, spk, spl, fname) !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ open (1, file=trim(fname), status='old', form='unformatted') ! no symmetry about spi,spj,spk,spl + 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 the first index integral transformation '//trim(fname) + 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 -30 read (1, err=10, end=20) i, j, k, l, cint2 - - isym = irpmo(l) + isym = irpmo(l) - Do lnew = 1, nsym(spl, isym) - l1 = indsym(spl, isym, lnew) - traint2(i, j, k, l1) = traint2(i, j, k, l1) + cint2*f(l, l1) - End do + Do lnew = 1, nsym(spl, isym) + l1 = indsym(spl, isym, lnew) + traint2(i, j, k, l1) = traint2(i, j, k, l1) + cint2*f(l, l1) + End do - Call takekr(i, j, k, l, cint2) - isym = irpmo(l) + Call takekr(i, j, k, l, cint2) + isym = irpmo(l) - Do lnew = 1, nsym(spl, isym) - l1 = indsym(spl, isym, lnew) - traint2(i, j, k, l1) = traint2(i, j, k, l1) + cint2*f(l, l1) - End do + Do lnew = 1, nsym(spl, isym) + l1 = indsym(spl, isym, lnew) + traint2(i, j, k, l1) = traint2(i, j, k, l1) + cint2*f(l, l1) + End do - goto 30 ! Continue to read 2-integrals + end do -20 close (1) + 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), & @@ -121,18 +127,26 @@ SUBROUTINE intra_1(spi, spj, spk, spl, fname) !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ open (1, file=trim(fname), status='old', form='unformatted') -31 read (1, err=10, end=21) i, j, k, l, cint2 - - isym = irpmo(k) - - Do knew = 1, nsym(spk, isym) - k1 = indsym(spk, isym, knew) - traint2(i, j, k1, l) = traint2(i, j, k1, l) + cint2*DCONJG(f(k, k1)) - End do + 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 the second index integral transformation '//trim(fname) + 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) - goto 31 ! Continue to read integrals + Do knew = 1, nsym(spk, isym) + k1 = indsym(spk, isym, knew) + traint2(i, j, k1, l) = traint2(i, j, k1, l) + cint2*DCONJG(f(k, k1)) + End do -21 close (1) + end do + 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) @@ -155,19 +169,27 @@ SUBROUTINE intra_1(spi, spj, spk, spl, fname) !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ open (1, file=trim(fname), status='old', form='unformatted') + 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 the third index integral transformation '//trim(fname) + 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) -32 read (1, err=10, end=22) i, j, k, l, cint2 - - isym = irpmo(j) - - Do jnew = 1, nsym(spj, isym) - j1 = indsym(spj, isym, jnew) - traint2(i, j1, k, l) = traint2(i, j1, k, l) + cint2*f(j, j1) - End do + Do jnew = 1, nsym(spj, isym) + j1 = indsym(spj, isym, jnew) + traint2(i, j1, k, l) = traint2(i, j1, k, l) + cint2*f(j, j1) + End do - goto 32 ! Continue to read 2-integrals + end do -22 close (1) + 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) @@ -190,19 +212,26 @@ SUBROUTINE intra_1(spi, spj, spk, spl, fname) !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ open (1, file=trim(fname), status='old', form='unformatted') + 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 the fourth index integral transformation '//trim(fname) + 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) -33 read (1, err=10, end=23) i, j, k, l, cint2 - - isym = irpmo(i) - - Do inew = 1, nsym(spi, isym) - i1 = indsym(spi, isym, inew) - traint2(i1, j, k, l) = traint2(i1, j, k, l) + cint2*DCONJG(f(i, i1)) - End do - - goto 33 ! Continue to read 2-integrals + Do inew = 1, nsym(spi, isym) + i1 = indsym(spi, isym, inew) + traint2(i1, j, k, l) = traint2(i1, j, k, l) + cint2*DCONJG(f(i, i1)) + End do -23 close (1) + end do + 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) @@ -217,11 +246,6 @@ SUBROUTINE intra_1(spi, spj, spk, spl, fname) 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) - goto 100 -10 write (*, *) 'error opening file' -100 continue - close (1) - deallocate (traint2); Call memminus(KIND(traint2), SIZE(traint2), 2) deallocate (indsym); Call memminus(KIND(indsym), SIZE(indsym), 1) @@ -255,13 +279,12 @@ SUBROUTINE intra_2(spi, spj, spk, spl, fname) integer :: i, j, k, l integer :: i1, j1, k1, l1, inew, jnew, knew, lnew integer :: ii, ji, ki, li, ie, je, ke, le - integer :: nmx, ini(3), end(3), isp, isym, imo, save + integer :: nmx, ini(3), end(3), isp, isym, imo, save, iostat - logical :: is_opened thresd = 1.0d-15 if (.not. (spi == spk .and. spj == spl)) then - write (*, *) 'error intra_2', spi, spj, spk, spl + print *, 'error intra_2', spi, spj, spk, spl stop end if @@ -301,9 +324,7 @@ SUBROUTINE intra_2(spi, spj, spk, spl, fname) Allocate (traint2(ii:ie, ji:je, ki:ke, li:le)); Call memplus(KIND(traint2), SIZE(traint2), 2) traint2 = 0.0d+00 - if (rank == 0) then ! Process limits for output - write (*, '("Current Memory is ",F10.2,"MB")') tmem/1024/1024 - end if + if (rank == 0) print '("Current Memory is ",F10.2,"MB")', tmem/1024/1024 !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~! ! Read intergals and first index transformation ! @@ -311,63 +332,75 @@ SUBROUTINE intra_2(spi, spj, spk, spl, fname) !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ open (1, file=trim(fname), status='old', form='unformatted') -30 read (1, err=10, end=20) i, j, k, l, cint2 - - isym = irpmo(l) + 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 the first index integral transformation '//trim(fname) + 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) - Do lnew = 1, nsym(spl, isym) - l1 = indsym(spl, isym, lnew) - traint2(i, j, k, l1) = traint2(i, j, k, l1) + cint2*f(l, l1) - End do + Do lnew = 1, nsym(spl, isym) + l1 = indsym(spl, isym, lnew) + traint2(i, j, k, l1) = traint2(i, j, k, l1) + cint2*f(l, l1) + End do - if (i == k .and. j == l) goto 50 - if (ABS(i - k) == 1 .and. ABS(j - l) == 1 .and. & - & ABS(i/2 - k/2) == 1 .and. ABS(j/2 - l/2) == 1) goto 50 - - ! swap indices i = k, j = l, k = i, l = j - save = i - i = k - k = save - save = j - j = l - l = save - isym = irpmo(l) - - Do lnew = 1, nsym(spl, isym) - l1 = indsym(spl, isym, lnew) - traint2(i, j, k, l1) = traint2(i, j, k, l1) + cint2*f(l, l1) - End do + if (i == k .and. j == l) then + continue + else if (ABS(i - k) == 1 .and. ABS(j - l) == 1 .and. & + & ABS(i/2 - k/2) == 1 .and. ABS(j/2 - l/2) == 1) then + continue + else -50 Call takekr(i, j, k, l, cint2) - isym = irpmo(l) + ! swap indices i = k, j = l, k = i, l = j + save = i + i = k + k = save + save = j + j = l + l = save + isym = irpmo(l) + + Do lnew = 1, nsym(spl, isym) + l1 = indsym(spl, isym, lnew) + traint2(i, j, k, l1) = traint2(i, j, k, l1) + cint2*f(l, l1) + End do + end if + Call takekr(i, j, k, l, cint2) + isym = irpmo(l) - Do lnew = 1, nsym(spl, isym) - l1 = indsym(spl, isym, lnew) - traint2(i, j, k, l1) = traint2(i, j, k, l1) + cint2*f(l, l1) - End do + Do lnew = 1, nsym(spl, isym) + l1 = indsym(spl, isym, lnew) + traint2(i, j, k, l1) = traint2(i, j, k, l1) + cint2*f(l, l1) + End do - if (i == k .and. j == l) goto 30 ! Continue to read 2-integrals - if (ABS(i - k) == 1 .and. ABS(j - l) == 1 .and. & - & ABS(i/2 - k/2) == 1 .and. ABS(j/2 - l/2) == 1) goto 30 ! Continue to read 2-integrals + if (i == k .and. j == l) cycle ! Continue to read 2-integrals + if (ABS(i - k) == 1 .and. ABS(j - l) == 1 .and. & + & ABS(i/2 - k/2) == 1 .and. ABS(j/2 - l/2) == 1) cycle ! Continue to read 2-integrals - ! swap indecis i = k, j = l, k = i, l = j - save = i - i = k - k = save - save = j - j = l - l = save + ! swap indecis i = k, j = l, k = i, l = j + save = i + i = k + k = save + save = j + j = l + l = save - isym = irpmo(l) + isym = irpmo(l) - Do lnew = 1, nsym(spl, isym) - l1 = indsym(spl, isym, lnew) - traint2(i, j, k, l1) = traint2(i, j, k, l1) + cint2*f(l, l1) - End do + Do lnew = 1, nsym(spl, isym) + l1 = indsym(spl, isym, lnew) + traint2(i, j, k, l1) = traint2(i, j, k, l1) + cint2*f(l, l1) + End do - goto 30 ! Continue to read 2-integrals + end do -20 close (1) + 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), & @@ -391,18 +424,28 @@ SUBROUTINE intra_2(spi, spj, spk, spl, fname) !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ open (1, file=trim(fname), status='old', form='unformatted') -31 read (1, err=10, end=21) i, j, k, l, cint2 - - isym = irpmo(k) + 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 the second index integral transformation '//trim(fname) + 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 - Do knew = 1, nsym(spk, isym) - k1 = indsym(spk, isym, knew) - traint2(i, j, k1, l) = traint2(i, j, k1, l) + cint2*DCONJG(f(k, k1)) - End do + isym = irpmo(k) - goto 31 ! Continue to read 2-integrals + Do knew = 1, nsym(spk, isym) + k1 = indsym(spk, isym, knew) + traint2(i, j, k1, l) = traint2(i, j, k1, l) + cint2*DCONJG(f(k, k1)) + End do + end do -21 close (1) + 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) @@ -425,18 +468,28 @@ SUBROUTINE intra_2(spi, spj, spk, spl, fname) !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ open (1, file=trim(fname), status='old', form='unformatted') -32 read (1, err=10, end=22) i, j, k, l, cint2 + 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 the third index integral transformation '//trim(fname) + 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) + isym = irpmo(j) - Do jnew = 1, nsym(spj, isym) - j1 = indsym(spj, isym, jnew) - traint2(i, j1, k, l) = traint2(i, j1, k, l) + cint2*f(j, j1) - End do + Do jnew = 1, nsym(spj, isym) + j1 = indsym(spj, isym, jnew) + traint2(i, j1, k, l) = traint2(i, j1, k, l) + cint2*f(j, j1) + End do - goto 32 + end do -22 close (1) + 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) @@ -459,18 +512,29 @@ SUBROUTINE intra_2(spi, spj, spk, spl, fname) !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ open (1, file=trim(fname), status='old', form='unformatted') -33 read (1, err=10, end=23) i, j, k, l, cint2 + 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 the fourth index integral transformation '//trim(fname) + 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) + isym = irpmo(i) - Do inew = 1, nsym(spi, isym) - i1 = indsym(spi, isym, inew) - traint2(i1, j, k, l) = traint2(i1, j, k, l) + cint2*DCONJG(f(i, i1)) - End do + Do inew = 1, nsym(spi, isym) + i1 = indsym(spi, isym, inew) + traint2(i1, j, k, l) = traint2(i1, j, k, l) + cint2*DCONJG(f(i, i1)) + End do - goto 33 ! Continue to read 2-integrals + end do -23 close (1) + 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) @@ -485,10 +549,6 @@ SUBROUTINE intra_2(spi, spj, spk, spl, fname) 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) - goto 100 -10 write (*, *) 'error opening file' -100 continue - close (1) 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) @@ -522,13 +582,12 @@ SUBROUTINE intra_3(spi, spj, spk, spl, fname) integer :: initial_i, initial_j, initial_k, initial_l integer :: i1, j1, k1, l1, inew, jnew, knew, lnew integer :: ii, ji, ki, li, ie, je, ke, le - integer :: nmx, ini(3), end(3), isp, isym, imo + integer :: nmx, ini(3), end(3), isp, isym, imo, iostat - logical :: is_opened thresd = 1.0d-15 if (.not. (spk == spl)) then - write (*, *) 'error intra_3', spi, spj, spk, spl + print *, 'error intra_3', spi, spj, spk, spl stop end if ini(1) = 1 @@ -570,9 +629,7 @@ SUBROUTINE intra_3(spi, spj, spk, spl, fname) ! write(*,'("intra_3",8I4)')ii,ie,ji,je,ki,ke,li,le traint2 = 0.0d+00 - if (rank == 0) then ! Process limits for output - write (*, '("Current Memory is ",F10.2,"MB")') tmem/1024/1024 - end if + if (rank == 0) print '("Current Memory is ",F10.2,"MB")', tmem/1024/1024 !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~! ! Read intergals and first index transformation ! @@ -580,57 +637,69 @@ SUBROUTINE intra_3(spi, spj, spk, spl, fname) !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ open (1, file=trim(fname), status='old', form='unformatted') -30 read (1, err=10, end=20) i, j, k, l, cint2 - ! save initial indices i,j,k,l to initial_i,initial_j,initial_k,initial_l, respectively. - initial_i = i - initial_j = j - initial_k = k - initial_l = l - - isym = irpamo(l) - - Do lnew = 1, nsym(spl, isym) - l1 = indsym(spl, isym, lnew) - traint2(i, j, k, l1) = traint2(i, j, k, l1) + cint2*f(l, l1) - End do + 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 the first index integral transformation '//trim(fname) + 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. + initial_i = i + initial_j = j + initial_k = k + initial_l = l + + isym = irpamo(l) + + Do lnew = 1, nsym(spl, isym) + l1 = indsym(spl, isym, lnew) + traint2(i, j, k, l1) = traint2(i, j, k, l1) + cint2*f(l, l1) + End do - Call takekr(i, j, k, l, cint2) - isym = irpamo(l) + Call takekr(i, j, k, l, cint2) + isym = irpamo(l) !Iwamuro modify ! write(*,'("takekr",4I4,2E20.10)')i,j,k,l,cint2 - Do lnew = 1, nsym(spl, isym) - l1 = indsym(spl, isym, lnew) - traint2(i, j, k, l1) = traint2(i, j, k, l1) + cint2*f(l, l1) - End do + Do lnew = 1, nsym(spl, isym) + l1 = indsym(spl, isym, lnew) + traint2(i, j, k, l1) = traint2(i, j, k, l1) + cint2*f(l, l1) + End do - if (ABS(k - l) == 1 .and. ABS(k/2 - l/2) == 1) goto 30 ! Continue to read 2-integrals + if (ABS(k - l) == 1 .and. ABS(k/2 - l/2) == 1) cycle ! Continue to read 2-integrals - i = initial_i - j = initial_j - if (mod(initial_k, 2) == 0) l = initial_k - 1 - if (mod(initial_k, 2) == 1) l = initial_k + 1 - if (mod(initial_l, 2) == 0) k = initial_l - 1 - if (mod(initial_l, 2) == 1) k = initial_l + 1 - cint2 = (-1.0d+00)**mod(initial_k + initial_l, 2)*cint2 - isym = irpamo(l) + i = initial_i + j = initial_j + if (mod(initial_k, 2) == 0) l = initial_k - 1 + if (mod(initial_k, 2) == 1) l = initial_k + 1 + if (mod(initial_l, 2) == 0) k = initial_l - 1 + if (mod(initial_l, 2) == 1) k = initial_l + 1 + cint2 = (-1.0d+00)**mod(initial_k + initial_l, 2)*cint2 + isym = irpamo(l) - Do lnew = 1, nsym(spl, isym) - l1 = indsym(spl, isym, lnew) - traint2(i, j, k, l1) = traint2(i, j, k, l1) + cint2*f(l, l1) - End do + Do lnew = 1, nsym(spl, isym) + l1 = indsym(spl, isym, lnew) + traint2(i, j, k, l1) = traint2(i, j, k, l1) + cint2*f(l, l1) + End do - Call takekr(i, j, k, l, cint2) - isym = irpamo(l) + Call takekr(i, j, k, l, cint2) + isym = irpamo(l) - Do lnew = 1, nsym(spl, isym) - l1 = indsym(spl, isym, lnew) - traint2(i, j, k, l1) = traint2(i, j, k, l1) + cint2*f(l, l1) - End do + Do lnew = 1, nsym(spl, isym) + l1 = indsym(spl, isym, lnew) + traint2(i, j, k, l1) = traint2(i, j, k, l1) + cint2*f(l, l1) + End do - goto 30 ! Continue to read 2-integrals + end do -20 close (1) + 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) @@ -652,22 +721,30 @@ SUBROUTINE intra_3(spi, spj, spk, spl, fname) ! ! !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - if (rank == 0) then ! Process limits for output - write (*, *) 'Read intergals and second index transformation' - end if open (1, file=trim(fname), status='old', form='unformatted') -31 read (1, err=10, end=21) i, j, k, l, cint2 + 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 the second index integral transformation '//trim(fname) + 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) + isym = irpamo(k) - Do knew = 1, nsym(spk, isym) - k1 = indsym(spk, isym, knew) - traint2(i, j, k1, l) = traint2(i, j, k1, l) + cint2*DCONJG(f(k, k1)) - End do + Do knew = 1, nsym(spk, isym) + k1 = indsym(spk, isym, knew) + traint2(i, j, k1, l) = traint2(i, j, k1, l) + cint2*DCONJG(f(k, k1)) + End do - goto 31 + end do -21 close (1) + 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) @@ -689,18 +766,29 @@ SUBROUTINE intra_3(spi, spj, spk, spl, fname) !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ open (1, file=trim(fname), status='old', form='unformatted') -32 read (1, err=10, end=22) i, j, k, l, cint2 + 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 third index integral transformation '//trim(fname) + 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) + isym = irpamo(j) - Do jnew = 1, nsym(spj, isym) - j1 = indsym(spj, isym, jnew) - traint2(i, j1, k, l) = traint2(i, j1, k, l) + cint2*f(j, j1) - End do + Do jnew = 1, nsym(spj, isym) + j1 = indsym(spj, isym, jnew) + traint2(i, j1, k, l) = traint2(i, j1, k, l) + cint2*f(j, j1) + End do - goto 32 + end do -22 close (1) + 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) @@ -723,18 +811,29 @@ SUBROUTINE intra_3(spi, spj, spk, spl, fname) !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ open (1, file=trim(fname), status='old', form='unformatted') -33 read (1, err=10, end=23) i, j, k, l, cint2 + 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 the fourth index integral transformation '//trim(fname) + 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) + isym = irpamo(i) - Do inew = 1, nsym(spi, isym) - i1 = indsym(spi, isym, inew) - traint2(i1, j, k, l) = traint2(i1, j, k, l) + cint2*DCONJG(f(i, i1)) - End do + Do inew = 1, nsym(spi, isym) + i1 = indsym(spi, isym, inew) + traint2(i1, j, k, l) = traint2(i1, j, k, l) + cint2*DCONJG(f(i, i1)) + End do - goto 33 + end do -23 close (1) + 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) @@ -747,14 +846,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) - goto 100 ! No error in intra3 - -10 write (*, *) 'error opening file' -100 continue close (1) - if (rank == 0) write (*, *) 'read and write file properly. filename : ', trim(fname) -101 continue + if (rank == 0) print *, 'read and write file properly. filename : ', trim(fname) 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) diff --git a/src/prtoutfock.f90 b/src/prtoutfock.f90 index 2514436d..401238c4 100644 --- a/src/prtoutfock.f90 +++ b/src/prtoutfock.f90 @@ -13,65 +13,63 @@ SUBROUTINE prtoutfock ! TO PRINT OUT FOCK MATRIX ! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= ! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= - - write (*, *) 'inactive-inactive' + print *, 'inactive-inactive' do i = 1, ninact do j = 1, ninact if ((i /= j) .and. (ABS(f(i, j)) > 1.0d-10)) then - write (*, '(2I4,3E20.10)') i, j, f(i, j), oner(i, j) + print '(2I4,3E20.10)', i, j, f(i, j), oner(i, j) end if end do end do - write (*, *) 'inactive-active' + print *, 'inactive-active' do i = 1, ninact do j = ninact + 1, ninact + nact if ((i /= j) .and. (ABS(f(i, j)) > 1.0d-10)) then - write (*, '(2I4,3E20.10)') i, j, f(i, j), oner(i, j) + print '(2I4,3E20.10)', i, j, f(i, j), oner(i, j) end if end do end do - write (*, *) 'inactive-secondary' + print *, 'inactive-secondary' do i = 1, ninact do j = ninact + nact + 1, ninact + nact + nsec if ((i /= j) .and. (ABS(f(i, j)) > 1.0d-10)) then - write (*, '(2I4,3E20.10)') i, j, f(i, j), oner(i, j) + print '(2I4,3E20.10)', i, j, f(i, j), oner(i, j) end if end do end do - write (*, *) 'active-active' + print *, 'active-active' do i = ninact + 1, ninact + nact do j = ninact + 1, ninact + nact if ((i /= j) .and. (ABS(f(i, j)) > 1.0d-10)) then - write (*, '(2I4,3E20.10)') i, j, f(i, j), oner(i, j) + print '(2I4,3E20.10)', i, j, f(i, j), oner(i, j) end if end do end do - write (*, *) 'active-secondary' + print *, 'active-secondary' do i = ninact + 1, ninact + nact do j = ninact + nact + 1, ninact + nact + nsec if ((i /= j) .and. (ABS(f(i, j)) > 1.0d-10)) then - write (*, '(2I4,3E20.10)') i, j, f(i, j), oner(i, j) + print '(2I4,3E20.10)', i, j, f(i, j), oner(i, j) end if end do end do - write (*, *) 'secondary-secondary' + print *, 'secondary-secondary' do i = ninact + nact + 1, ninact + nact + nsec do j = ninact + nact + 1, ninact + nact + nsec if ((i /= j) .and. (ABS(f(i, j)) > 1.0d-10)) then - write (*, '(2I4,3E20.10)') i, j, f(i, j), oner(i, j) + print '(2I4,3E20.10)', i, j, f(i, j), oner(i, j) end if end do end do - end SUBROUTINE prtoutfock diff --git a/src/r4dcasci_co.f90 b/src/r4dcasci_co.f90 index 4a9c7cbf..06177a02 100644 --- a/src/r4dcasci_co.f90 +++ b/src/r4dcasci_co.f90 @@ -35,44 +35,47 @@ PROGRAM r4dcasci_co ! DO CASCI CALC IN THIS PROGRAM! #else rank = 0; nprocs = 1 #endif - if (rank == 0) then ! Process limits for output - write (*, '(A,I8,A,I8)') 'initialization of mpi, rank :', rank, ' nprocs :', nprocs - write (*, *) '' - write (*, *) ' ENTER R4DCASCI_TY PROGRAM written by M. Abe 2007.7.19' - write (*, *) '' + if (rank == 0) then + print '(A,I8,A,I8)', 'initialization of mpi, rank :', rank, ' nprocs :', nprocs + print *, '' + print *, ' ENTER R4DCASCI_TY PROGRAM written by M. Abe 2007.7.19' + print *, '' end if tmem = 0.0d+00 - if (rank == 0) then ! Process limits for output - write (*, '("Current Memory is ",F10.2,"MB")') tmem/1024/1024 + if (rank == 0) then + print '("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) + print *, 'Year = ', val(1), 'Mon = ', val(2), 'Date = ', val(3) + print *, '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 + print *, inittime end if call read_input - if (rank == 0) then ! Process limits for output - 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 (*, *) 'ptgrp =', ptgrp - write (*, *) 'dirac_version =', dirac_version + if (rank == 0) then + print *, 'ninact =', ninact + print *, 'nact =', nact + print *, 'nsec =', nsec + print *, 'nelec =', nelec + print *, 'nroot =', nroot + print *, 'selectroot =', selectroot + print *, 'totsym =', totsym + print *, 'ncore =', ncore + print *, 'nbas =', nbas + print *, 'eshift =', eshift + print *, 'ptgrp =', ptgrp + print *, 'dirac_version =', dirac_version + if (is_ras1_configured) print *, "RAS1 =", ras1_list + if (is_ras2_configured) print *, "RAS2 =", ras2_list + if (is_ras3_configured) print *, "RAS3 =", ras3_list end if !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! filename = 'MRCONEE' @@ -80,29 +83,22 @@ PROGRAM r4dcasci_co ! DO CASCI CALC IN THIS PROGRAM! call readorb_enesym_co(filename) call read1mo_co(filename) - if (rank == 0) then ! Process limits for output - write (*, *) 'realc', realc, ECORE, ninact, nact, nsec, nmo - end if + if (rank == 0) print *, 'realc', realc, ECORE, ninact, nact, nsec, nmo + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! !Iwamuro create new ikr for dirac Call create_newmdcint - if (rank == 0) then ! Process limits for output - write (*, '(a)') 'Before readint2_casci_co' - end if + if (rank == 0) print '(a)', 'Before readint2_casci_co' Call readint2_casci_co(mdcintnew, nuniq) - if (rank == 0) then ! Process limits for output - write (*, *) 'nmo =', nmo - end if + if (rank == 0) print *, 'nmo =', nmo nmo = ninact + nact + nsec !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - if (rank == 0) then ! Process limits for output - write (*, *) "iwamuro modify" - end if + if (rank == 0) print *, "iwamuro modify" If (mod(nelec, 2) == 0) then inisym = nsymrp + 1 endsym = 2*nsymrp @@ -111,39 +107,39 @@ PROGRAM r4dcasci_co ! DO CASCI CALC IN THIS PROGRAM! endsym = nsymrp End if - if (rank == 0) then ! Process limits for output - write (*, '("Current Memory is ",F10.2,"MB")') tmem/1024/1024 + if (rank == 0) then + print '("Current Memory is ",F10.2,"MB")', tmem/1024/1024 - write (*, *) ' ' - write (*, *) '*******************************' - write (*, *) ' ' - write (*, *) 'IREP IS ', repna(totsym) - write (*, *) ' ' - write (*, *) '*******************************' - write (*, *) ' ' + print *, ' ' + print *, '*******************************' + print *, ' ' + print *, 'IREP IS ', repna(totsym) + print *, ' ' + print *, '*******************************' + print *, ' ' end if realcvec = .TRUE. Call casci_ty ! This is test for bug fix about realc part - if (rank == 0) then ! Process limits for output - write (*, *) realc, 'realc' - write (*, *) realcvec, 'realcvec' + if (rank == 0) then + print *, realc, 'realc' + print *, realcvec, 'realcvec' end if test = .true. - if (rank == 0) then ! Process limits for output - write (*, *) realc, 'realc' - write (*, *) realcvec, 'realcvec' + if (rank == 0) then + print *, realc, 'realc' + print *, realcvec, 'realcvec' end if realc = .FALSE. !!! realc =.TRUE. realcvec = .FALSE. !!! realcvec =.TRUE. - if (rank == 0) then ! Process limits for output - write (*, *) 'FOR TEST WE DO (F,F)' - write (*, *) realc, 'realc' - write (*, *) realcvec, 'realcvec' + if (rank == 0) then + print *, 'FOR TEST WE DO (F,F)' + print *, realc, 'realc' + print *, realcvec, 'realcvec' end if !!=============================================! ! ! @@ -153,9 +149,7 @@ PROGRAM r4dcasci_co ! DO CASCI CALC IN THIS PROGRAM! Call e0test_v2 - if (rank == 0) then ! Process limits for output - write (*, '("Current Memory is ",F10.2,"MB")') tmem/1024/1024 - end if + if (rank == 0) print '("Current Memory is ",F10.2,"MB")', tmem/1024/1024 !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~! ! BUILDING FOCK MATRIX ! ! fij = hij + SIGUMA[<0|Ekl|0>{(ij|kl)-(il|kj)} ! @@ -171,9 +165,7 @@ PROGRAM r4dcasci_co ! DO CASCI CALC IN THIS PROGRAM! debug = .TRUE. If (debug) then f(:, :) = 0.0d+00 - if (rank == 0) then ! Process limits for output - write (*, *) 'fockhf1_ty start' - end if + if (rank == 0) print *, 'fockhf1_ty start' Call fockhf1_ty End if @@ -182,23 +174,21 @@ PROGRAM r4dcasci_co ! DO CASCI CALC IN THIS PROGRAM! f(:, :) = 0.0d+00 if (rank == 0) then - write (*, *) 'before building fock' + print *, 'before building fock' date1 = date0 tsec1 = tsec0 Call timing(date1, tsec1, date0, tsec0) end if Call fockcasci_ty if (rank == 0) then - write (*, *) 'end building fock' + print *, 'end building fock' date1 = date0 tsec1 = tsec0 Call timing(date1, tsec1, date0, tsec0) end if ! debug = .TRUE. debug = .FALSE. - if (rank == 0) then ! Process limits for output - write (*, *) debug, 'debug' - end if + if (rank == 0) print *, debug, 'debug' if (debug) Call prtoutfock Allocate (eps(nmo)); Call memplus(KIND(eps), SIZE(eps), 1) @@ -206,9 +196,9 @@ PROGRAM r4dcasci_co ! DO CASCI CALC IN THIS PROGRAM! Call fockdiag_ty - if (rank == 0) then ! Process limits for output + if (rank == 0) then Do i0 = 1, nmo - write (*, *) 'eps(', i0, ')=', eps(i0) + print *, 'eps(', i0, ')=', eps(i0) End do end if @@ -218,39 +208,42 @@ PROGRAM r4dcasci_co ! DO CASCI CALC IN THIS PROGRAM! write (5) eps(1:nmo) close (5) end if - - 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 (idetr); Call memminus(KIND(idetr), SIZE(idetr), 1) - deallocate (MULTB_S); Call memminus(KIND(MULTB_S), SIZE(MULTB_S), 1) - deallocate (MULTB_D); Call memminus(KIND(MULTB_D), SIZE(MULTB_D), 1) - deallocate (MULTB_DS); Call memminus(KIND(MULTB_DS), SIZE(MULTB_DS), 1) - deallocate (MULTB_DF); Call memminus(KIND(MULTB_DF), SIZE(MULTB_DF), 1) - deallocate (MULTB_DB); Call memminus(KIND(MULTB_DB), SIZE(MULTB_DB), 1) - deallocate (MULTB_SB); Call memminus(KIND(MULTB_SB), SIZE(MULTB_SB), 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 (inttwi); Call memminus(KIND(inttwi), SIZE(inttwi), 1) - deallocate (oner); Call memminus(KIND(oner), SIZE(oner), 1) - deallocate (inttwr); Call memminus(KIND(inttwr), SIZE(inttwr), 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) - if (rank == 0) then ! Process limits for output - write (*, '("Current Memory is ",F10.2,"MB")') tmem/1024/1024 + ! end if + + if (allocated(ras1_list)) deallocate (ras1_list); Call memminus(KIND(ras1_list), SIZE(ras1_list), 1) + if (allocated(ras2_list)) deallocate (ras2_list); Call memminus(KIND(ras2_list), SIZE(ras2_list), 1) + if (allocated(ras3_list)) deallocate (ras3_list); Call memminus(KIND(ras3_list), SIZE(ras3_list), 1) + if (allocated(sp)) deallocate (sp); Call memminus(KIND(sp), SIZE(sp), 1) + if (allocated(cir)) deallocate (cir); Call memminus(KIND(cir), SIZE(cir), 1) + if (allocated(cii)) deallocate (cii); Call memminus(KIND(cii), SIZE(cii), 1) + if (allocated(eigen)) deallocate (eigen); Call memminus(KIND(eigen), SIZE(eigen), 1) + if (allocated(f)) deallocate (f); Call memminus(KIND(f), SIZE(f), 2) + if (allocated(eps)) deallocate (eps); Call memminus(KIND(eps), SIZE(eps), 1) + if (allocated(idet)) deallocate (idet); Call memminus(KIND(idet), SIZE(idet), 1) + if (allocated(idetr)) deallocate (idetr); Call memminus(KIND(idetr), SIZE(idetr), 1) + if (allocated(MULTB_S)) deallocate (MULTB_S); Call memminus(KIND(MULTB_S), SIZE(MULTB_S), 1) + if (allocated(MULTB_D)) deallocate (MULTB_D); Call memminus(KIND(MULTB_D), SIZE(MULTB_D), 1) + if (allocated(MULTB_DS)) deallocate (MULTB_DS); Call memminus(KIND(MULTB_DS), SIZE(MULTB_DS), 1) + if (allocated(MULTB_DF)) deallocate (MULTB_DF); Call memminus(KIND(MULTB_DF), SIZE(MULTB_DF), 1) + if (allocated(MULTB_DB)) deallocate (MULTB_DB); Call memminus(KIND(MULTB_DB), SIZE(MULTB_DB), 1) + if (allocated(MULTB_SB)) deallocate (MULTB_SB); Call memminus(KIND(MULTB_SB), SIZE(MULTB_SB), 1) + if (allocated(irpmo)) deallocate (irpmo); Call memminus(KIND(irpmo), SIZE(irpmo), 1) + if (allocated(irpamo)) deallocate (irpamo); Call memminus(KIND(irpamo), SIZE(irpamo), 1) + if (allocated(indmo)) deallocate (indmo); Call memminus(KIND(indmo), SIZE(indmo), 1) + if (allocated(indmor)) deallocate (indmor); Call memminus(KIND(indmor), SIZE(indmor), 1) + if (allocated(onei)) deallocate (onei); Call memminus(KIND(onei), SIZE(onei), 1) + if (allocated(inttwi)) deallocate (inttwi); Call memminus(KIND(inttwi), SIZE(inttwi), 1) + if (allocated(oner)) deallocate (oner); Call memminus(KIND(oner), SIZE(oner), 1) + if (allocated(inttwr)) deallocate (inttwr); Call memminus(KIND(inttwr), SIZE(inttwr), 1) + if (allocated(int2r_f1)) deallocate (int2r_f1); Call memminus(KIND(int2r_f1), SIZE(int2r_f1), 1) + if (allocated(int2i_f1)) deallocate (int2i_f1); Call memminus(KIND(int2i_f1), SIZE(int2i_f1), 1) + if (allocated(int2r_f2)) deallocate (int2r_f2); Call memminus(KIND(int2r_f2), SIZE(int2r_f2), 1) + if (allocated(int2i_f2)) deallocate (int2i_f2); Call memminus(KIND(int2i_f2), SIZE(int2i_f2), 1) + if (rank == 0) then + print '("Current Memory is ",F10.2,"MB")', tmem/1024/1024 Call timing(val(3), totalsec, date0, tsec0) - write (*, *) 'End r4dcasci_ty part' + print *, 'End r4dcasci_ty part' end if #ifdef HAVE_MPI call MPI_FINALIZE(ierr) diff --git a/src/r4dcaspt2_tra_co.f90 b/src/r4dcaspt2_tra_co.f90 index e8f61aae..e8f411e1 100644 --- a/src/r4dcaspt2_tra_co.f90 +++ b/src/r4dcaspt2_tra_co.f90 @@ -11,12 +11,12 @@ PROGRAM r4dcaspt2_tra_co ! DO CASPT2 CALC WITH MO TRANSFORMATION Implicit NONE #ifdef HAVE_MPI include 'mpif.h' + real(16) :: time0, time1 #endif integer :: ieshift real*8 :: e0, e2, e2all, weight0 complex*16, allocatable :: ci(:) real*8, allocatable :: ecas(:) - real(16) :: time0, time1 character*50 :: filename integer :: idetr_array_len ! length of array = idetr(1:2**nact - 1) @@ -40,25 +40,25 @@ PROGRAM r4dcaspt2_tra_co ! DO CASPT2 CALC WITH MO TRANSFORMATION #else rank = 0; nprocs = 1 #endif - if (rank == 0) then ! Process limits for output - write (*, *) '' - write (*, *) ' ENTER R4DCASPT2_TRA_TY PROGRAM written by M. Abe 2007.7.23' - write (*, *) '' + if (rank == 0) then + print *, '' + print *, ' ENTER R4DCASPT2_TRA_TY PROGRAM written by M. Abe 2007.7.23' + print *, '' end if tmem = 0.0d+00 val = 0 Call DATE_AND_TIME(VALUES=val) - if (rank == 0) then ! Process limits for output - Write (*, *) 'Year = ', val(1), 'Mon = ', val(2), 'Date = ', val(3) - Write (*, *) 'Hour = ', val(5), 'Min = ', val(6), 'Sec = ', val(7), '.', val(8) + if (rank == 0) then + print *, 'Year = ', val(1), 'Mon = ', val(2), 'Date = ', val(3) + print *, 'Hour = ', val(5), 'Min = ', val(6), 'Sec = ', val(7), '.', val(8) end if totalsec = val(8)*(1.0d-03) + val(7) + val(6)*(6.0d+01) + val(5)*(6.0d+01)**2 initdate = val(3) inittime = totalsec - if (rank == 0) then ! Process limits for output - write (*, *) inittime + if (rank == 0) then + print *, inittime Call timing(val(3), totalsec, date0, tsec) end if @@ -66,19 +66,19 @@ PROGRAM r4dcaspt2_tra_co ! DO CASPT2 CALC WITH MO TRANSFORMATION ieshift = 0 call read_input - if (rank == 0) then ! Process limits for output - 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 (*, *) 'ptgrp =', ptgrp - write (*, *) 'dirac_version =', dirac_version + if (rank == 0) then + print *, 'ninact =', ninact + print *, 'nact =', nact + print *, 'nsec =', nsec + print *, 'nelec =', nelec + print *, 'nroot =', nroot + print *, 'selectroot =', selectroot + print *, 'totsym =', totsym + print *, 'ncore =', ncore + print *, 'nbas =', nbas + print *, 'eshift =', eshift + print *, 'ptgrp =', ptgrp + print *, 'dirac_version =', dirac_version if (is_ras1_configured) print *, "RAS1 =", ras1_list if (is_ras2_configured) print *, "RAS2 =", ras2_list if (is_ras3_configured) print *, "RAS3 =", ras3_list @@ -91,18 +91,16 @@ PROGRAM r4dcaspt2_tra_co ! DO CASPT2 CALC WITH MO TRANSFORMATION evenelec = .false. End if -! write(*,*)' ENTER READ r4dmoint1' - if (rank == 0) then ! Process limits for output - write (*, *) ' ENTER READ MRCONEE' - end if +! print *,' ENTER READ r4dmoint1' + if (rank == 0) print *, ' ENTER READ MRCONEE' filename = 'MRCONEE' call readorb_enesym_co(filename) call read1mo_co(filename) - if (rank == 0) then ! Process limits for output - write (*, *) ' EXIT READ MRCONEE' - write (*, *) ' ENTER READ MDCINT' + if (rank == 0) then + print *, ' EXIT READ MRCONEE' + print *, ' ENTER READ MDCINT' end if ! Get MDCINTNEWX's filename and subspace filename @@ -111,15 +109,11 @@ PROGRAM r4dcaspt2_tra_co ! DO CASPT2 CALC WITH MO TRANSFORMATION Call readint2_ord_co(mdcintnew) - if (rank == 0) then ! Process limits for output - write (*, '("Current Memory is ",F10.2,"MB")') tmem/1024/1024 - end if + if (rank == 0) print '("Current Memory is ",F10.2,"MB")', tmem/1024/1024 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! nmo = ninact + nact + nsec - if (rank == 0) then ! Process limits for output - write (*, *) 'nmo =', nmo - end if + if (rank == 0) print *, 'nmo =', nmo open (10, file='CIMAT', form='unformatted', status='old') @@ -143,9 +137,7 @@ PROGRAM r4dcaspt2_tra_co ! DO CASPT2 CALC WITH MO TRANSFORMATION !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - if (rank == 0) then ! Process limits for output - write (*, *) ' ENTER READ NEWCICOEFF', ndet - end if + if (rank == 0) print *, ' ENTER READ NEWCICOEFF', ndet Allocate (ci(1:ndet)) ci = 0.0d+00 @@ -164,9 +156,7 @@ PROGRAM r4dcaspt2_tra_co ! DO CASPT2 CALC WITH MO TRANSFORMATION deallocate (ci) - if (rank == 0) then ! Process limits for output - write (*, *) ' EXIT READ NEWCICOEFF' - end if + if (rank == 0) print *, ' EXIT READ NEWCICOEFF' !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -191,30 +181,30 @@ PROGRAM r4dcaspt2_tra_co ! DO CASPT2 CALC WITH MO TRANSFORMATION !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - if (rank == 0) then ! Process limits for output - write (*, *) ' ' - write (*, *) '*******************************' - write (*, *) ' ' - write (*, *) 'IREP IS ', repna(totsym) - write (*, *) ' ' - write (*, *) '*******************************' - write (*, *) ' ' + if (rank == 0) then + print *, ' ' + print *, '*******************************' + print *, ' ' + print *, 'IREP IS ', repna(totsym) + print *, ' ' + print *, '*******************************' + print *, ' ' end if realcvec = .TRUE. ! This is test for bug fix about realc part - if (rank == 0) then ! Process limits for output - write (*, *) realc, 'realc' - write (*, *) realcvec, 'realcvec' + if (rank == 0) then + print *, realc, 'realc' + print *, realcvec, 'realcvec' end if realc = .FALSE. !!! realc =.TRUE. realcvec = .FALSE. !!! realcvec =.TRUE. - if (rank == 0) then ! Process limits for output - write (*, *) 'FOR TEST WE DO (F,F)' - write (*, *) realc, 'realc' - write (*, *) realcvec, 'realcvec' + if (rank == 0) then + print *, 'FOR TEST WE DO (F,F)' + print *, realc, 'realc' + print *, realcvec, 'realcvec' end if !!=============================================! ! ! @@ -222,7 +212,7 @@ PROGRAM r4dcaspt2_tra_co ! DO CASPT2 CALC WITH MO TRANSFORMATION ! ! !!=============================================! -! write(*,*)'RECALCULATION OF CASCI ENERGY' +! print *,'RECALCULATION OF CASCI ENERGY' ! Call e0test_v2 e2 = 0.0d+00 @@ -238,45 +228,33 @@ PROGRAM r4dcaspt2_tra_co ! DO CASPT2 CALC WITH MO TRANSFORMATION ! date1 = date0 ! tsec1 = tsec0 - if (rank == 0) then ! Proces limits for output - write (*, *) 'A1int filename : ', trim(a1int), ' rank', rank - end if + if (rank == 0) print *, 'A1int filename : ', trim(a1int), ' rank', rank ! Call intra_3(2, 1, 2, 2, 'A1int') Call intra_3(2, 1, 2, 2, a1int) - if (rank == 0) then ! Process limits for output - write (*, *) 'End intra3 A1int' - end if + if (rank == 0) print *, 'End intra3 A1int' date1 = date0 tsec1 = tsec0 Call timing(date1, tsec1, date0, tsec0) Call intra_3(2, 1, 1, 1, a2int) - if (rank == 0) then ! Process limits for output - write (*, *) 'End intra_3 A2int' - end if + if (rank == 0) print *, 'End intra_3 A2int' date1 = date0 tsec1 = tsec0 Call timing(date1, tsec1, date0, tsec0) sumc2local = 0.0d+00 - if (rank == 0) then ! Process limits for output - write (*, *) 'Enter solvA' - end if + if (rank == 0) print *, 'Enter solvA' Call solvA_ord_ty(e0, e2) e2all = e2all + e2 - if (rank == 0) then ! Process limits for output - write (*, *) e2all - end if + if (rank == 0) print *, e2all date1 = date0 tsec1 = tsec0 Call timing(date1, tsec1, date0, tsec0) Call intra_2(2, 1, 2, 1, bint) - if (rank == 0) then ! Process limits for output - write (*, *) 'End intra_2 Bint' - end if + if (rank == 0) print *, 'End intra_2 Bint' date1 = date0 tsec1 = tsec0 Call timing(date1, tsec1, date0, tsec0) @@ -284,34 +262,26 @@ PROGRAM r4dcaspt2_tra_co ! DO CASPT2 CALC WITH MO TRANSFORMATION sumc2local = 0.0d+00 Call solvB_ord_ty(e0, e2) e2all = e2all + e2 - if (rank == 0) then ! Process limits for output - write (*, *) e2all - end if + if (rank == 0) print *, e2all date1 = date0 tsec1 = tsec0 Call timing(date1, tsec1, date0, tsec0) Call intra_3(3, 2, 2, 2, c1int) - if (rank == 0) then ! Process limits for output - write (*, *) 'End intra_3 C1int' - end if + if (rank == 0) print *, 'End intra_3 C1int' date1 = date0 tsec1 = tsec0 Call timing(date1, tsec1, date0, tsec0) Call intra_3(3, 2, 1, 1, c2int) - if (rank == 0) then ! Process limits for output - write (*, *) 'End intra_3 C2int' - end if + if (rank == 0) print *, 'End intra_3 C2int' date1 = date0 tsec1 = tsec0 Call timing(date1, tsec1, date0, tsec0) Call intra_1(3, 1, 1, 2, c3int) - if (rank == 0) then ! Process limits for output - write (*, *) 'End intra_1 C3int' - end if + if (rank == 0) print *, 'End intra_1 C3int' date1 = date0 tsec1 = tsec0 Call timing(date1, tsec1, date0, tsec0) @@ -325,25 +295,19 @@ PROGRAM r4dcaspt2_tra_co ! DO CASPT2 CALC WITH MO TRANSFORMATION Call timing(date1, tsec1, date0, tsec0) Call intra_3(3, 1, 2, 2, d1int) - if (rank == 0) then ! Process limits for output - write (*, *) 'End intra_1 D1int' - end if + if (rank == 0) print *, 'End intra_1 D1int' date1 = date0 tsec1 = tsec0 Call timing(date1, tsec1, date0, tsec0) Call intra_1(3, 2, 2, 1, d2int) - if (rank == 0) then ! Process limits for output - write (*, *) 'End intra_1 D2int' - end if + if (rank == 0) print *, 'End intra_1 D2int' date1 = date0 tsec1 = tsec0 Call timing(date1, tsec1, date0, tsec0) Call intra_3(3, 1, 1, 1, d3int) - if (rank == 0) then ! Process limits for output - write (*, *) 'End intra_1 D3int' - end if + if (rank == 0) print *, 'End intra_1 D3int' date1 = date0 tsec1 = tsec0 Call timing(date1, tsec1, date0, tsec0) @@ -351,18 +315,14 @@ PROGRAM r4dcaspt2_tra_co ! DO CASPT2 CALC WITH MO TRANSFORMATION sumc2local = 0.0d+00 Call solvD_ord_ty(e0, e2) e2all = e2all + e2 - if (rank == 0) then ! Process limits for output - write (*, *) e2all - end if + if (rank == 0) print *, e2all date1 = date0 tsec1 = tsec0 Call timing(date1, tsec1, date0, tsec0) Call intra_1(3, 1, 2, 1, eint) - if (rank == 0) then ! Process limits for output - write (*, *) 'End intra_1 Eint' - end if + if (rank == 0) print *, 'End intra_1 Eint' date1 = date0 tsec1 = tsec0 Call timing(date1, tsec1, date0, tsec0) @@ -370,18 +330,14 @@ PROGRAM r4dcaspt2_tra_co ! DO CASPT2 CALC WITH MO TRANSFORMATION sumc2local = 0.0d+00 Call solvE_ord_ty(e0, e2) e2all = e2all + e2 - if (rank == 0) then ! Process limits for output - write (*, *) e2all - end if + if (rank == 0) print *, e2all date1 = date0 tsec1 = tsec0 Call timing(date1, tsec1, date0, tsec0) Call intra_2(3, 2, 3, 2, fint) - if (rank == 0) then ! Process limits for output - write (*, *) 'End intra_1 Fint' - end if + if (rank == 0) print *, 'End intra_1 Fint' date1 = date0 tsec1 = tsec0 Call timing(date1, tsec1, date0, tsec0) @@ -389,18 +345,14 @@ PROGRAM r4dcaspt2_tra_co ! DO CASPT2 CALC WITH MO TRANSFORMATION sumc2local = 0.0d+00 Call solvF_ord_ty(e0, e2) e2all = e2all + e2 - if (rank == 0) then ! Process limits for output - write (*, *) e2all - end if + if (rank == 0) print *, e2all date1 = date0 tsec1 = tsec0 Call timing(date1, tsec1, date0, tsec0) Call intra_1(3, 1, 3, 2, gint) - if (rank == 0) then ! Process limits for output - write (*, *) 'End intra_1 Gint' - end if + if (rank == 0) print *, 'End intra_1 Gint' date1 = date0 tsec1 = tsec0 Call timing(date1, tsec1, date0, tsec0) @@ -408,46 +360,36 @@ PROGRAM r4dcaspt2_tra_co ! DO CASPT2 CALC WITH MO TRANSFORMATION sumc2local = 0.0d+00 Call solvG_ord_ty(e0, e2) e2all = e2all + e2 - if (rank == 0) then ! Process limits for output - write (*, *) e2all - end if + if (rank == 0) print *, e2all date1 = date0 tsec1 = tsec0 Call timing(date1, tsec1, date0, tsec0) Call intra_2(3, 1, 3, 1, hint) - if (rank == 0) then ! Process limits for output - write (*, *) 'End intra_1 Hint' - end if + if (rank == 0) print *, 'End intra_1 Hint' date1 = date0 tsec1 = tsec0 Call timing(date1, tsec1, date0, tsec0) sumc2local = 0.0d+00 - if (rank == 0) then ! Process limits for output - write (*, *) 'enter solveH_ord_ty' - end if + if (rank == 0) print *, 'enter solveH_ord_ty' + Call solvH_ord_ty(e0, e2) e2all = e2all + e2 - if (rank == 0) then ! Process limits for output - write (*, *) e2all - end if + if (rank == 0) print *, e2all date1 = date0 tsec1 = tsec0 Call timing(date1, tsec1, date0, tsec0) - if (rank == 0) then ! Process limits for output - write (*, '("c^2 ",F30.15)') sumc2 - end if + if (rank == 0) print '("c^2 ",F30.15)', sumc2 weight0 = 1.0d+00/(1.0d+00 + sumc2) - if (rank == 0) then ! Process limits for output - write (*, '("weight of 0th wave function is",F30.15)') weight0 + if (rank == 0) then + print '("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 + print '("Total second order energy is ",F30.15," a.u.")', e2all - eshift*sumc2 + print '("Total energy is ",F30.15," a.u.")', e2all + eigen(iroot) - eshift*sumc2 end if if (allocated(cir)) deallocate (cir); Call memminus(KIND(cir), SIZE(cir), 1) if (allocated(cii)) deallocate (cii); Call memminus(KIND(cii), SIZE(cii), 1) @@ -463,13 +405,11 @@ PROGRAM r4dcaspt2_tra_co ! DO CASPT2 CALC WITH MO TRANSFORMATION if (allocated(MULTB_SB)) deallocate (MULTB_SB); Call memminus(KIND(MULTB_SB), SIZE(MULTB_SB), 1) Call timing(val(3), totalsec, date0, tsec0) - if (rank == 0) then ! Process limits for output - write (*, *) 'End r4dcaspt2_tra_ty' - end if + if (rank == 0) print *, 'End r4dcaspt2_tra_ty' #ifdef HAVE_MPI call MPI_Barrier(MPI_COMM_WORLD, ierr) time1 = MPI_Wtime() - if (rank == 0) then ! Process limits for output + if (rank == 0) then write (*, "(a,e16.6)") "MPI_Wtime :", time1 - time0 end if call MPI_FINALIZE(ierr) diff --git a/src/ras_det_check.f90 b/src/ras_det_check.f90 new file mode 100644 index 00000000..5f07dd53 --- /dev/null +++ b/src/ras_det_check.f90 @@ -0,0 +1,59 @@ +module ras_det_check + use four_caspt2_module, only: rank, ras1_list, ras2_list + implicit none + private + public ras1_det_check, ras3_det_check +contains + function ras1_det_check(i, upper_allowed_hole) result(is_det_allowed) + ! function ras1_det_check(i,upper_allowed_hole) result(is_det_allowed) + ! This function returns true if the determinant (i) is allowed + use four_caspt2_module, only: ras1_size, min_hole_ras1 + integer, intent(in) :: i, upper_allowed_hole + integer :: num_of_electron, ras1_bit + logical :: is_det_allowed + ras1_bit = 2**ras1_size - 1 + call conunt_num_of_elec(i, ras1_bit, num_of_electron) + is_det_allowed = ras1_size - upper_allowed_hole <= num_of_electron .and. num_of_electron <= ras1_size - min_hole_ras1 + end function ras1_det_check + function ras3_det_check(i, upper_allowed_electron) result(is_det_allowed) + ! function ras3_det_check(i,upper_allowed_electron) result(is_det_allowed) + ! This function returns true if the determinant (i) is allowed + use four_caspt2_module, only: is_ras1_configured, is_ras2_configured, ras1_size, ras2_size + integer, intent(in) :: i, upper_allowed_electron + integer :: num_of_electron, ras3_bit, width_of_shift + logical :: is_det_allowed + ras3_bit = i + width_of_shift = 0 + if (is_ras1_configured) then + ras3_bit = ishft(ras3_bit, -ras1_size) + width_of_shift = width_of_shift + ras1_size + end if + if (is_ras2_configured) then + ras3_bit = ishft(ras3_bit, -ras2_size) + width_of_shift = width_of_shift + ras2_size + end if + ras3_bit = ishft(ras3_bit, width_of_shift) + call conunt_num_of_elec(i, ras3_bit, num_of_electron) + ! print *, 'res', i, num_of_electron + is_det_allowed = num_of_electron <= upper_allowed_electron + end function ras3_det_check + + subroutine conunt_num_of_elec(i, bit, num_of_electron) + implicit none + integer, intent(in) :: i, bit + integer, intent(out) :: num_of_electron + num_of_electron = ras_bit_calculate(i, bit) + + end subroutine conunt_num_of_elec + + function ras_bit_calculate(determinant, bit) result(num_of_electron) + implicit none + integer, intent(in) :: determinant, bit + integer :: num_of_electron, multiply + + ! ras_bitとdeterminantとのbit論理積 + multiply = iand(bit, determinant) + num_of_electron = popcnt(multiply) + + end function ras_bit_calculate +end module ras_det_check diff --git a/src/read1mo_co.f90 b/src/read1mo_co.f90 index 4e9f48b5..792e71a1 100644 --- a/src/read1mo_co.f90 +++ b/src/read1mo_co.f90 @@ -8,13 +8,13 @@ SUBROUTINE read1mo_co(filename) ! one-electron MO integrals in moint1 Implicit NONE - integer :: mrconee, isp, nmom + integer :: mrconee, isp, nmom, iostat character*50, intent(in) :: filename integer :: j0, i0 double precision, allocatable :: roner(:, :, :), ronei(:, :, :) if (rank == 0) then - write (*, *) 'Enter read1mo_co' + print *, 'Enter read1mo_co' end if mrconee = 10 @@ -23,19 +23,39 @@ 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', err=10) + 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 + 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, isp), ronei(i0, j0, isp), j0=1, nmo), i0=1, nmo), isp=1, scfru) + read (mrconee, iostat=iostat) + read (mrconee, iostat=iostat) + read (mrconee, iostat=iostat) + read (mrconee, iostat=iostat) + 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 ! Reverse the sign of ronei if DIRAC version is larger or equal to 21. -if (dirac_version >= 21) then - ronei(:, :, :) = -ronei(:, :, :) -end if + if (dirac_version >= 21) then + ronei(:, :, :) = -ronei(:, :, :) + end if + close (mrconee) nmom = ninact + nact + nsec @@ -57,17 +77,6 @@ SUBROUTINE read1mo_co(filename) ! one-electron MO integrals in moint1 deallocate (ronei); Call memminus(KIND(ronei), SIZE(ronei), 1) if (rank == 0) then - write (*, *) realc, 'realc' + print *, realc, 'realc' end if - goto 1000 - -10 if (rank == 0) then - write (*, *) 'err 10 mo1' - end if - go to 1000 - if (rank == 0) then - write (*, *) 'err 11 mo1' - end if - go to 1000 - -1000 end subroutine read1mo_co +end subroutine read1mo_co diff --git a/src/read_input_module.f90 b/src/read_input_module.f90 index 5e28bac4..feecc244 100644 --- a/src/read_input_module.f90 +++ b/src/read_input_module.f90 @@ -181,7 +181,7 @@ subroutine ras_read(ras_list, ras_num) 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 + 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 @@ -212,6 +212,38 @@ subroutine ras_read(ras_list, ras_num) 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) + + !=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=! + ! Check the specification of input is kramers pair? + !=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=!=! + + ! 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 + end if + + ! ras_list(idx) (idx : odd) must be odd number and equal to ras_list(idx+1) (idx : even) + do idx = 1, size(ras_list, 1), 2 + ! Check the ras_list(idx) (idx : odd) is odd number? + if (mod(ras_list(idx), 2) /= 1) then + if (rank == 0) then + 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 + 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 + end if + end do + + return ! END SUBROUTINE NORMALLY + +10 if (rank == 0) print *, "ERROR: Error in input, can't read ras"//ras_chr//" value!!. Stop the program." + stop end subroutine ras_read subroutine parse_input_string_to_int_list(string, list, filled_num, allow_int_min, allow_int_max) @@ -499,10 +531,9 @@ 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 + return ! Read the numbers properly 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 end subroutine parse_range_input_int subroutine is_substring(substring, string, is_substring_bool) @@ -616,8 +647,10 @@ subroutine read_an_integer(allowed_min_int, allowed_max_int, result_int) exit ! EXIT LOOP end do return ! END SUBROUTINE -10 if (rank == 0) print *, "ERROR: Error in input, can't read a integer value!!. Stop the program." - if (rank == 0) print *, "input: ", input +10 if (rank == 0) then + print *, "ERROR: Error in input, can't read a integer value!!. Stop the program." + print *, "input: ", input + end if stop end subroutine read_an_integer @@ -655,6 +688,8 @@ subroutine is_comment_line(string, is_comment) ! (e.g.) " 2,3,4" => "2,3,4" !=!=!=!=!=!=!=!=!=!=!=!=!=!=!=! string = trim(adjustl(string)) + + ! Find the index of comment character (comment_idx = 0 if the comment character is not found) comment_idx = scan(string, '!#') if (verify(string, " ") == 0) then ! Empty line diff --git a/src/readint2_casci_co.f90 b/src/readint2_casci_co.f90 index 51dc9967..a0538cf8 100644 --- a/src/readint2_casci_co.f90 +++ b/src/readint2_casci_co.f90 @@ -24,16 +24,14 @@ SUBROUTINE readint2_casci_co(filename, nuniq) ! 2 electorn integrals created by integer, allocatable :: indk(:, :), indl(:, :), kr(:) real*8, allocatable :: rklr(:, :), rkli(:, :) logical :: continue_read - integer :: idx, read_line_len + integer :: idx, read_line_len, iostat read_line_len = read_line_max ! Set read_line_len as parameter "read_line_max" ! Iwamuro modify realonly = .false. continue_read = .true. nmoc = ninact + nact nmom = ninact + nact + nsec - if (rank == 0) then ! Process limits for output - write (*, *) "Enter readint2_casci_co" - end if + if (rank == 0) print *, "Enter readint2_casci_co" Allocate (i(read_line_max)); call memplus(kind(i), size(i), 1) Allocate (j(read_line_max)); call memplus(kind(j), size(j), 1) @@ -55,9 +53,7 @@ SUBROUTINE readint2_casci_co(filename, nuniq) ! 2 electorn integrals created by !Iwamuro modify Allocate (kr(-nmo/2:nmo/2)); Call memplus(KIND(kr), SIZE(kr), 1) - if (rank == 0) then ! Process limits for output - write (*, '("Current Memory is ",F10.2,"MB")') tmem/1024/1024 - end if + if (rank == 0) print '("Current Memory is ",F10.2,"MB")', tmem/1024/1024 ! Initialize variables nuniq = 0 @@ -78,308 +74,310 @@ SUBROUTINE readint2_casci_co(filename, nuniq) ! 2 electorn integrals created by mdcint = 11 open (mdcint, file=trim(filename), form='unformatted', status='old') - read (mdcint, err=20, end=30) datex, timex, nkr, & + read (mdcint, iostat=iostat) datex, timex, nkr, & (kr(i0), kr(-1*i0), i0=1, nkr) - if (rank == 0) then ! Process limits for output - write (*, *) datex, timex - write (*, *) 'readint2', 'nkr', nkr, 'kr(+),kr(-)', (kr(i0), kr(-1*i0), i0=1, nkr) + ! File status check + if (iostat < 0) then + ! End of file + 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 -60 do idx = 1, read_line_len - read (mdcint, err=20, END=81) i(idx), j(idx), nz(idx), & - (indk(idx, inz), indl(idx, inz), rklr(idx, inz), rkli(idx, inz), inz=1, nz(idx)) - end do - goto 82 ! Skip 81 (Skip end read MDCINTNEW) -81 continue_read = .false. ! End read MDCINTNEW - read_line_len = idx -82 continue - !$OMP parallel do private(idx,itr,jtr,i0,itr0,j0,jtr0,inz,k,ktr,l,ltr,SIGNIJ,SIGNKL,cint2,save,count) & - !$OMP & reduction(+:totalint,nuniq) - do idx = 1, read_line_len - if (i(idx) == 0) cycle ! Go to next idx - - totalint = totalint + nz(idx) - - itr = i(idx) + (-1)**(mod(i(idx), 2) + 1) - jtr = j(idx) + (-1)**(mod(j(idx), 2) + 1) - - i0 = i(idx) - itr0 = itr - j0 = j(idx) - jtr0 = jtr - - Do inz = 1, nz(idx) - - i(idx) = i0 - itr = itr0 - j(idx) = j0 - jtr = jtr0 - - k = indk(idx, inz) - ktr = k + (-1)**(mod(k, 2) + 1) - l = indl(idx, inz) - ltr = l + (-1)**(mod(l, 2) + 1) - - If (i(idx) > nmoc .and. j(idx) > nmoc .and. k > nmoc .and. l > nmoc) goto 70 ! (33|33) is ignored - If (i(idx) == j(idx) .and. k > l) goto 70 - - If (i(idx) <= nmoc .and. j(idx) <= nmoc .and. k <= nmoc .and. l <= nmoc) then - SignIJ = (-1)**(mod(i(idx), 2) + mod(j(idx), 2)) - SignKL = (-1)**(mod(k, 2) + mod(l, 2)) - nuniq = nuniq + 1 - !=-> Original integral plus time-reversed partners - INTTWR(I(idx), J(idx), K, L) = rklr(idx, inz) - INTTWR(JTR, ITR, K, L) = rklr(idx, inz)*SignIJ - INTTWR(I(idx), J(idx), LTR, KTR) = rklr(idx, inz)*SignKL - INTTWR(JTR, ITR, LTR, KTR) = rklr(idx, inz)*SignIJ*SignKL - INTTWI(I(idx), J(idx), K, L) = rkli(idx, inz) - INTTWI(JTR, ITR, K, L) = rkli(idx, inz)*SignIJ - INTTWI(I(idx), J(idx), LTR, KTR) = rkli(idx, inz)*SignKL - INTTWI(JTR, ITR, LTR, KTR) = rkli(idx, inz)*SignIJ*SignKL - !=-> Complex conjugate plus time-reversed partners - INTTWR(J(idx), I(idx), L, K) = rklr(idx, inz) - INTTWR(ITR, JTR, L, K) = rklr(idx, inz)*SignIJ - INTTWR(J(idx), I(idx), KTR, LTR) = rklr(idx, inz)*SignKL - INTTWR(ITR, JTR, KTR, LTR) = rklr(idx, inz)*SignIJ*SignKL - INTTWI(J(idx), I(idx), L, K) = -rkli(idx, inz) - INTTWI(ITR, JTR, L, K) = -rkli(idx, inz)*SignIJ - INTTWI(J(idx), I(idx), KTR, LTR) = -rkli(idx, inz)*SignKL - INTTWI(ITR, JTR, KTR, LTR) = -rkli(idx, inz)*SignIJ*SignKL - !=-> Particle interchanged plus time-reversed partners - INTTWR(K, L, I(idx), J(idx)) = rklr(idx, inz) - INTTWR(LTR, KTR, I(idx), J(idx)) = rklr(idx, inz)*SignKL - INTTWR(K, L, JTR, ITR) = rklr(idx, inz)*SignIJ - INTTWR(LTR, KTR, JTR, ITR) = rklr(idx, inz)*SignIJ*SignKL - INTTWI(K, L, I(idx), J(idx)) = rkli(idx, inz) - INTTWI(LTR, KTR, I(idx), J(idx)) = rkli(idx, inz)*SignKL - INTTWI(K, L, JTR, ITR) = rkli(idx, inz)*SignIJ - INTTWI(LTR, KTR, JTR, ITR) = rkli(idx, inz)*SignIJ*SignKL - !=-> Particle interchanged and complex conjugated plus time-reversed partners - INTTWR(L, K, J(idx), I(idx)) = rklr(idx, inz) - INTTWR(KTR, LTR, J(idx), I(idx)) = rklr(idx, inz)*SignKL - INTTWR(L, K, ITR, JTR) = rklr(idx, inz)*SignIJ - INTTWR(KTR, LTR, ITR, JTR) = rklr(idx, inz)*SignIJ*SignKL - INTTWI(L, K, J(idx), I(idx)) = -rkli(idx, inz) - INTTWI(KTR, LTR, J(idx), I(idx)) = -rkli(idx, inz)*SignKL - INTTWI(L, K, ITR, JTR) = -rkli(idx, inz)*SignIJ - INTTWI(KTR, LTR, ITR, JTR) = -rkli(idx, inz)*SignIJ*SignKL - if (abs(rkli(idx, inz)) > thres) realc = .false. - - elseif (sp(i(idx)) == 3 .and. sp(j(idx)) == 3 .and. sp(k) < 3 .and. sp(l) == sp(k)) then !(33|11) or (33|22) type - count = 0 - -11 if (mod(i(idx), 2) == 0) then - itr = i(idx) - 1 - else - itr = i(idx) + 1 - end if - - if (mod(j(idx), 2) == 0) then - jtr = j(idx) - 1 - else - jtr = j(idx) + 1 - end if - - if (mod(k, 2) == 0) then - ktr = k - 1 - else - ktr = k + 1 - end if - - if (mod(l, 2) == 0) then - ltr = l - 1 - else - ltr = l + 1 - end if - - SignIJ = (-1.0d+00)**mod(i(idx) + j(idx), 2) - SignKL = (-1.0d+00)**mod(k + l, 2) - ! write(*,*)'sign',signIJ,signKL - - int2r_f1(i(idx), j(idx), k, l) = rklr(idx, inz) - int2i_f1(i(idx), j(idx), k, l) = rkli(idx, inz) - - int2r_f1(jtr, itr, k, l) = SignIJ*rklr(idx, inz) - int2i_f1(jtr, itr, k, l) = SignIJ*rkli(idx, inz) - - int2r_f1(i(idx), j(idx), ltr, ktr) = SignKL*rklr(idx, inz) - int2i_f1(i(idx), j(idx), ltr, ktr) = SignKL*rkli(idx, inz) - - int2r_f1(jtr, itr, ltr, ktr) = SignIJ*SignKL*rklr(idx, inz) - int2i_f1(jtr, itr, ltr, ktr) = SignIJ*SignKL*rkli(idx, inz) - - count = count + 1 - cint2 = DCMPLX(rklr(idx, inz), rkli(idx, inz)) - - if (count == 1) then - Call takekr(i(idx), j(idx), k, l, cint2) ! Consider Kramers pair - rklr(idx, inz) = DBLE(cint2) - rkli(idx, inz) = DIMAG(cint2) - goto 11 - else - goto 70 ! Go to next inz - end if - - elseif (sp(k) == 3 .and. sp(l) == 3 .and. sp(i(idx)) < 3 .and. sp(i(idx)) == sp(j(idx))) then !(11|33) or (22|33) type - - count = 0 - -21 if (mod(i(idx), 2) == 0) then - itr = i(idx) - 1 - else - itr = i(idx) + 1 - end if - - if (mod(j(idx), 2) == 0) then - jtr = j(idx) - 1 - else - jtr = j(idx) + 1 - end if - - if (mod(k, 2) == 0) then - ktr = k - 1 - else - ktr = k + 1 - end if - - if (mod(l, 2) == 0) then - ltr = l - 1 - else - ltr = l + 1 - end if - - SignIJ = (-1.0d+00)**mod(i(idx) + j(idx), 2) - SignKL = (-1.0d+00)**mod(k + l, 2) - - int2r_f1(k, l, i(idx), j(idx)) = rklr(idx, inz) - int2i_f1(k, l, i(idx), j(idx)) = rkli(idx, inz) - - int2r_f1(k, l, jtr, itr) = SignIJ*rklr(idx, inz) - int2i_f1(k, l, jtr, itr) = SignIJ*rkli(idx, inz) - - int2r_f1(ltr, ktr, i(idx), j(idx)) = SignKL*rklr(idx, inz) - int2i_f1(ltr, ktr, i(idx), j(idx)) = SignKL*rkli(idx, inz) - - int2r_f1(ltr, ktr, jtr, itr) = SignIJ*SignKL*rklr(idx, inz) - int2i_f1(ltr, ktr, jtr, itr) = SignIJ*SignKL*rkli(idx, inz) - - count = count + 1 - cint2 = DCMPLX(rklr(idx, inz), rkli(idx, inz)) - if (count == 1) then - Call takekr(i(idx), j(idx), k, l, cint2) ! Consider Kramers pair - rklr(idx, inz) = DBLE(cint2) - rkli(idx, inz) = DIMAG(cint2) - goto 21 - else - goto 70 ! Go to next inz - end if - - elseif (max(sp(i(idx)), sp(j(idx))) == 3 .and. max(sp(k), sp(l)) == 3 .and. & - & min(sp(i(idx)), sp(j(idx))) == min(sp(k), sp(l))) then !(31|31) or (32|32) series - - count = 0 - -12 if (mod(i(idx), 2) == 0) then - itr = i(idx) - 1 - else - itr = i(idx) + 1 - end if - - if (mod(j(idx), 2) == 0) then - jtr = j(idx) - 1 - else - jtr = j(idx) + 1 - end if - - if (mod(k, 2) == 0) then - ktr = k - 1 - else - ktr = k + 1 - end if - - if (mod(l, 2) == 0) then - ltr = l - 1 - else - ltr = l + 1 - end if - - SignIJ = (-1.0d+00)**mod(i(idx) + j(idx), 2) - SignKL = (-1.0d+00)**mod(k + l, 2) - - if (i(idx) > j(idx) .and. k > l) then ! (31|31) or (32|32) ==> (31|13) or (32|23) - - int2r_f2(i(idx), j(idx), ltr, ktr) = signKL*rklr(idx, inz) - int2i_f2(i(idx), j(idx), ltr, ktr) = signKL*rkli(idx, inz) - - elseif (i(idx) > j(idx) .and. k < l) then ! (31|13) or (32|23) ==> (31|13) or (32|23) - - int2r_f2(i(idx), j(idx), k, l) = rklr(idx, inz) - int2i_f2(i(idx), j(idx), k, l) = rkli(idx, inz) - - elseif (i(idx) < j(idx) .and. k < l) then ! (13|13) or (23|23) ==> (31|13) or (32|23) - - int2r_f2(jtr, itr, k, l) = signIJ*rklr(idx, inz) - int2i_f2(jtr, itr, k, l) = signIJ*rkli(idx, inz) - - elseif (i(idx) < j(idx) .and. k > l) then ! (13|31) or (23|32) ==> (31|13) or (32|23) - - int2r_f2(jtr, itr, ltr, ktr) = signIJ*signKL*rklr(idx, inz) - int2i_f2(jtr, itr, ltr, ktr) = signIJ*signKL*rkli(idx, inz) - - end if - - count = count + 1 - cint2 = DCMPLX(rklr(idx, inz), rkli(idx, inz)) - if (count == 1 .or. count == 3) then - Call takekr(i(idx), j(idx), k, l, cint2) ! Consider Kramers pair - rklr(idx, inz) = DBLE(cint2) - rkli(idx, inz) = DIMAG(cint2) - goto 12 - elseif (count == 2) then ! variables exchange (AA|BB) => (BB|AA) - save = i(idx) - i(idx) = k - k = save - save = j(idx) - j(idx) = l - l = save - goto 12 + if (rank == 0) then + print *, datex, timex + print *, 'readint2', 'nkr', nkr, 'kr(+),kr(-)', (kr(i0), kr(-1*i0), i0=1, nkr) + end if + do while (continue_read) + 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 + 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 + end if + end do + + ! The length of read line is equal to min(read_line_max, idx) + read_line_len = min(read_line_max, idx) + + !$OMP parallel do private(idx,itr,jtr,i0,itr0,j0,jtr0,inz,k,ktr,l,ltr,SIGNIJ,SIGNKL,cint2,save,count) & + !$OMP & reduction(+:totalint,nuniq) + do idx = 1, read_line_len + if (i(idx) == 0) cycle ! Go to next idx + + totalint = totalint + nz(idx) + + itr = i(idx) + (-1)**(mod(i(idx), 2) + 1) + jtr = j(idx) + (-1)**(mod(j(idx), 2) + 1) + + i0 = i(idx) + itr0 = itr + j0 = j(idx) + jtr0 = jtr + + loop_inz: Do inz = 1, nz(idx) + + i(idx) = i0 + itr = itr0 + j(idx) = j0 + jtr = jtr0 + + k = indk(idx, inz) + ktr = k + (-1)**(mod(k, 2) + 1) + l = indl(idx, inz) + ltr = l + (-1)**(mod(l, 2) + 1) + + If (i(idx) > nmoc .and. j(idx) > nmoc .and. k > nmoc .and. l > nmoc) cycle loop_inz ! (33|33) is ignored + If (i(idx) == j(idx) .and. k > l) cycle loop_inz + + If (i(idx) <= nmoc .and. j(idx) <= nmoc .and. k <= nmoc .and. l <= nmoc) then + SignIJ = (-1)**(mod(i(idx), 2) + mod(j(idx), 2)) + SignKL = (-1)**(mod(k, 2) + mod(l, 2)) + nuniq = nuniq + 1 + !=-> Original integral plus time-reversed partners + INTTWR(I(idx), J(idx), K, L) = rklr(idx, inz) + INTTWR(JTR, ITR, K, L) = rklr(idx, inz)*SignIJ + INTTWR(I(idx), J(idx), LTR, KTR) = rklr(idx, inz)*SignKL + INTTWR(JTR, ITR, LTR, KTR) = rklr(idx, inz)*SignIJ*SignKL + INTTWI(I(idx), J(idx), K, L) = rkli(idx, inz) + INTTWI(JTR, ITR, K, L) = rkli(idx, inz)*SignIJ + INTTWI(I(idx), J(idx), LTR, KTR) = rkli(idx, inz)*SignKL + INTTWI(JTR, ITR, LTR, KTR) = rkli(idx, inz)*SignIJ*SignKL + !=-> Complex conjugate plus time-reversed partners + INTTWR(J(idx), I(idx), L, K) = rklr(idx, inz) + INTTWR(ITR, JTR, L, K) = rklr(idx, inz)*SignIJ + INTTWR(J(idx), I(idx), KTR, LTR) = rklr(idx, inz)*SignKL + INTTWR(ITR, JTR, KTR, LTR) = rklr(idx, inz)*SignIJ*SignKL + INTTWI(J(idx), I(idx), L, K) = -rkli(idx, inz) + INTTWI(ITR, JTR, L, K) = -rkli(idx, inz)*SignIJ + INTTWI(J(idx), I(idx), KTR, LTR) = -rkli(idx, inz)*SignKL + INTTWI(ITR, JTR, KTR, LTR) = -rkli(idx, inz)*SignIJ*SignKL + !=-> Particle interchanged plus time-reversed partners + INTTWR(K, L, I(idx), J(idx)) = rklr(idx, inz) + INTTWR(LTR, KTR, I(idx), J(idx)) = rklr(idx, inz)*SignKL + INTTWR(K, L, JTR, ITR) = rklr(idx, inz)*SignIJ + INTTWR(LTR, KTR, JTR, ITR) = rklr(idx, inz)*SignIJ*SignKL + INTTWI(K, L, I(idx), J(idx)) = rkli(idx, inz) + INTTWI(LTR, KTR, I(idx), J(idx)) = rkli(idx, inz)*SignKL + INTTWI(K, L, JTR, ITR) = rkli(idx, inz)*SignIJ + INTTWI(LTR, KTR, JTR, ITR) = rkli(idx, inz)*SignIJ*SignKL + !=-> Particle interchanged and complex conjugated plus time-reversed partners + INTTWR(L, K, J(idx), I(idx)) = rklr(idx, inz) + INTTWR(KTR, LTR, J(idx), I(idx)) = rklr(idx, inz)*SignKL + INTTWR(L, K, ITR, JTR) = rklr(idx, inz)*SignIJ + INTTWR(KTR, LTR, ITR, JTR) = rklr(idx, inz)*SignIJ*SignKL + INTTWI(L, K, J(idx), I(idx)) = -rkli(idx, inz) + INTTWI(KTR, LTR, J(idx), I(idx)) = -rkli(idx, inz)*SignKL + INTTWI(L, K, ITR, JTR) = -rkli(idx, inz)*SignIJ + INTTWI(KTR, LTR, ITR, JTR) = -rkli(idx, inz)*SignIJ*SignKL + if (abs(rkli(idx, inz)) > thres) realc = .false. + + elseif (sp(i(idx)) == 3 .and. sp(j(idx)) == 3 .and. sp(k) < 3 .and. sp(l) == sp(k)) then !(33|11) or (33|22) type + count = 0 + do + if (mod(i(idx), 2) == 0) then + itr = i(idx) - 1 + else + itr = i(idx) + 1 + end if + + if (mod(j(idx), 2) == 0) then + jtr = j(idx) - 1 + else + jtr = j(idx) + 1 + end if + + if (mod(k, 2) == 0) then + ktr = k - 1 + else + ktr = k + 1 + end if + + if (mod(l, 2) == 0) then + ltr = l - 1 + else + ltr = l + 1 + end if + + SignIJ = (-1.0d+00)**mod(i(idx) + j(idx), 2) + SignKL = (-1.0d+00)**mod(k + l, 2) + + int2r_f1(i(idx), j(idx), k, l) = rklr(idx, inz) + int2i_f1(i(idx), j(idx), k, l) = rkli(idx, inz) + + int2r_f1(jtr, itr, k, l) = SignIJ*rklr(idx, inz) + int2i_f1(jtr, itr, k, l) = SignIJ*rkli(idx, inz) + + int2r_f1(i(idx), j(idx), ltr, ktr) = SignKL*rklr(idx, inz) + int2i_f1(i(idx), j(idx), ltr, ktr) = SignKL*rkli(idx, inz) + + int2r_f1(jtr, itr, ltr, ktr) = SignIJ*SignKL*rklr(idx, inz) + int2i_f1(jtr, itr, ltr, ktr) = SignIJ*SignKL*rkli(idx, inz) + + count = count + 1 + cint2 = DCMPLX(rklr(idx, inz), rkli(idx, inz)) + + if (count == 1) then + Call takekr(i(idx), j(idx), k, l, cint2) ! Consider Kramers pair + rklr(idx, inz) = DBLE(cint2) + rkli(idx, inz) = DIMAG(cint2) + cycle ! Go to the next count loop + else + cycle loop_inz ! Go to the next inz + end if + end do + elseif (sp(k) == 3 .and. sp(l) == 3 .and. sp(i(idx)) < 3 .and. sp(i(idx)) == sp(j(idx))) then !(11|33) or (22|33) type + count = 0 + do + if (mod(i(idx), 2) == 0) then + itr = i(idx) - 1 + else + itr = i(idx) + 1 + end if + + if (mod(j(idx), 2) == 0) then + jtr = j(idx) - 1 + else + jtr = j(idx) + 1 + end if + + if (mod(k, 2) == 0) then + ktr = k - 1 + else + ktr = k + 1 + end if + + if (mod(l, 2) == 0) then + ltr = l - 1 + else + ltr = l + 1 + end if + + SignIJ = (-1.0d+00)**mod(i(idx) + j(idx), 2) + SignKL = (-1.0d+00)**mod(k + l, 2) + + int2r_f1(k, l, i(idx), j(idx)) = rklr(idx, inz) + int2i_f1(k, l, i(idx), j(idx)) = rkli(idx, inz) + + int2r_f1(k, l, jtr, itr) = SignIJ*rklr(idx, inz) + int2i_f1(k, l, jtr, itr) = SignIJ*rkli(idx, inz) + + int2r_f1(ltr, ktr, i(idx), j(idx)) = SignKL*rklr(idx, inz) + int2i_f1(ltr, ktr, i(idx), j(idx)) = SignKL*rkli(idx, inz) + + int2r_f1(ltr, ktr, jtr, itr) = SignIJ*SignKL*rklr(idx, inz) + int2i_f1(ltr, ktr, jtr, itr) = SignIJ*SignKL*rkli(idx, inz) + + count = count + 1 + cint2 = DCMPLX(rklr(idx, inz), rkli(idx, inz)) + if (count == 1) then + Call takekr(i(idx), j(idx), k, l, cint2) ! Consider Kramers pair + rklr(idx, inz) = DBLE(cint2) + rkli(idx, inz) = DIMAG(cint2) + cycle ! Go to the next count loop + else + cycle loop_inz ! Go to the next inz + end if + end do + + elseif (max(sp(i(idx)), sp(j(idx))) == 3 .and. max(sp(k), sp(l)) == 3 .and. & + & min(sp(i(idx)), sp(j(idx))) == min(sp(k), sp(l))) then !(31|31) or (32|32) series + + count = 0 + + do + if (mod(i(idx), 2) == 0) then + itr = i(idx) - 1 + else + itr = i(idx) + 1 + end if + + if (mod(j(idx), 2) == 0) then + jtr = j(idx) - 1 + else + jtr = j(idx) + 1 + end if + + if (mod(k, 2) == 0) then + ktr = k - 1 + else + ktr = k + 1 + end if + + if (mod(l, 2) == 0) then + ltr = l - 1 + else + ltr = l + 1 + end if + + SignIJ = (-1.0d+00)**mod(i(idx) + j(idx), 2) + SignKL = (-1.0d+00)**mod(k + l, 2) + + if (i(idx) > j(idx) .and. k > l) then ! (31|31) or (32|32) ==> (31|13) or (32|23) + + int2r_f2(i(idx), j(idx), ltr, ktr) = signKL*rklr(idx, inz) + int2i_f2(i(idx), j(idx), ltr, ktr) = signKL*rkli(idx, inz) + + elseif (i(idx) > j(idx) .and. k < l) then ! (31|13) or (32|23) ==> (31|13) or (32|23) + + int2r_f2(i(idx), j(idx), k, l) = rklr(idx, inz) + int2i_f2(i(idx), j(idx), k, l) = rkli(idx, inz) + + elseif (i(idx) < j(idx) .and. k < l) then ! (13|13) or (23|23) ==> (31|13) or (32|23) + + int2r_f2(jtr, itr, k, l) = signIJ*rklr(idx, inz) + int2i_f2(jtr, itr, k, l) = signIJ*rkli(idx, inz) + + elseif (i(idx) < j(idx) .and. k > l) then ! (13|31) or (23|32) ==> (31|13) or (32|23) + + int2r_f2(jtr, itr, ltr, ktr) = signIJ*signKL*rklr(idx, inz) + int2i_f2(jtr, itr, ltr, ktr) = signIJ*signKL*rkli(idx, inz) + + end if + + count = count + 1 + cint2 = DCMPLX(rklr(idx, inz), rkli(idx, inz)) + if (count == 1 .or. count == 3) then + Call takekr(i(idx), j(idx), k, l, cint2) ! Consider Kramers pair + rklr(idx, inz) = DBLE(cint2) + rkli(idx, inz) = DIMAG(cint2) + cycle ! Go to the next count loop + elseif (count == 2) then ! variables exchange (AA|BB) => (BB|AA) + save = i(idx) + i(idx) = k + k = save + save = j(idx) + j(idx) = l + l = save + cycle ! Go to the next count loop + else + cycle loop_inz ! Go to the next inz + end if + end do else - goto 70 ! Go to next inz end if - else - end if - -70 End do - end do - !$OMP end parallel do + End do loop_inz + end do + !$OMP end parallel do - if (continue_read) then ! Initialize i and continue to read i(:) = 0 - Goto 60 ! Continue to read MDCINTNEW - else - goto 50 ! Stop to read MDCINTNEW (read MDCINTNEW normally) - end if - if (rank == 0) then ! Process limits for output - write (*, *) 'error for opening mdcint 10' - end if - go to 100 -20 if (rank == 0) then ! Process limits for output - write (*, *) 'error for reading mdcint 20' - end if - go to 100 -30 if (rank == 0) then ! Process limits for output - write (*, *) 'end mdcint 30' - end if - go to 100 -50 if (rank == 0) then ! Process limits for output - write (*, *) 'end mdcint 50 normal' - end if - go to 100 -100 continue + end do + if (rank == 0) print *, 'end Read mdcint normal' close (mdcint) #ifdef HAVE_MPI @@ -392,17 +390,17 @@ SUBROUTINE readint2_casci_co(filename, nuniq) ! 2 electorn integrals created by end if #endif if (rank == 0) then - write (*, *) nuniq, totalint + print *, nuniq, totalint end if - 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) - deallocate (i); Call memminus(KIND(i), SIZE(i), 1) - deallocate (j); Call memminus(KIND(j), SIZE(j), 1) - deallocate (nz); call memminus(kind(nz), size(nz), 1) + if (allocated(indk)) deallocate (indk); Call memminus(KIND(indk), SIZE(indk), 1) + if (allocated(indl)) deallocate (indl); Call memminus(KIND(indl), SIZE(indl), 1) + if (allocated(rklr)) deallocate (rklr); Call memminus(KIND(rklr), SIZE(rklr), 1) + if (allocated(rkli)) deallocate (rkli); Call memminus(KIND(rkli), SIZE(rkli), 1) + if (allocated(kr)) deallocate (kr); Call memminus(KIND(kr), SIZE(kr), 1) + if (allocated(i)) deallocate (i); Call memminus(KIND(i), SIZE(i), 1) + if (allocated(j)) deallocate (j); Call memminus(KIND(j), SIZE(j), 1) + if (allocated(nz)) deallocate (nz); call memminus(kind(nz), size(nz), 1) #ifdef HAVE_MPI call MPI_Allreduce(MPI_IN_PLACE, inttwr(1, 1, 1, 1), nmoc**4, MPI_REAL8, MPI_SUM, MPI_COMM_WORLD, ierr) call MPI_Allreduce(MPI_IN_PLACE, inttwi(1, 1, 1, 1), nmoc**4, MPI_REAL8, MPI_SUM, MPI_COMM_WORLD, ierr) @@ -414,5 +412,6 @@ SUBROUTINE readint2_casci_co(filename, nuniq) ! 2 electorn integrals created by nsec*nmoc*nmoc*nsec, MPI_REAL8, MPI_SUM, MPI_COMM_WORLD, ierr) call MPI_Allreduce(MPI_IN_PLACE, int2i_f2(ninact + nact + 1, 1, 1, ninact + nact + 1), & nsec*nmoc*nmoc*nsec, MPI_REAL8, MPI_SUM, MPI_COMM_WORLD, ierr) + if (rank == 0) print *, 'End MPI_Allreduce inttwr, inttwi, int2r_f1, int2i_f1, int2r_f2, int2i_f2' #endif end subroutine readint2_casci_co diff --git a/src/readint2_ord_co.f90 b/src/readint2_ord_co.f90 index 5286a05a..21e1a82e 100644 --- a/src/readint2_ord_co.f90 +++ b/src/readint2_ord_co.f90 @@ -11,23 +11,19 @@ SUBROUTINE readint2_ord_co(filename) ! 2 electorn integrals created by typart in character :: datex*10, timex*8 - integer :: mdcint, nkr, idum, nmom, max1, max2, min1, min2 - integer :: nz, type - integer :: j0, i0, i1 - integer :: k0, l0, ii, jj, kk, ll, signind - integer :: i, j, k, l + integer :: mdcint, nkr, nmom, max1, max2, min1, min2 + integer :: nz + integer :: i0, i, j, k, l integer :: SignIJ, SignKL, itr, jtr, ltr, ktr, inz, totalint integer, allocatable :: indk(:), indl(:), kr(:) real*8, allocatable :: rklr(:), rkli(:) - logical :: breit - ! Unit numbers for subspace files integer :: unit_a1, unit_a2, unit_b, unit_c1, unit_c2, unit_c3, & unit_d1, unit_d2, unit_d3, unit_e, unit_f, unit_g, unit_h - integer :: ioerr + integer :: ioerr, iostat integer :: a1_cnt, a2_cnt, b_cnt, c1_cnt, c2_cnt, c3_cnt, d1_cnt, d2_cnt, d3_cnt, e_cnt, f_cnt, g_cnt, h_cnt !Iwamuro modify ! integer :: ikr, jkr, kkr, lkr @@ -45,9 +41,9 @@ SUBROUTINE readint2_ord_co(filename) ! 2 electorn integrals created by typart in 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) - if (rank == 0) then ! Process limits for output - write (*, *) "enter readint2_ord_co" - write (*, '("Current Memory is ",F10.2,"MB")') tmem/1024/1024 + if (rank == 0) then + print *, "enter readint2_ord_co" + print '("Current Memory is ",F10.2,"MB")', tmem/1024/1024 end if indk(:) = 0 indl(:) = 0 @@ -72,809 +68,830 @@ SUBROUTINE readint2_ord_co(filename) ! 2 electorn integrals created by typart in mdcint = 1500 - open (mdcint, file=trim(filename), form='unformatted', status='old', err=10) + 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, err=20, end=30) datex, timex, nkr, & + Read (mdcint, iostat=iostat) datex, timex, nkr, & (kr(i0), kr(-1*i0), i0=1, nkr) - if (rank == 0) then ! Process limits for output - write (*, *) datex, timex - write (*, *) 'nkr', nkr, 'kr(+),kr(-)', (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 end if -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 .and. j == 0 .and. nz == 0) goto 50 - totalint = totalint + nz + if (rank == 0) then + print *, datex, timex + print *, 'nkr', nkr, 'kr(+),kr(-)', (kr(i0), kr(-1*i0), i0=1, nkr) + end if + + ! 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) + 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 + + totalint = totalint + nz - itr = i + (-1)**(mod(i, 2) + 1) - jtr = j + (-1)**(mod(j, 2) + 1) + itr = i + (-1)**(mod(i, 2) + 1) + jtr = j + (-1)**(mod(j, 2) + 1) - nmom = ninact + nact + nsec + nmom = ninact + nact + nsec - If (sp(i) == 4 .or. sp(j) == 4) goto 60 - If (i > ninact + nact .and. j > ninact + nact) goto 60 + If (sp(i) == 4 .or. sp(j) == 4) cycle ! Read the next 2-integral + If (i > ninact + nact .and. j > ninact + nact) cycle ! Read the next 2-integral - SignIJ = (-1)**(mod(i + j, 2)) + SignIJ = (-1)**(mod(i + j, 2)) - Do inz = 1, nz + Do inz = 1, nz - k = indk(inz) - ktr = k + (-1)**(mod(k, 2) + 1) - l = indl(inz) - ltr = l + (-1)**(mod(l, 2) + 1) + k = indk(inz) + ktr = k + (-1)**(mod(k, 2) + 1) + l = indl(inz) + ltr = l + (-1)**(mod(l, 2) + 1) - 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 (sp(k) == 4 .or. sp(l) == 4) cycle ! Go to the next idz + If (k > ninact + nact .and. l > ninact + nact) cycle ! Go to the next idz + If (i == j .and. k > l) cycle ! Go to the next idz - SignKL = (-1)**(mod(k + l, 2)) + 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)) + 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) + If (max1 == 2 .and. min1 == 2 .and. max2 == 2 .and. min2 == 1) then ! (22|21) => (21|22) - if (k > l) then ! (22|21) => (21|22) - write (unit_a1) k, l, i, j, rklr(inz), rkli(inz) - if (ioerr .ne. 0) then - write (*, *) 'error write unit_a1', ioerr, 'rank', rank - else + if (k > l) then ! (22|21) => (21|22) + write (unit_a1) k, l, i, j, rklr(inz), rkli(inz) + if (ioerr .ne. 0) then + print *, 'error write unit_a1', ioerr, 'rank', rank + else - a1_cnt = a1_cnt + 1 - end if + a1_cnt = a1_cnt + 1 + end if - else ! (22|12) => (22|21)* => (21|22)* + else ! (22|12) => (22|21)* => (21|22)* - write (unit_a1, IOSTAT=ioerr) l, k, j, i, rklr(inz), -1.0d+00*rkli(inz) - if (ioerr .ne. 0) then - write (*, *) 'error write unit_a1', ioerr, 'rank', rank - else + write (unit_a1, IOSTAT=ioerr) l, k, j, i, rklr(inz), -1.0d+00*rkli(inz) + if (ioerr .ne. 0) then + print *, 'error write unit_a1', ioerr, 'rank', rank + else - a1_cnt = a1_cnt + 1 + a1_cnt = a1_cnt + 1 + end if end if - end if - elseif (max1 == 2 .and. min1 == 1 .and. max2 == 2 .and. min2 == 2) then ! (21|22) => (21|22) + elseif (max1 == 2 .and. min1 == 1 .and. max2 == 2 .and. min2 == 2) then ! (21|22) => (21|22) - if (i > j) then ! (21|22) => (21|22) + if (i > j) then ! (21|22) => (21|22) - write (unit_a1, IOSTAT=ioerr) i, j, k, l, rklr(inz), rkli(inz) - if (ioerr .ne. 0) then - write (*, *) 'error write unit_a1', ioerr, 'rank', rank - else + write (unit_a1, IOSTAT=ioerr) i, j, k, l, rklr(inz), rkli(inz) + if (ioerr .ne. 0) then + print *, 'error write unit_a1', ioerr, 'rank', rank + else - a1_cnt = a1_cnt + 1 - end if! write(*,'("A1int3",4I4,2E20.10)')i ,j ,k ,l , rklr(inz), rkli(inz) + a1_cnt = a1_cnt + 1 + end if! write(*,'("A1int3",4I4,2E20.10)')i ,j ,k ,l , rklr(inz), rkli(inz) - else ! (12|22) => (21|22)* + else ! (12|22) => (21|22)* - write (unit_a1, IOSTAT=ioerr) j, i, l, k, rklr(inz), -1.0d+00*rkli(inz) - if (ioerr .ne. 0) then - write (*, *) 'error write unit_a1', ioerr, 'rank', rank - else + write (unit_a1, IOSTAT=ioerr) j, i, l, k, rklr(inz), -1.0d+00*rkli(inz) + if (ioerr .ne. 0) then + print *, 'error write unit_a1', ioerr, 'rank', rank + else - a1_cnt = a1_cnt + 1 - end if! write(*,'("A1int4",4I4,2E20.10)')j ,i ,l ,k , rklr(inz),-1.0d+00*rkli(inz) + a1_cnt = a1_cnt + 1 + end if! write(*,'("A1int4",4I4,2E20.10)')j ,i ,l ,k , rklr(inz),-1.0d+00*rkli(inz) - end if + end if - elseif (max1 == 2 .and. min1 == 1 .and. max2 == 1 .and. min2 == 1) then ! (21|11)=>(21|11) + elseif (max1 == 2 .and. min1 == 1 .and. max2 == 1 .and. min2 == 1) then ! (21|11)=>(21|11) - if (i > j) then ! (21|11) => (21|11) + if (i > j) then ! (21|11) => (21|11) - write (unit_a2, IOSTAT=ioerr) i, j, k, l, rklr(inz), rkli(inz) - if (ioerr .ne. 0) then - write (*, *) 'error write unit_a2', ioerr, 'rank', rank - else + write (unit_a2, IOSTAT=ioerr) i, j, k, l, rklr(inz), rkli(inz) + if (ioerr .ne. 0) then + print *, 'error write unit_a2', ioerr, 'rank', rank + else - a2_cnt = a2_cnt + 1 - end if! write(*,'("A2int1",4I4,2E20.10)')i ,j ,k ,l , rklr(inz), rkli(inz) + a2_cnt = a2_cnt + 1 + end if! write(*,'("A2int1",4I4,2E20.10)')i ,j ,k ,l , rklr(inz), rkli(inz) - else ! (12|11) => (21|11)* => (21|11)* + else ! (12|11) => (21|11)* => (21|11)* - write (unit_a2, IOSTAT=ioerr) j, i, l, k, rklr(inz), -1.0d+00*rkli(inz) - if (ioerr .ne. 0) then - write (*, *) 'error write unit_a2', ioerr, 'rank', rank - else + write (unit_a2, IOSTAT=ioerr) j, i, l, k, rklr(inz), -1.0d+00*rkli(inz) + if (ioerr .ne. 0) then + print *, 'error write unit_a2', ioerr, 'rank', rank + else - a2_cnt = a2_cnt + 1 - end if! write(*,'("A2int2",4I4,2E20.10)')j ,i ,l ,k , rklr(inz), -1.0d+00*rkli(inz) - end if + a2_cnt = a2_cnt + 1 + end if! write(*,'("A2int2",4I4,2E20.10)')j ,i ,l ,k , rklr(inz), -1.0d+00*rkli(inz) + end if - elseif (max1 == 1 .and. min1 == 1 .and. max2 == 2 .and. min2 == 1) then ! (11|21)=>(21|11) + elseif (max1 == 1 .and. min1 == 1 .and. max2 == 2 .and. min2 == 1) then ! (11|21)=>(21|11) - if (k > l) then ! (11|21) => (21|11) + if (k > l) then ! (11|21) => (21|11) - write (unit_a2, IOSTAT=ioerr) k, l, i, j, rklr(inz), rkli(inz) - if (ioerr .ne. 0) then - write (*, *) 'error write unit_a2', ioerr, 'rank', rank - else + write (unit_a2, IOSTAT=ioerr) k, l, i, j, rklr(inz), rkli(inz) + if (ioerr .ne. 0) then + print *, 'error write unit_a2', ioerr, 'rank', rank + else - a2_cnt = a2_cnt + 1 - end if! write(*,'("A2int3",4I4,2E20.10)')k ,l ,i ,j , rklr(inz), rkli(inz) + a2_cnt = a2_cnt + 1 + end if! write(*,'("A2int3",4I4,2E20.10)')k ,l ,i ,j , rklr(inz), rkli(inz) - else ! (11|12) => (11|21)* => (21|11)* + else ! (11|12) => (11|21)* => (21|11)* - write (unit_a2, IOSTAT=ioerr) l, k, j, i, rklr(inz), -1.0d+00*rkli(inz) - if (ioerr .ne. 0) then - write (*, *) 'error write unit_a2', ioerr, 'rank', rank - else + write (unit_a2, IOSTAT=ioerr) l, k, j, i, rklr(inz), -1.0d+00*rkli(inz) + if (ioerr .ne. 0) then + print *, 'error write unit_a2', ioerr, 'rank', rank + else - a2_cnt = a2_cnt + 1 - end if! write(*,'("A2int4",4I4,2E20.10)')l ,k ,j ,i , rklr(inz), -1.0d+00*rkli(inz) + a2_cnt = a2_cnt + 1 + end if! write(*,'("A2int4",4I4,2E20.10)')l ,k ,j ,i , rklr(inz), -1.0d+00*rkli(inz) - end if - ! end if + end if + ! end if !============================================= ! 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) + 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) + if (i > j .and. k > l) then ! (21|21) => (21|21) - write (unit_b, IOSTAT=ioerr) i, j, k, l, rklr(inz), rkli(inz) - if (ioerr .ne. 0) then - write (*, *) 'error write unit_b', ioerr, 'rank', rank - else + write (unit_b, IOSTAT=ioerr) i, j, k, l, rklr(inz), rkli(inz) + if (ioerr .ne. 0) then + print *, 'error write unit_b', ioerr, 'rank', rank + else - b_cnt = b_cnt + 1 - end if - elseif (i < j .and. k > l) then ! (12|21) => (21|21) + b_cnt = b_cnt + 1 + end if + elseif (i < j .and. k > l) then ! (12|21) => (21|21) - write (unit_b, IOSTAT=ioerr) jtr, itr, k, l, SignIJ*rklr(inz), SignIJ*rkli(inz) - if (ioerr .ne. 0) then - write (*, *) 'error write unit_b', ioerr, 'rank', rank - else + write (unit_b, IOSTAT=ioerr) jtr, itr, k, l, SignIJ*rklr(inz), SignIJ*rkli(inz) + if (ioerr .ne. 0) then + print *, 'error write unit_b', ioerr, 'rank', rank + else - b_cnt = b_cnt + 1 - end if - elseif (i > j .and. k < l) then ! (21|12) => (21|21) + b_cnt = b_cnt + 1 + end if + elseif (i > j .and. k < l) then ! (21|12) => (21|21) - write (unit_b, IOSTAT=ioerr) i, j, ltr, ktr, SignKL*rklr(inz), SignKL*rkli(inz) - if (ioerr .ne. 0) then - write (*, *) 'error write unit_b', ioerr, 'rank', rank - else + write (unit_b, IOSTAT=ioerr) i, j, ltr, ktr, SignKL*rklr(inz), SignKL*rkli(inz) + if (ioerr .ne. 0) then + print *, 'error write unit_b', ioerr, 'rank', rank + else - b_cnt = b_cnt + 1 - end if - elseif (i < j .and. k < l) then ! (12|12) => (21|21)* + b_cnt = b_cnt + 1 + end if + elseif (i < j .and. k < l) then ! (12|12) => (21|21)* - write (unit_b, IOSTAT=ioerr) jtr, itr, ltr, ktr, SignIJ*SignKL*rklr(inz), SignIJ*SignKL*rkli(inz) - if (ioerr .ne. 0) then - write (*, *) 'error write unit_b', ioerr, 'rank', rank - else + write (unit_b, IOSTAT=ioerr) jtr, itr, ltr, ktr, SignIJ*SignKL*rklr(inz), SignIJ*SignKL*rkli(inz) + if (ioerr .ne. 0) then + print *, 'error write unit_b', ioerr, 'rank', rank + else - b_cnt = b_cnt + 1 + b_cnt = b_cnt + 1 + end if end if - end if !============================================================================ ! 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) + 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) + if (i > j) then ! (32|22)=>(32|22) - write (unit_c1, IOSTAT=ioerr) i, j, k, l, rklr(inz), rkli(inz) - if (ioerr .ne. 0) then - write (*, *) 'error write unit_c1', ioerr, 'rank', rank - else + write (unit_c1, IOSTAT=ioerr) i, j, k, l, rklr(inz), rkli(inz) + if (ioerr .ne. 0) then + print *, 'error write unit_c1', ioerr, 'rank', rank + else - c1_cnt = c1_cnt + 1 - end if!Iwamuro modify + c1_cnt = c1_cnt + 1 + end if!Iwamuro modify - else ! (23|22)=>(32|22) + else ! (23|22)=>(32|22) - write (unit_c1, IOSTAT=ioerr) jtr, itr, k, l, SignIJ*rklr(inz), SignIJ*rkli(inz) - if (ioerr .ne. 0) then - write (*, *) 'error write unit_c1', ioerr, 'rank', rank - else + write (unit_c1, IOSTAT=ioerr) jtr, itr, k, l, SignIJ*rklr(inz), SignIJ*rkli(inz) + if (ioerr .ne. 0) then + print *, 'error write unit_c1', ioerr, 'rank', rank + else - c1_cnt = c1_cnt + 1 - end if!Iwamuro modify - end if + c1_cnt = c1_cnt + 1 + end if!Iwamuro modify + end if - elseif (max1 == 2 .and. min1 == 2 .and. max2 == 3 .and. min2 == 2) then ! (22|32)=>(32|22) + 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) + if (k > l) then ! (22|32)=>(32|22) - write (unit_c1, IOSTAT=ioerr) k, l, i, j, rklr(inz), rkli(inz) - if (ioerr .ne. 0) then - write (*, *) 'error write unit_c1', ioerr, 'rank', rank - else + write (unit_c1, IOSTAT=ioerr) k, l, i, j, rklr(inz), rkli(inz) + if (ioerr .ne. 0) then + print *, 'error write unit_c1', ioerr, 'rank', rank + else - c1_cnt = c1_cnt + 1 - end if!Iwamuro modify - else ! (22|23)=>(32|22) + c1_cnt = c1_cnt + 1 + end if!Iwamuro modify + else ! (22|23)=>(32|22) - write (unit_c1, IOSTAT=ioerr) ltr, ktr, i, j, SignKL*rklr(inz), SignKL*rkli(inz) - if (ioerr .ne. 0) then - write (*, *) 'error write unit_c1', ioerr, 'rank', rank - else + write (unit_c1, IOSTAT=ioerr) ltr, ktr, i, j, SignKL*rklr(inz), SignKL*rkli(inz) + if (ioerr .ne. 0) then + print *, 'error write unit_c1', ioerr, 'rank', rank + else - c1_cnt = c1_cnt + 1 - end if!Iwamuro modify - end if + c1_cnt = c1_cnt + 1 + end if!Iwamuro modify + end if !============================================================================ ! 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) + 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) + if (i > j) then ! (32|11)=>(32|11) - write (unit_c2, IOSTAT=ioerr) i, j, k, l, rklr(inz), rkli(inz) - if (ioerr .ne. 0) then - write (*, *) 'error write unit_c2', ioerr, 'rank', rank - else + write (unit_c2, IOSTAT=ioerr) i, j, k, l, rklr(inz), rkli(inz) + if (ioerr .ne. 0) then + print *, 'error write unit_c2', ioerr, 'rank', rank + else - c2_cnt = c2_cnt + 1 - end if - else ! (23|11)=>(32|11) + c2_cnt = c2_cnt + 1 + end if + else ! (23|11)=>(32|11) - write (unit_c2, IOSTAT=ioerr) jtr, itr, k, l, SignIJ*rklr(inz), SignIJ*rkli(inz) - if (ioerr .ne. 0) then - write (*, *) 'error write unit_c2', ioerr, 'rank', rank - else + write (unit_c2, IOSTAT=ioerr) jtr, itr, k, l, SignIJ*rklr(inz), SignIJ*rkli(inz) + if (ioerr .ne. 0) then + print *, 'error write unit_c2', ioerr, 'rank', rank + else - c2_cnt = c2_cnt + 1 + c2_cnt = c2_cnt + 1 + end if end if - end if - elseif (max1 == 1 .and. min1 == 1 .and. max2 == 3 .and. min2 == 2) then ! (32|11)=>(32|11) + 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) + if (k > l) then ! (11|32)=>(32|11) - write (unit_c2, IOSTAT=ioerr) k, l, i, j, rklr(inz), rkli(inz) - if (ioerr .ne. 0) then - write (*, *) 'error write unit_c2', ioerr, 'rank', rank - else + write (unit_c2, IOSTAT=ioerr) k, l, i, j, rklr(inz), rkli(inz) + if (ioerr .ne. 0) then + print *, 'error write unit_c2', ioerr, 'rank', rank + else - c2_cnt = c2_cnt + 1 - end if - else ! (11|23)=>(32|11) + c2_cnt = c2_cnt + 1 + end if + else ! (11|23)=>(32|11) - write (unit_c2, IOSTAT=ioerr) ltr, ktr, i, j, SignKL*rklr(inz), SignKL*rkli(inz) - if (ioerr .ne. 0) then - write (*, *) 'error write unit_c2', ioerr, 'rank', rank - else + write (unit_c2, IOSTAT=ioerr) ltr, ktr, i, j, SignKL*rklr(inz), SignKL*rkli(inz) + if (ioerr .ne. 0) then + print *, 'error write unit_c2', ioerr, 'rank', rank + else - c2_cnt = c2_cnt + 1 + c2_cnt = c2_cnt + 1 + end if end if - end if !============================================================================ ! 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 (unit_e, IOSTAT=ioerr) i, j, ltr, ktr, SignKL*rklr(inz), SignKL*rkli(inz) - if (ioerr .ne. 0) then - write (*, *) 'error write unit_e', ioerr, 'rank', rank - else - - e_cnt = e_cnt + 1 - end if - write (unit_c3, IOSTAT=ioerr) i, j, k, l, rklr(inz), rkli(inz) - if (ioerr .ne. 0) then - write (*, *) 'error write unit_c3', ioerr, 'rank', rank - else - - c3_cnt = c3_cnt + 1 - end if - elseif (j > i .and. l > k) then ! (13|12)=>(31|21) For E - - write (unit_e, IOSTAT=ioerr) jtr, itr, ltr, ktr, SignIJ*SignKL*rklr(inz), SignIJ*SignKL*rkli(inz) - if (ioerr .ne. 0) then - write (*, *) 'error write unit_e', ioerr, 'rank', rank - else - - e_cnt = e_cnt + 1 - end if - write (unit_c3, IOSTAT=ioerr) jtr, itr, k, l, SignIJ*rklr(inz), SignIJ*rkli(inz) - if (ioerr .ne. 0) then - write (*, *) 'error write unit_c3', ioerr, 'rank', rank - else - - c3_cnt = c3_cnt + 1 - end if - elseif (i > j .and. k > l) then ! (31|21)=>(31|21) For E - - write (unit_e, IOSTAT=ioerr) i, j, k, l, rklr(inz), rkli(inz) - if (ioerr .ne. 0) then - write (*, *) 'error write unit_e', ioerr, 'rank', rank - else - - e_cnt = e_cnt + 1 - end if - write (unit_c3, IOSTAT=ioerr) i, j, ltr, ktr, SignKL*rklr(inz), SignKL*rkli(inz) - if (ioerr .ne. 0) then - write (*, *) 'error write unit_c3', ioerr, 'rank', rank - else - - c3_cnt = c3_cnt + 1 - end if - elseif (i < j .and. k > l) then ! (13|21)=>(31|21) For E - - write (unit_e, IOSTAT=ioerr) jtr, itr, k, l, SignIJ*rklr(inz), SignIJ*rkli(inz) - if (ioerr .ne. 0) then - write (*, *) 'error write unit_e', ioerr, 'rank', rank - else - - e_cnt = e_cnt + 1 - end if - write (unit_c3, IOSTAT=ioerr) jtr, itr, ltr, ktr, SignIJ*SignKL*rklr(inz), SignIJ*SignKL*rkli(inz) - if (ioerr .ne. 0) then - write (*, *) 'error write unit_c3', ioerr, 'rank', rank - else - - c3_cnt = c3_cnt + 1 - end if - end if - - 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 (unit_e, IOSTAT=ioerr) ltr, ktr, i, j, SignKL*rklr(inz), SignKL*rkli(inz) - if (ioerr .ne. 0) then - write (*, *) 'error write unit_e', ioerr, 'rank', rank - else - - e_cnt = e_cnt + 1 + 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 (unit_e, IOSTAT=ioerr) i, j, ltr, ktr, SignKL*rklr(inz), SignKL*rkli(inz) + if (ioerr .ne. 0) then + print *, 'error write unit_e', ioerr, 'rank', rank + else + + e_cnt = e_cnt + 1 + end if + write (unit_c3, IOSTAT=ioerr) i, j, k, l, rklr(inz), rkli(inz) + if (ioerr .ne. 0) then + print *, 'error write unit_c3', ioerr, 'rank', rank + else + + c3_cnt = c3_cnt + 1 + end if + elseif (j > i .and. l > k) then ! (13|12)=>(31|21) For E + + write (unit_e, IOSTAT=ioerr) jtr, itr, ltr, ktr, SignIJ*SignKL*rklr(inz), SignIJ*SignKL*rkli(inz) + if (ioerr .ne. 0) then + print *, 'error write unit_e', ioerr, 'rank', rank + else + + e_cnt = e_cnt + 1 + end if + write (unit_c3, IOSTAT=ioerr) jtr, itr, k, l, SignIJ*rklr(inz), SignIJ*rkli(inz) + if (ioerr .ne. 0) then + print *, 'error write unit_c3', ioerr, 'rank', rank + else + + c3_cnt = c3_cnt + 1 + end if + elseif (i > j .and. k > l) then ! (31|21)=>(31|21) For E + + write (unit_e, IOSTAT=ioerr) i, j, k, l, rklr(inz), rkli(inz) + if (ioerr .ne. 0) then + print *, 'error write unit_e', ioerr, 'rank', rank + else + + e_cnt = e_cnt + 1 + end if + write (unit_c3, IOSTAT=ioerr) i, j, ltr, ktr, SignKL*rklr(inz), SignKL*rkli(inz) + if (ioerr .ne. 0) then + print *, 'error write unit_c3', ioerr, 'rank', rank + else + + c3_cnt = c3_cnt + 1 + end if + elseif (i < j .and. k > l) then ! (13|21)=>(31|21) For E + + write (unit_e, IOSTAT=ioerr) jtr, itr, k, l, SignIJ*rklr(inz), SignIJ*rkli(inz) + if (ioerr .ne. 0) then + print *, 'error write unit_e', ioerr, 'rank', rank + else + + e_cnt = e_cnt + 1 + end if + write (unit_c3, IOSTAT=ioerr) jtr, itr, ltr, ktr, SignIJ*SignKL*rklr(inz), SignIJ*SignKL*rkli(inz) + if (ioerr .ne. 0) then + print *, 'error write unit_c3', ioerr, 'rank', rank + else + + c3_cnt = c3_cnt + 1 + end if + end if + + 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 (unit_e, IOSTAT=ioerr) ltr, ktr, i, j, SignKL*rklr(inz), SignKL*rkli(inz) + if (ioerr .ne. 0) then + print *, 'error write unit_e', ioerr, 'rank', rank + else + + e_cnt = e_cnt + 1 + end if + write (unit_c3, IOSTAT=ioerr) ltr, ktr, jtr, itr, SignIJ*SignKL*rklr(inz), SignIJ*SignKL*rkli(inz) + if (ioerr .ne. 0) then + print *, 'error write unit_c3', ioerr, 'rank', rank + else + + c3_cnt = c3_cnt + 1 + end if + elseif (j > i .and. l > k) then ! (12|13)=>(31|21) For E + + write (unit_e, IOSTAT=ioerr) ltr, ktr, jtr, itr, SignIJ*SignKL*rklr(inz), SignIJ*SignKL*rkli(inz) + if (ioerr .ne. 0) then + print *, 'error write unit_e', ioerr, 'rank', rank + else + + e_cnt = e_cnt + 1 + end if + write (unit_c3, IOSTAT=ioerr) ltr, ktr, i, j, SignKL*rklr(inz), SignKL*rkli(inz) + if (ioerr .ne. 0) then + print *, 'error write unit_c3', ioerr, 'rank', rank + else + + c3_cnt = c3_cnt + 1 + end if + elseif (i > j .and. k > l) then ! (21|31)=>(31|21) For E + + write (unit_e, IOSTAT=ioerr) k, l, i, j, rklr(inz), rkli(inz) + if (ioerr .ne. 0) then + print *, 'error write unit_e', ioerr, 'rank', rank + else + + e_cnt = e_cnt + 1 + end if + write (unit_c3, IOSTAT=ioerr) k, l, jtr, itr, SignIJ*rklr(inz), SignIJ*rkli(inz) + if (ioerr .ne. 0) then + print *, 'error write unit_c3', ioerr, 'rank', rank + else + + c3_cnt = c3_cnt + 1 + end if + elseif (i < j .and. k > l) then ! (12|31)=>(31|21) For E + + write (unit_e, IOSTAT=ioerr) k, l, jtr, itr, SignIJ*rklr(inz), SignIJ*rkli(inz) + if (ioerr .ne. 0) then + print *, 'error write unit_e', ioerr, 'rank', rank + else + + e_cnt = e_cnt + 1 + end if + write (unit_c3, IOSTAT=ioerr) k, l, i, j, rklr(inz), rkli(inz) + if (ioerr .ne. 0) then + print *, 'error write unit_c3', ioerr, 'rank', rank + else + + c3_cnt = c3_cnt + 1 + end if end if - write (unit_c3, IOSTAT=ioerr) ltr, ktr, jtr, itr, SignIJ*SignKL*rklr(inz), SignIJ*SignKL*rkli(inz) - if (ioerr .ne. 0) then - write (*, *) 'error write unit_c3', ioerr, 'rank', rank - else - - c3_cnt = c3_cnt + 1 - end if - elseif (j > i .and. l > k) then ! (12|13)=>(31|21) For E - - write (unit_e, IOSTAT=ioerr) ltr, ktr, jtr, itr, SignIJ*SignKL*rklr(inz), SignIJ*SignKL*rkli(inz) - if (ioerr .ne. 0) then - write (*, *) 'error write unit_e', ioerr, 'rank', rank - else - - e_cnt = e_cnt + 1 - end if - write (unit_c3, IOSTAT=ioerr) ltr, ktr, i, j, SignKL*rklr(inz), SignKL*rkli(inz) - if (ioerr .ne. 0) then - write (*, *) 'error write unit_c3', ioerr, 'rank', rank - else - - c3_cnt = c3_cnt + 1 - end if - elseif (i > j .and. k > l) then ! (21|31)=>(31|21) For E - - write (unit_e, IOSTAT=ioerr) k, l, i, j, rklr(inz), rkli(inz) - if (ioerr .ne. 0) then - write (*, *) 'error write unit_e', ioerr, 'rank', rank - else - - e_cnt = e_cnt + 1 - end if - write (unit_c3, IOSTAT=ioerr) k, l, jtr, itr, SignIJ*rklr(inz), SignIJ*rkli(inz) - if (ioerr .ne. 0) then - write (*, *) 'error write unit_c3', ioerr, 'rank', rank - else - - c3_cnt = c3_cnt + 1 - end if - elseif (i < j .and. k > l) then ! (12|31)=>(31|21) For E - - write (unit_e, IOSTAT=ioerr) k, l, jtr, itr, SignIJ*rklr(inz), SignIJ*rkli(inz) - if (ioerr .ne. 0) then - write (*, *) 'error write unit_e', ioerr, 'rank', rank - else - - e_cnt = e_cnt + 1 - end if - write (unit_c3, IOSTAT=ioerr) k, l, i, j, rklr(inz), rkli(inz) - if (ioerr .ne. 0) then - write (*, *) 'error write unit_c3', ioerr, 'rank', rank - else - - c3_cnt = c3_cnt + 1 - end if - end if !============================================================================ ! 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) + elseif (max1 == 3 .and. min1 == 1 .and. max2 == 2 .and. min2 == 2) then ! (31|22)=>(31|22) - if (i > j) then ! (31|22)=>(31|22) + if (i > j) then ! (31|22)=>(31|22) - write (unit_d1, IOSTAT=ioerr) i, j, k, l, rklr(inz), rkli(inz) - if (ioerr .ne. 0) then !ioerr /= 0 - write (*, *) 'error write unit_d1', ioerr, 'rank', rank - else + write (unit_d1, IOSTAT=ioerr) i, j, k, l, rklr(inz), rkli(inz) + if (ioerr .ne. 0) then !ioerr /= 0 + print *, 'error write unit_d1', ioerr, 'rank', rank + else - d1_cnt = d1_cnt + 1 - end if - else ! (13|22)=>(31|22) + d1_cnt = d1_cnt + 1 + end if + else ! (13|22)=>(31|22) - write (unit_d1, IOSTAT=ioerr) jtr, itr, k, l, SignIJ*rklr(inz), SignIJ*rkli(inz) - if (ioerr .ne. 0) then - write (*, *) 'error write unit_d1', ioerr, 'rank', rank - else + write (unit_d1, IOSTAT=ioerr) jtr, itr, k, l, SignIJ*rklr(inz), SignIJ*rkli(inz) + if (ioerr .ne. 0) then + print *, 'error write unit_d1', ioerr, 'rank', rank + else - d1_cnt = d1_cnt + 1 + d1_cnt = d1_cnt + 1 + end if end if - end if - elseif (max1 == 2 .and. min1 == 2 .and. max2 == 3 .and. min2 == 1) then ! (22|31)=>(31|22) + elseif (max1 == 2 .and. min1 == 2 .and. max2 == 3 .and. min2 == 1) then ! (22|31)=>(31|22) - if (k > l) then ! (22|31)=>(31|22) + if (k > l) then ! (22|31)=>(31|22) - write (unit_d1, IOSTAT=ioerr) k, l, i, j, rklr(inz), rkli(inz) - if (ioerr .ne. 0) then - write (*, *) 'error write unit_d1', ioerr, 'rank', rank - else + write (unit_d1, IOSTAT=ioerr) k, l, i, j, rklr(inz), rkli(inz) + if (ioerr .ne. 0) then + print *, 'error write unit_d1', ioerr, 'rank', rank + else - d1_cnt = d1_cnt + 1 - end if - else ! (22|13)=>(31|22) + d1_cnt = d1_cnt + 1 + end if + else ! (22|13)=>(31|22) - write (unit_d1, IOSTAT=ioerr) ltr, ktr, i, j, SignKL*rklr(inz), SignKL*rkli(inz) - if (ioerr .ne. 0) then - write (*, *) 'error write unit_d1', ioerr, 'rank', rank - else + write (unit_d1, IOSTAT=ioerr) ltr, ktr, i, j, SignKL*rklr(inz), SignKL*rkli(inz) + if (ioerr .ne. 0) then + print *, 'error write unit_d1', ioerr, 'rank', rank + else - d1_cnt = d1_cnt + 1 + d1_cnt = d1_cnt + 1 + end if end if - end if !============================================================================ ! 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) + 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) + if (i > j .and. k > l) then ! (32|21)=>(32|21) - write (unit_d2, IOSTAT=ioerr) i, j, k, l, rklr(inz), rkli(inz) - if (ioerr .ne. 0) then - write (*, *) 'error write unit_d2', ioerr, 'rank', rank - else + write (unit_d2, IOSTAT=ioerr) i, j, k, l, rklr(inz), rkli(inz) + if (ioerr .ne. 0) then + print *, 'error write unit_d2', ioerr, 'rank', rank + else - d2_cnt = d2_cnt + 1 - end if - elseif (i < j .and. k > l) then ! (23|21)=>(32|21) + d2_cnt = d2_cnt + 1 + end if + elseif (i < j .and. k > l) then ! (23|21)=>(32|21) - write (unit_d2, IOSTAT=ioerr) jtr, itr, k, l, SignIJ*rklr(inz), SignIJ*rkli(inz) - if (ioerr .ne. 0) then - write (*, *) 'error write unit_d2', ioerr, 'rank', rank - else + write (unit_d2, IOSTAT=ioerr) jtr, itr, k, l, SignIJ*rklr(inz), SignIJ*rkli(inz) + if (ioerr .ne. 0) then + print *, 'error write unit_d2', ioerr, 'rank', rank + else - d2_cnt = d2_cnt + 1 - end if - elseif (i > j .and. k < l) then ! (32|12)=>(32|21) + d2_cnt = d2_cnt + 1 + end if + elseif (i > j .and. k < l) then ! (32|12)=>(32|21) - write (unit_d2, IOSTAT=ioerr) i, j, ltr, ktr, SignKL*rklr(inz), SignKL*rkli(inz) - if (ioerr .ne. 0) then - write (*, *) 'error write unit_d2', ioerr, 'rank', rank - else + write (unit_d2, IOSTAT=ioerr) i, j, ltr, ktr, SignKL*rklr(inz), SignKL*rkli(inz) + if (ioerr .ne. 0) then + print *, 'error write unit_d2', ioerr, 'rank', rank + else - d2_cnt = d2_cnt + 1 - end if - elseif (i < j .and. k < l) then ! (23|12)=>(32|21) + d2_cnt = d2_cnt + 1 + end if + elseif (i < j .and. k < l) then ! (23|12)=>(32|21) - write (unit_d2, IOSTAT=ioerr) jtr, itr, ltr, ktr, SignIJ*SignKL*rklr(inz), SignIJ*SignKL*rkli(inz) - if (ioerr .ne. 0) then - write (*, *) 'error write unit_d2', ioerr, 'rank', rank - else + write (unit_d2, IOSTAT=ioerr) jtr, itr, ltr, ktr, SignIJ*SignKL*rklr(inz), SignIJ*SignKL*rkli(inz) + if (ioerr .ne. 0) then + print *, 'error write unit_d2', ioerr, 'rank', rank + else - d2_cnt = d2_cnt + 1 + d2_cnt = d2_cnt + 1 + end if end if - end if - elseif (max1 == 2 .and. min1 == 1 .and. max2 == 3 .and. min2 == 2) then ! (21|32)=>(32|21) + 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) + if (i > j .and. k > l) then ! (21|32)=>(32|21) - write (unit_d2, IOSTAT=ioerr) k, l, i, j, rklr(inz), rkli(inz) - if (ioerr .ne. 0) then - write (*, *) 'error write unit_d2', ioerr, 'rank', rank - else + write (unit_d2, IOSTAT=ioerr) k, l, i, j, rklr(inz), rkli(inz) + if (ioerr .ne. 0) then + print *, 'error write unit_d2', ioerr, 'rank', rank + else - d2_cnt = d2_cnt + 1 - end if - elseif (i < j .and. k > l) then ! (12|32)=>(32|21) + d2_cnt = d2_cnt + 1 + end if + elseif (i < j .and. k > l) then ! (12|32)=>(32|21) - write (unit_d2, IOSTAT=ioerr) k, l, jtr, itr, SignIJ*rklr(inz), SignIJ*rkli(inz) - if (ioerr .ne. 0) then - write (*, *) 'error write unit_d2', ioerr, 'rank', rank - else + write (unit_d2, IOSTAT=ioerr) k, l, jtr, itr, SignIJ*rklr(inz), SignIJ*rkli(inz) + if (ioerr .ne. 0) then + print *, 'error write unit_d2', ioerr, 'rank', rank + else - d2_cnt = d2_cnt + 1 - end if - elseif (i > j .and. k < l) then ! (21|23)=>(32|21) + d2_cnt = d2_cnt + 1 + end if + elseif (i > j .and. k < l) then ! (21|23)=>(32|21) - write (unit_d2, IOSTAT=ioerr) ltr, ktr, i, j, SignKL*rklr(inz), SignKL*rkli(inz) - if (ioerr .ne. 0) then - write (*, *) 'error write unit_d2', ioerr, 'rank', rank - else + write (unit_d2, IOSTAT=ioerr) ltr, ktr, i, j, SignKL*rklr(inz), SignKL*rkli(inz) + if (ioerr .ne. 0) then + print *, 'error write unit_d2', ioerr, 'rank', rank + else - d2_cnt = d2_cnt + 1 - end if - elseif (i < j .and. k < l) then ! (12|23)=>(32|21) + d2_cnt = d2_cnt + 1 + end if + elseif (i < j .and. k < l) then ! (12|23)=>(32|21) - write (unit_d2, IOSTAT=ioerr) ltr, ktr, jtr, itr, SignIJ*SignKL*rklr(inz), SignIJ*SignKL*rkli(inz) - if (ioerr .ne. 0) then - write (*, *) 'error write unit_d2', ioerr, 'rank', rank - else + write (unit_d2, IOSTAT=ioerr) ltr, ktr, jtr, itr, SignIJ*SignKL*rklr(inz), SignIJ*SignKL*rkli(inz) + if (ioerr .ne. 0) then + print *, 'error write unit_d2', ioerr, 'rank', rank + else - d2_cnt = d2_cnt + 1 + d2_cnt = d2_cnt + 1 + end if end if - end if !============================================================================ ! 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) + 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) + if (i > j) then ! (ai|jk) (31|11)=>(31|11) - write (unit_d3, IOSTAT=ioerr) i, j, k, l, rklr(inz), rkli(inz) - if (ioerr .ne. 0) then - write (*, *) 'error write unit_d3', ioerr, 'rank', rank - else + write (unit_d3, IOSTAT=ioerr) i, j, k, l, rklr(inz), rkli(inz) + if (ioerr .ne. 0) then + print *, 'error write unit_d3', ioerr, 'rank', rank + else - d3_cnt = d3_cnt + 1 - end if - else ! (i~a~|kk) (13|11)=>(31|11) + d3_cnt = d3_cnt + 1 + end if + else ! (i~a~|kk) (13|11)=>(31|11) - write (unit_d3, IOSTAT=ioerr) jtr, itr, k, l, SignIJ*rklr(inz), SignIJ*rkli(inz) - if (ioerr .ne. 0) then - write (*, *) 'error write unit_d3', ioerr, 'rank', rank - else + write (unit_d3, IOSTAT=ioerr) jtr, itr, k, l, SignIJ*rklr(inz), SignIJ*rkli(inz) + if (ioerr .ne. 0) then + print *, 'error write unit_d3', ioerr, 'rank', rank + else - d3_cnt = d3_cnt + 1 + d3_cnt = d3_cnt + 1 + end if end if - end if - elseif (max1 == 1 .and. min1 == 1 .and. max2 == 3 .and. min2 == 1) then ! (11|31)=>(31|11) + 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) + if (k > l) then ! (jk|ai) (31|11)=>(31|11) - write (unit_d3, IOSTAT=ioerr) k, l, i, j, rklr(inz), rkli(inz) - if (ioerr .ne. 0) then - write (*, *) 'error write unit_d3', ioerr, 'rank', rank - else + write (unit_d3, IOSTAT=ioerr) k, l, i, j, rklr(inz), rkli(inz) + if (ioerr .ne. 0) then + print *, 'error write unit_d3', ioerr, 'rank', rank + else - d3_cnt = d3_cnt + 1 - end if - else ! (jk|i~a~)=>( ai|kk) (11|13)=>(31|11) + d3_cnt = d3_cnt + 1 + end if + else ! (jk|i~a~)=>( ai|kk) (11|13)=>(31|11) - write (unit_d3, IOSTAT=ioerr) ltr, ktr, i, j, SignKL*rklr(inz), SignKL*rkli(inz) - if (ioerr .ne. 0) then - write (*, *) 'error write unit_d3', ioerr, 'rank', rank - else + write (unit_d3, IOSTAT=ioerr) ltr, ktr, i, j, SignKL*rklr(inz), SignKL*rkli(inz) + if (ioerr .ne. 0) then + print *, 'error write unit_d3', ioerr, 'rank', rank + else - d3_cnt = d3_cnt + 1 + d3_cnt = d3_cnt + 1 + end if end if - end if !============================================= ! 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) + 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) + if (i > j .and. k > l) then ! (32|32) => (32|32) - write (unit_f, IOSTAT=ioerr) i, j, k, l, rklr(inz), rkli(inz) - if (ioerr .ne. 0) then - write (*, *) 'error write unit_f', ioerr, 'rank', rank - else + write (unit_f, IOSTAT=ioerr) i, j, k, l, rklr(inz), rkli(inz) + if (ioerr .ne. 0) then + print *, 'error write unit_f', ioerr, 'rank', rank + else - f_cnt = f_cnt + 1 - end if - elseif (i < j .and. k > l) then ! (23|32) => (32|32) + f_cnt = f_cnt + 1 + end if + elseif (i < j .and. k > l) then ! (23|32) => (32|32) - write (unit_f, IOSTAT=ioerr) jtr, itr, k, l, SignIJ*rklr(inz), SignIJ*rkli(inz) - if (ioerr .ne. 0) then - write (*, *) 'error write unit_f', ioerr, 'rank', rank - else + write (unit_f, IOSTAT=ioerr) jtr, itr, k, l, SignIJ*rklr(inz), SignIJ*rkli(inz) + if (ioerr .ne. 0) then + print *, 'error write unit_f', ioerr, 'rank', rank + else - f_cnt = f_cnt + 1 - end if - elseif (i > j .and. k < l) then ! (32|23) => (32|32) + f_cnt = f_cnt + 1 + end if + elseif (i > j .and. k < l) then ! (32|23) => (32|32) - write (unit_f, IOSTAT=ioerr) i, j, ltr, ktr, SignKL*rklr(inz), SignKL*rkli(inz) - if (ioerr .ne. 0) then - write (*, *) 'error write unit_f', ioerr, 'rank', rank - else + write (unit_f, IOSTAT=ioerr) i, j, ltr, ktr, SignKL*rklr(inz), SignKL*rkli(inz) + if (ioerr .ne. 0) then + print *, 'error write unit_f', ioerr, 'rank', rank + else - f_cnt = f_cnt + 1 - end if - elseif (i < j .and. k < l) then ! (23|23) => (32|32) + f_cnt = f_cnt + 1 + end if + elseif (i < j .and. k < l) then ! (23|23) => (32|32) - write (unit_f, IOSTAT=ioerr) jtr, itr, ltr, ktr, SignIJ*SignKL*rklr(inz), SignIJ*SignKL*rkli(inz) - if (ioerr .ne. 0) then - write (*, *) 'error write unit_f', ioerr, 'rank', rank - else + write (unit_f, IOSTAT=ioerr) jtr, itr, ltr, ktr, SignIJ*SignKL*rklr(inz), SignIJ*SignKL*rkli(inz) + if (ioerr .ne. 0) then + print *, 'error write unit_f', ioerr, 'rank', rank + else - f_cnt = f_cnt + 1 + f_cnt = f_cnt + 1 + end if end if - end if !============================================================================ ! G space (ai|bp)(31|32) type !============================================================================ - elseif (max1 == 3 .and. min1 == 1 .and. max2 == 3 .and. min2 == 2) then ! (31|32)=>(31|32) + 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) + if (i > j .and. l > k) then ! (31|23)=>(31|32) - write (unit_g, IOSTAT=ioerr) i, j, ltr, ktr, SignKL*rklr(inz), SignKL*rkli(inz) - if (ioerr .ne. 0) then - write (*, *) 'error write unit_g', ioerr, 'rank', rank - else + write (unit_g, IOSTAT=ioerr) i, j, ltr, ktr, SignKL*rklr(inz), SignKL*rkli(inz) + if (ioerr .ne. 0) then + print *, 'error write unit_g', ioerr, 'rank', rank + else - g_cnt = g_cnt + 1 - end if! write(*,'("Gint1",4I4,2E20.10)')i ,j ,ltr,ktr, SignKL*rklr(inz), SignKL*rkli(inz) + g_cnt = g_cnt + 1 + end if! 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) then ! (13|23)=>(31|32) - write (unit_g, IOSTAT=ioerr) jtr, itr, ltr, ktr, SignIJ*SignKL*rklr(inz), SignIJ*SignKL*rkli(inz) - if (ioerr .ne. 0) then - write (*, *) 'error write unit_g', ioerr, 'rank', rank - else + write (unit_g, IOSTAT=ioerr) jtr, itr, ltr, ktr, SignIJ*SignKL*rklr(inz), SignIJ*SignKL*rkli(inz) + if (ioerr .ne. 0) then + print *, 'error write unit_g', ioerr, 'rank', rank + else - g_cnt = g_cnt + 1 - end if! write(*,'("Gint2",4I4,2E20.10)')jtr,itr,ltr,ktr, SignIJ*SignKL*rklr(inz), SignIJ*SignKL*rkli(inz) + g_cnt = g_cnt + 1 + end if! 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) + elseif (i > j .and. k > l) then ! (31|32)=>(31|32) - write (unit_g, IOSTAT=ioerr) i, j, k, l, rklr(inz), rkli(inz) - if (ioerr .ne. 0) then - write (*, *) 'error write unit_g', ioerr, 'rank', rank - else + write (unit_g, IOSTAT=ioerr) i, j, k, l, rklr(inz), rkli(inz) + if (ioerr .ne. 0) then + print *, 'error write unit_g', ioerr, 'rank', rank + else - g_cnt = g_cnt + 1 - end if! write(*,'("Gint3",4I4,2E20.10)')i ,j ,k ,l , rklr(inz), rkli(inz) + g_cnt = g_cnt + 1 + end if! 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) then ! (13|32)=>(31|32) - write (unit_g, IOSTAT=ioerr) jtr, itr, k, l, SignIJ*rklr(inz), SignIJ*rkli(inz) - if (ioerr .ne. 0) then - write (*, *) 'error write unit_g', ioerr, 'rank', rank - else + write (unit_g, IOSTAT=ioerr) jtr, itr, k, l, SignIJ*rklr(inz), SignIJ*rkli(inz) + if (ioerr .ne. 0) then + print *, 'error write unit_g', ioerr, 'rank', rank + else - g_cnt = g_cnt + 1 - end if! write(*,'("Gint4",4I4,2E20.10)')jtr,itr,k ,l , SignIJ*rklr(inz), SignIJ*rkli(inz) + g_cnt = g_cnt + 1 + end if! write(*,'("Gint4",4I4,2E20.10)')jtr,itr,k ,l , SignIJ*rklr(inz), SignIJ*rkli(inz) - end if + end if - elseif (max1 == 3 .and. min1 == 2 .and. max2 == 3 .and. min2 == 1) then ! (32|31)=>(31|32) + 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) + if (i > j .and. l > k) then ! (32|13)=>(31|32) - write (unit_g, IOSTAT=ioerr) ltr, ktr, i, j, SignKL*rklr(inz), SignKL*rkli(inz) - if (ioerr .ne. 0) then - write (*, *) 'error write unit_g', ioerr, 'rank', rank - else + write (unit_g, IOSTAT=ioerr) ltr, ktr, i, j, SignKL*rklr(inz), SignKL*rkli(inz) + if (ioerr .ne. 0) then + print *, 'error write unit_g', ioerr, 'rank', rank + else - g_cnt = g_cnt + 1 - end if! write(*,'("Gint5",4I4,2E20.10)')ltr,ktr,i ,j , SignKL*rklr(inz), SignKL*rkli(inz) + g_cnt = g_cnt + 1 + end if! 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) + elseif (j > i .and. l > k) then ! (23|13)=>(31|32) - write (unit_g, IOSTAT=ioerr) ltr, ktr, jtr, itr, SignIJ*SignKL*rklr(inz), SignIJ*SignKL*rkli(inz) - if (ioerr .ne. 0) then - write (*, *) 'error write unit_g', ioerr, 'rank', rank - else + write (unit_g, IOSTAT=ioerr) ltr, ktr, jtr, itr, SignIJ*SignKL*rklr(inz), SignIJ*SignKL*rkli(inz) + if (ioerr .ne. 0) then + print *, 'error write unit_g', ioerr, 'rank', rank + else - g_cnt = g_cnt + 1 - end if ! write (*, '("Gint6",4I4,2E20.10)') ltr, ktr, jtr, itr, SignIJ*SignKL*rklr(inz), SignIJ*SignKL*rkli(inz) + g_cnt = g_cnt + 1 + end if ! print '("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) + elseif (i > j .and. k > l) then ! (32|31)=>(31|32) - write (unit_g, IOSTAT=ioerr) k, l, i, j, rklr(inz), rkli(inz) - if (ioerr .ne. 0) then - write (*, *) 'error write unit_g', ioerr, 'rank', rank - else + write (unit_g, IOSTAT=ioerr) k, l, i, j, rklr(inz), rkli(inz) + if (ioerr .ne. 0) then + print *, 'error write unit_g', ioerr, 'rank', rank + else - g_cnt = g_cnt + 1 - end if! write(*,'("Gint7",4I4,2E20.10)')k ,l ,i ,j , rklr(inz), rkli(inz) + g_cnt = g_cnt + 1 + end if! write(*,'("Gint7",4I4,2E20.10)')k ,l ,i ,j , rklr(inz), rkli(inz) - elseif (i < j .and. k > l) then ! (23|31)=>(31|32) + elseif (i < j .and. k > l) then ! (23|31)=>(31|32) - write (unit_g, IOSTAT=ioerr) k, l, jtr, itr, SignIJ*rklr(inz), SignIJ*rkli(inz) - if (ioerr .ne. 0) then - write (*, *) 'error write unit_g', ioerr, 'rank', rank - else + write (unit_g, IOSTAT=ioerr) k, l, jtr, itr, SignIJ*rklr(inz), SignIJ*rkli(inz) + if (ioerr .ne. 0) then + print *, 'error write unit_g', ioerr, 'rank', rank + else - g_cnt = g_cnt + 1 - end if! write(*,'("Gint8",4I4,2E20.10)')k ,l ,jtr,itr, SignIJ*rklr(inz), SignIJ*rkli(inz) + g_cnt = g_cnt + 1 + end if! write(*,'("Gint8",4I4,2E20.10)')k ,l ,jtr,itr, SignIJ*rklr(inz), SignIJ*rkli(inz) - end if + end if !============================================= ! 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) + 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) + if (i > j .and. k > l) then ! (31|31) => (31|31) - write (unit_h, IOSTAT=ioerr) i, j, k, l, rklr(inz), rkli(inz) - if (ioerr .ne. 0) then - write (*, *) 'error write unit_h', ioerr, 'rank', rank - else + write (unit_h, IOSTAT=ioerr) i, j, k, l, rklr(inz), rkli(inz) + if (ioerr .ne. 0) then + print *, 'error write unit_h', ioerr, 'rank', rank + else - h_cnt = h_cnt + 1 - end if! write(*,'("Hint1",4I4,2E20.10)')i ,j ,k ,l , rklr(inz), rkli(inz) + h_cnt = h_cnt + 1 + end if! write(*,'("Hint1",4I4,2E20.10)')i ,j ,k ,l , rklr(inz), rkli(inz) - elseif (i < j .and. k > l) then ! (13|31) => (31|31) + elseif (i < j .and. k > l) then ! (13|31) => (31|31) - write (unit_h, IOSTAT=ioerr) jtr, itr, k, l, SignIJ*rklr(inz), SignIJ*rkli(inz) - if (ioerr .ne. 0) then - write (*, *) 'error write unit_h', ioerr, 'rank', rank - else + write (unit_h, IOSTAT=ioerr) jtr, itr, k, l, SignIJ*rklr(inz), SignIJ*rkli(inz) + if (ioerr .ne. 0) then + print *, 'error write unit_h', ioerr, 'rank', rank + else - h_cnt = h_cnt + 1 - end if! write(*,'("Hint2",4I4,2E20.10)')jtr,itr,k ,l , SignIJ*rklr(inz), SignIJ*rkli(inz) + h_cnt = h_cnt + 1 + end if! write(*,'("Hint2",4I4,2E20.10)')jtr,itr,k ,l , SignIJ*rklr(inz), SignIJ*rkli(inz) - elseif (i > j .and. k < l) then ! (31|13) => (31|31) + elseif (i > j .and. k < l) then ! (31|13) => (31|31) - write (unit_h, IOSTAT=ioerr) i, j, ltr, ktr, SignKL*rklr(inz), SignKL*rkli(inz) - if (ioerr .ne. 0) then - write (*, *) 'error write unit_h', ioerr, 'rank', rank - else + write (unit_h, IOSTAT=ioerr) i, j, ltr, ktr, SignKL*rklr(inz), SignKL*rkli(inz) + if (ioerr .ne. 0) then + print *, 'error write unit_h', ioerr, 'rank', rank + else - h_cnt = h_cnt + 1 - end if! write(*,'("Hint3",4I4,2E20.10)')i ,j ,ltr,ktr, SignKL*rklr(inz), SignKL*rkli(inz) + h_cnt = h_cnt + 1 + end if! write(*,'("Hint3",4I4,2E20.10)')i ,j ,ltr,ktr, SignKL*rklr(inz), SignKL*rkli(inz) - elseif (i < j .and. k < l) then ! (13|13) => (31|31) + elseif (i < j .and. k < l) then ! (13|13) => (31|31) - write (unit_h, IOSTAT=ioerr) jtr, itr, ltr, ktr, SignIJ*SignKL*rklr(inz), SignIJ*SignKL*rkli(inz) - if (ioerr .ne. 0) then - write (*, *) 'error write unit_h', ioerr, 'rank', rank - else + write (unit_h, IOSTAT=ioerr) jtr, itr, ltr, ktr, SignIJ*SignKL*rklr(inz), SignIJ*SignKL*rkli(inz) + if (ioerr .ne. 0) then + print *, 'error write unit_h', ioerr, 'rank', rank + else - h_cnt = h_cnt + 1 - end if! write(*,'("Hint4",4I4,2E20.10)')jtr,itr,ltr,ktr,SignIJ*SignKL*rklr(inz),SignIJ*SignKL*rkli(inz) + h_cnt = h_cnt + 1 + end if! write(*,'("Hint4",4I4,2E20.10)')jtr,itr,ltr,ktr,SignIJ*SignKL*rklr(inz),SignIJ*SignKL*rkli(inz) + end if end if - end if - - if (abs(rkli(inz)) > thres) realc = .false. - -70 End do - Goto 60 + if (abs(rkli(inz)) > thres) realc = .false. + end do ! Next inz + end do ! Continue to read 2-integrals - -10 if (rank == 0) write (*, *) 'error for opening mdcint 10' - go to 100 -20 if (rank == 0) write (*, *) 'error for reading mdcint 20' - go to 100 -30 if (rank == 0) write (*, *) 'end mdcint 30' - go to 100 -40 if (rank == 0) write (*, *) 'error for reading mdcint 40' - go to 100 -50 if (rank == 0) write (*, *) 'end mdcint 50 normal' +10 if (rank == 0) print *, 'error for opening mdcint 10' go to 100 100 continue @@ -893,13 +910,11 @@ SUBROUTINE readint2_ord_co(filename) ! 2 electorn integrals created by typart in close (unit_f) close (unit_g) close (unit_h) - 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) - if (rank == 0) then ! Process limits for output - write (*, *) "end readint2_ord_co" - end if + if (allocated(indk)) deallocate (indk); Call memminus(KIND(indk), SIZE(indk), 1) + if (allocated(indl)) deallocate (indl); Call memminus(KIND(indl), SIZE(indl), 1) + if (allocated(rklr)) deallocate (rklr); Call memminus(KIND(rklr), SIZE(rklr), 1) + if (allocated(rkli)) deallocate (rkli); Call memminus(KIND(rkli), SIZE(rkli), 1) + if (allocated(kr)) deallocate (kr); Call memminus(KIND(kr), SIZE(kr), 1) + if (rank == 0) print *, "end readint2_ord_co" end subroutine readint2_ord_co diff --git a/src/readorb_enesym_co.f90 b/src/readorb_enesym_co.f90 index 6efdfce5..94eb91a8 100644 --- a/src/readorb_enesym_co.f90 +++ b/src/readorb_enesym_co.f90 @@ -5,15 +5,14 @@ SUBROUTINE readorb_enesym_co(filename) ! orbital energies in r4dmoin1 ! ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ use four_caspt2_module - + use module_sort_swap Implicit NONE integer :: mrconee, IMO, IRP character*50, intent(in) :: filename - integer :: i0, j0, k0, i, j, m, isym, jsym, ksym + integer :: i0, j0, k0, i, j, m, isym, jsym, ksym, iostat integer, allocatable :: dammo(:), UTCHEMIMO1(:, :), UTCHEMIMO2(:, :) integer, allocatable :: SD(:, :), DS(:, :) - real*8 :: w logical :: breit ! Write(UT_sys_ftmp) NMO,UT_molinp_atm_enm - DELETE, & @@ -26,11 +25,18 @@ SUBROUTINE readorb_enesym_co(filename) ! orbital energies in r4dmoin1 mrconee = 10 - open (mrconee, file=trim(filename), form='unformatted', status='old', err=10) + open (mrconee, file=trim(filename), form='unformatted', status='old', iostat=iostat) + + if (iostat /= 0) then ! open failed, stop the program + print *, 'ERROR: Error opening file ', trim(filename), ' , rank = ', rank + print *, 'Stop the program.' + stop + end if + Read (mrconee) NMO, BREIT, ECORE ! NMO is nbas - ncore if (rank == 0) then - write (*, *) 'NMO, BREIT, ECORE, 1 ! NMO is nbas - ncore' - write (*, *) NMO, BREIT, ECORE, 1 ! NMO is nbas - ncore + print *, 'NMO, BREIT, ECORE, 1 ! NMO is nbas - ncore' + print *, NMO, BREIT, ECORE, 1 ! NMO is nbas - ncore end if !Iwamuro modify scfru = 1 @@ -47,13 +53,13 @@ SUBROUTINE readorb_enesym_co(filename) ! orbital energies in r4dmoin1 Read (mrconee) NSYMRP, (REPN(IRP), IRP=1, NSYMRP) ! IRs chars if (rank == 0) then - write (*, *) ' NSYMRP, (REPN(IRP),IRP=1,NSYMRP) ! IRs chars' - write (*, *) NSYMRP, (REPN(IRP), IRP=1, NSYMRP) ! IRs chars + 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) if (rank == 0) then - write (*, *) nsymrpa, (repna(i0), i0=1, nsymrpa*2) + print *, nsymrpa, (repna(i0), i0=1, nsymrpa*2) end if allocate (MULTB_S(1:NSYMRPA, 1:NSYMRPA)) allocate (MULTB_D(1:NSYMRPA, 1:NSYMRPA)) ! dagger @@ -104,18 +110,18 @@ SUBROUTINE readorb_enesym_co(filename) ! orbital energies in r4dmoin1 End do if (rank == 0) then - write (*, *) 'MULTB' + print *, 'MULTB' Do i0 = 1, 2*nsymrpa - write (*, '(400I3)') (MULTB(i0, j0), j0=1, 2*nsymrpa) + print '(400I3)', (MULTB(i0, j0), j0=1, 2*nsymrpa) End do - write (*, *) 'MULTB2' + print *, 'MULTB2' Do i0 = 1, 2*nsymrpa - write (*, '(400I3)') (MULTB2(i0, j0), j0=1, 2*nsymrpa) + print '(400I3)', (MULTB2(i0, j0), j0=1, 2*nsymrpa) End do - write (*, *) 'end multb1,2' + print *, 'end multb1,2' end if ! create MULTB_S, MULTB_D @@ -131,16 +137,16 @@ SUBROUTINE readorb_enesym_co(filename) ! orbital energies in r4dmoin1 MULTB_D = MULTB_D - nsymrpa if (rank == 0) then - write (*, *) 'MULTB_S' + print *, 'MULTB_S' Do i0 = 1, nsymrpa - write (*, '(200I3)') (MULTB_S(i0, j0), j0=1, nsymrpa) + print '(200I3)', (MULTB_S(i0, j0), j0=1, nsymrpa) End do - write (*, *) 'MULTB_D' + print *, 'MULTB_D' Do i0 = 1, nsymrpa - write (*, '(200I3)') (MULTB_D(i0, j0), j0=1, nsymrpa) + print '(200I3)', (MULTB_D(i0, j0), j0=1, nsymrpa) End do end if @@ -156,56 +162,68 @@ SUBROUTINE readorb_enesym_co(filename) ! orbital energies in r4dmoin1 sp(ninact + nact + nsec + 1:nmo) = 4 if (rank == 0) then - write (*, *) 'moint1 is closed.' + print *, 'moint1 is closed.' end if ! irpmo(1:imo) = irpmo(1:imo) + 1 ! irrep starts from 1 ! Create MULTB_DF, MULTB_SB and MULTB_DB - If (trim(ptgrp) == 'C1') go to 71 - -!Iwamuro modify - if (rank == 0) then - write (*, *) 'if pgsym=c1, this route does not go through. ' - end if - - Do jsym = 1, nsymrpa - Do isym = 1, nsymrpa - 1, 2 - MULTB_DF(isym + 1, jsym) = MULTB_D(isym, jsym) - MULTB_DF(isym, jsym) = MULTB_D(isym + 1, jsym) + If (trim(ptgrp) == 'C1') then ! C1 symmetry + if (rank == 0) then + print *, 'If pgsym=c1, this route goes through.' + end if + NSYMRP = 1 + NSYMRPA = 1 + REPNA(1) = 'a'; REPNA(2) = 'a' + + SD(1, 1) = 1 + DS(1, 1) = 1 + MULTB_DS = 1 + irpmo = 1 + else ! trim(prgrp) /= 'C1' + !Iwamuro modify + ! Not C1 symmetry + if (rank == 0) then + print *, 'if pgsym=c1, this route does not go through. ' + end if + + Do jsym = 1, nsymrpa + Do isym = 1, nsymrpa - 1, 2 + MULTB_DF(isym + 1, jsym) = MULTB_D(isym, jsym) + MULTB_DF(isym, jsym) = MULTB_D(isym + 1, jsym) + End do End do - End do - Do jsym = 1, nsymrpa - Do isym = 1, nsymrpa - ksym = MULTB_DF(isym, jsym) - MULTB_DB(isym, ksym) = jsym + Do jsym = 1, nsymrpa + Do isym = 1, nsymrpa + ksym = MULTB_DF(isym, jsym) + MULTB_DB(isym, ksym) = jsym + End do End do - End do - Do jsym = 1, nsymrpa - Do isym = 1, nsymrpa - ksym = MULTB_S(isym, jsym) - MULTB_SB(isym, ksym) = jsym + Do jsym = 1, nsymrpa + Do isym = 1, nsymrpa + ksym = MULTB_S(isym, jsym) + MULTB_SB(isym, ksym) = jsym + End do End do - End do - if (rank == 0) then - write (*, *) 'MULTB_SB' - Do I = 1, nsymrpa - write (*, '(50I3)') (MULTB_SB(I, J), J=1, NSYMRPA) - End do + if (rank == 0) then + print *, 'MULTB_SB' + Do I = 1, nsymrpa + print '(50I3)', (MULTB_SB(I, J), J=1, NSYMRPA) + End do - write (*, *) 'MULTB_DF' - Do I = 1, nsymrpa - write (*, '(50I3)') (MULTB_DF(I, J), J=1, NSYMRPA) - End do + print *, 'MULTB_DF' + Do I = 1, nsymrpa + print '(50I3)', (MULTB_DF(I, J), J=1, NSYMRPA) + End do - write (*, *) 'MULTB_DB' - Do I = 1, nsymrpa - write (*, '(50I3)') (MULTB_DB(I, J), J=1, NSYMRPA) - End do - end if + print *, 'MULTB_DB' + Do I = 1, nsymrpa + print '(50I3)', (MULTB_DB(I, J), J=1, NSYMRPA) + End do + end if ! Write(*,'("UTCHEMIMO1",50I3)') (UTCHEMIMO1(IMO,1),IMO=1,nmo) ! Write(*,'("UTCHEMIMO2",50I3)') (UTCHEMIMO2(IMO,1),IMO=1,nmo) ! Write(*,'("IRPMO",50I3)') (IRPMO(IMO),IMO=1,nmo) @@ -213,104 +231,91 @@ SUBROUTINE readorb_enesym_co(filename) ! orbital energies in r4dmoin1 ! Create MULTB_DS, MULTB_SD - If (trim(ptgrp) == 'C32h') then - 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 ' - - Do i = 1, nsymrpa/2 - Do j = 1, nsymrpa/2 - SD(i, j) = MULTB(i + nsymrpa, j) + If (trim(ptgrp) == 'C32h') then + 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 ' + + Do i = 1, nsymrpa/2 + Do j = 1, nsymrpa/2 + SD(i, j) = MULTB(i + nsymrpa, j) + End do End do - End do - Do i = 1, nsymrpa/2 - Do j = 1, nsymrpa/2 - SD(i, j + nsymrpa/2) = SD(i, j) + nsymrpa/2 + Do i = 1, nsymrpa/2 + Do j = 1, nsymrpa/2 + SD(i, j + nsymrpa/2) = SD(i, j) + nsymrpa/2 + End do End do - End do - Do i = 1, nsymrpa/2 - Do j = 1, nsymrpa/2 - SD(i + nsymrpa/2, j) = SD(i, j + nsymrpa/2) + Do i = 1, nsymrpa/2 + Do j = 1, nsymrpa/2 + SD(i + nsymrpa/2, j) = SD(i, j + nsymrpa/2) + End do End do - End do - Do i = 1, nsymrpa/2 - Do j = 1, nsymrpa/2 - SD(i + nsymrpa/2, j + nsymrpa/2) = SD(i, j) + Do i = 1, nsymrpa/2 + Do j = 1, nsymrpa/2 + SD(i + nsymrpa/2, j + nsymrpa/2) = SD(i, j) + End do End do - End do - - Elseif (trim(ptgrp) == 'C32') then - 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) + Elseif (trim(ptgrp) == 'C32') then + 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 - End do - Else + Else - Do i = 1, nsymrpa - Do j = 1, nsymrpa - SD(i, j) = MULTB(i + nsymrpa, j) + Do i = 1, nsymrpa + Do j = 1, nsymrpa + SD(i, j) = MULTB(i + nsymrpa, j) + End do End do - End do - - End if - - go to 72 -71 if (rank == 0) then - write (*, *) 'If pgsym=c1, this route goes through.' + End if end if - NSYMRP = 1 - NSYMRPA = 1 - REPNA(1) = 'a'; REPNA(2) = 'a' - SD(1, 1) = 1 - DS(1, 1) = 1 - MULTB_DS = 1 - irpmo = 1 - -72 If (trim(ptgrp) /= 'C1') nsymrp = nsymrpa + If (trim(ptgrp) /= 'C1') nsymrp = nsymrpa if (rank == 0) then - write (*, *) 'MULTB_SD' + print *, 'MULTB_SD' Do i = 1, nsymrpa - write (*, '(50I3)') (SD(i, j), j=1, nsymrpa) + print '(50I3)', (SD(i, j), j=1, nsymrpa) End do end if Do i = 1, nsymrpa @@ -320,9 +325,9 @@ SUBROUTINE readorb_enesym_co(filename) ! orbital energies in r4dmoin1 End do if (rank == 0) then - write (*, *) 'MULTB_DS' + print *, 'MULTB_DS' Do i = 1, nsymrpa - write (*, '(50I3)') (DS(i, j), j=1, nsymrpa) + print '(50I3)', (DS(i, j), j=1, nsymrpa) End do end if MULTB_DS(:, :) = DS(:, :) @@ -350,87 +355,57 @@ SUBROUTINE readorb_enesym_co(filename) ! orbital energies in r4dmoin1 !Iwamuro modify irpmo(:) = irpamo(:) -! Do IMO=1,NMO -! Write(*,*) IRPMO(IMO),ORBMO(IMO) -! Enddo - -!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" - if (rank == 0) then - write (*, '("irpamo ",20I2)') (irpamo(i0), i0=1, nmo) + print '("irpamo ",20I2)', (irpamo(i0), i0=1, nmo) end if -! orbmo(:) = 0.0d+00 + orb = orbmo ! orb is lower order of orbmo + call heapSort(orb, .false.) + allocate (sort_orb(nmo)); Call memplus(KIND(sort_orb), SIZE(sort_orb), 1) + sort_orb = orb +! RAS sort + if (is_ras1_configured .or. is_ras2_configured .or. is_ras3_configured) then + call sort_list_energy_order_to_ras_order(sort_orb, orb) + end if - 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 +!! orb_sort is lower order of orbmo + ! sort_orb(i0) and sort_orb(i0+1) should be same orbital energy (kramers pair) do i0 = 1, nmo, 2 m = 0 do j0 = 1, nmo - if (orbmo(j0) == orb(i0)) then ! orbmo(j0) is i0 th MO + if (orbmo(j0) == sort_orb(i0)) then ! orbmo(j0) is i0 th MO if (m == 0) then indmo(i0) = j0 m = m + 1 else indmo(i0 + 1) = j0 end if - end if end do end do + if (rank == 0) then + print *, 'orb sort end' + + print *, 'i0,orb(i0),sort_orb(i0)' + do i0 = 1, nmo + print *, i0, orb(i0), sort_orb(i0) + end do + end if + do i0 = 1, nmo indmor(indmo(i0)) = i0 ! i0 is energetic order, indmo(i0) is symmtric order (MRCONEE order) end do if (rank == 0) then do i0 = 1, nmo - write (*, '("indmor output",3I4)') indmor(i0), indmo(i0), i0 + print '("indmor output",3I4)', indmor(i0), indmo(i0), i0 end do end if - orbmo = orb + orbmo = sort_orb dammo = irpmo @@ -440,51 +415,104 @@ SUBROUTINE readorb_enesym_co(filename) ! orbital energies in r4dmoin1 end do if (rank == 0) then - write (*, '("irpamo ",20I2)') (irpamo(i0), i0=1, nmo) + print '("irpamo ",20I2)', (irpamo(i0), i0=1, nmo) - write (*, *) 'inactive' + print *, 'inactive' do i0 = 1, ninact - write (*, '(2I4,2X,E20.10,2X,I4)') i0, indmo(i0), orbmo(i0), irpmo(i0) + print '(2I4,2X,E20.10,2X,I4)', i0, indmo(i0), orbmo(i0), irpmo(i0) end do - write (*, *) 'active' + print *, 'active' do i0 = ninact + 1, ninact + nact - write (*, '(2I4,2X,E20.10,2X,I4)') i0, indmo(i0), orbmo(i0), irpmo(i0) + print '(2I4,2X,E20.10,2X,I4)', i0, indmo(i0), orbmo(i0), irpmo(i0) end do - write (*, *) 'secondary' + print *, 'secondary' do i0 = ninact + nact + 1, ninact + nact + nsec - write (*, '(2I4,2X,E20.10,2X,I4)') i0, indmo(i0), orbmo(i0), irpmo(i0) + print '(2I4,2X,E20.10,2X,I4)', i0, indmo(i0), orbmo(i0), irpmo(i0) end do end if -! do i0 = 1, nmo -! indmo(i0)=i0 -! end do - - deallocate (dammo); Call memminus(KIND(dammo), SIZE(dammo), 1) - - goto 1000 - -10 if (rank == 0) then - write (*, *) 'err 0' - end if - go to 1000 -11 if (rank == 0) then - write (*, *) 'err 1' - end if - go to 1000 -12 if (rank == 0) then - write (*, *) 'err 2' - end if - go to 1000 -13 if (rank == 0) then - write (*, *) 'err 3' - end if - go to 1000 -14 if (rank == 0) then - write (*, *) 'err 4' - end if - go to 1000 -100 go to 1000 -1000 end subroutine readorb_enesym_co + if (allocated(dammo)) deallocate (dammo); Call memminus(KIND(dammo), SIZE(dammo), 1) + if (allocated(orb)) deallocate (orb); Call memminus(KIND(orb), SIZE(orb), 1) + if (allocated(sort_orb)) deallocate (sort_orb); Call memminus(KIND(sort_orb), SIZE(sort_orb), 1) +contains + + subroutine sort_list_energy_order_to_ras_order(want_to_sort, original_orb_energy_order) + use four_caspt2_module, only: ras1_list, ras2_list, ras3_list, ninact, nact, nsec, ras1_size, ras2_size, ras3_size + implicit none + real(8), intent(in) :: original_orb_energy_order(:) + real(8), intent(inout) :: want_to_sort(:) + integer :: current_spinor_idx, current_idx, idx + integer :: ras1_current_idx, ras2_current_idx, ras3_current_idx + if (rank == 0) print *, 'sizeofras', ras1_size, ras2_size, ras3_size + if (ras1_size == 0 .and. ras2_size == 0 .and. ras3_size == 0) return ! Do nothing because ras is not configured + current_spinor_idx = 1; current_idx = 1; ras1_current_idx = 1; ras2_current_idx = 1; ras3_current_idx = 1 ! Initialization + ! Fill ninact + do while (current_idx <= ninact) + if (is_ras1_configured .and. ras1_list(ras1_current_idx) == current_spinor_idx) then + if (ras1_size > ras1_current_idx) ras1_current_idx = ras1_current_idx + 1 ! Skip ras1_list(ras1_current_idx) + elseif (is_ras2_configured .and. ras2_list(ras2_current_idx) == current_spinor_idx) then + if (ras2_size > ras2_current_idx) ras2_current_idx = ras2_current_idx + 1 ! Skip ras2_list(ras2_current_idx) + elseif (is_ras3_configured .and. ras3_list(ras3_current_idx) == current_spinor_idx) then + if (ras3_size > ras3_current_idx) ras3_current_idx = ras3_current_idx + 1 ! Skip ras3_list(ras3_current_idx) + else + want_to_sort(current_idx) = original_orb_energy_order(current_spinor_idx) + current_idx = current_idx + 1 + end if + current_spinor_idx = current_spinor_idx + 1 ! Next spinor (energy order) + end do + ! current_idx must be ninact + 1 + if (current_idx /= ninact + 1) then + print *, "ERROR: Sorting energy ascending order to RAS order is failed... STOP THE PROGRAM" + print *, "ORIGINAL ENERGY ORDER LIST : ", original_orb_energy_order + print *, "LIST OF SORTING IN PROGRESS: ", want_to_sort(1:current_idx) + stop ! ERROR, STOP THE PROGRAM + end if + + ! Fill active + ! Fill ras1 + if (ras1_size > 0) then + do idx = 1, ras1_size + want_to_sort(current_idx + idx - 1) = original_orb_energy_order(ras1_list(idx)) + end do + current_idx = current_idx + ras1_size + end if + ! Fill ras2 + if (ras2_size > 0) then + do idx = 1, ras2_size + want_to_sort(current_idx + idx - 1) = original_orb_energy_order(ras2_list(idx)) + end do + current_idx = current_idx + ras2_size + end if + ! Fill ras3 + if (ras3_size > 0) then + do idx = 1, ras3_size + want_to_sort(current_idx + idx - 1) = original_orb_energy_order(ras3_list(idx)) + end do + current_idx = current_idx + ras3_size + end if + + ! current_idx must be ninact + nact +1 + if (current_idx /= ninact + nact + 1) then + print *, "ERROR: Sorting energy ascending order to RAS order is failed... STOP THE PROGRAM" + print *, "ORIGINAL ENERGY ORDER LIST : ", original_orb_energy_order + print *, "LIST OF SORTING IN PROGRESS: ", want_to_sort(1:current_idx) + stop ! ERROR, STOP THE PROGRAM + end if + ! Fill secondary + do while (current_idx <= ninact + nact + nsec) + if (ras1_size > 0 .and. ras1_list(ras1_current_idx) == current_spinor_idx) then + if (ras1_size > ras1_current_idx) ras1_current_idx = ras1_current_idx + 1 ! Skip ras1_list(ras1_current_idx) + elseif (ras2_size > 0 .and. ras2_list(ras2_current_idx) == current_spinor_idx) then + if (ras2_size > ras2_current_idx) ras2_current_idx = ras2_current_idx + 1 ! Skip ras2_list(ras2_current_idx) + elseif (ras3_size > 0 .and. ras3_list(ras3_current_idx) == current_spinor_idx) then + if (ras3_size > ras3_current_idx) ras3_current_idx = ras3_current_idx + 1 ! Skip ras3_list(ras3_current_idx) + else + want_to_sort(current_idx) = original_orb_energy_order(current_spinor_idx) + current_idx = current_idx + 1 + end if + current_spinor_idx = current_spinor_idx + 1 ! Next spinor (energy order) + end do + end subroutine sort_list_energy_order_to_ras_order +end subroutine readorb_enesym_co diff --git a/src/solvall_A_ord_ty.f90 b/src/solvall_A_ord_ty.f90 index fdf0decb..656b4ff8 100644 --- a/src/solvall_A_ord_ty.f90 +++ b/src/solvall_A_ord_ty.f90 @@ -76,21 +76,19 @@ SUBROUTINE solvA_ord_ty(e0, e2a) datetmp1 = date0; datetmp0 = date0 Call timing(date0, tsec0, datetmp0, tsectmp0) tsectmp1 = tsectmp0 - if (rank == 0) then ! Process limits for output - write (*, *) ' ENTER solv A part' - write (*, *) ' nsymrpa', nsymrpa + if (rank == 0) then + print *, ' ENTER solv A part' + print *, ' nsymrpa', nsymrpa end if Allocate (v(ninact, nact, nact, nact)) Call memplus(KIND(v), SIZE(v), 2) - if (rank == 0) then ! Process limits for output - write (*, *) 'before vAmat' - end if + if (rank == 0) print *, 'before vAmat' #ifdef HAVE_MPI call MPI_Barrier(MPI_COMM_WORLD, ierr) #endif - if (rank == 0) write (*, *) 'end before v matrices' + if (rank == 0) print *, 'end before v matrices' Call timing(datetmp1, tsectmp1, datetmp0, tsectmp0) datetmp1 = datetmp0 tsectmp1 = tsectmp0 @@ -114,17 +112,18 @@ 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 -100 End do + End do End do End do dimn = ixyz - If (dimn == 0) goto 1000 + If (dimn == 0) cycle ! Go to the next isym. Allocate (indsym(3, dimn)); Call memplus(KIND(indsym), SIZE(indsym), 1) @@ -141,6 +140,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 @@ -148,27 +148,21 @@ SUBROUTINE solvA_ord_ty(e0, e2a) indsym(3, ixyz) = iz End if -200 End do + End do End do End do - if (rank == 0) then ! Process limits for output - write (*, *) 'isym, dimn', isym, dimn - end if + if (rank == 0) print *, 'isym, dimn', isym, dimn Allocate (sc(dimn, dimn)); Call memplus(KIND(sc), SIZE(sc), 2) sc = 0.0d+00 ! sr N*N - if (rank == 0) then ! Process limits for output - write (*, *) 'before sAmat' - end if + if (rank == 0) print *, 'before sAmat' Call timing(datetmp1, tsectmp1, datetmp0, tsectmp0) datetmp1 = datetmp0 tsectmp1 = tsectmp0 Call sAmat(dimn, indsym, sc) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - if (rank == 0) then ! Process limits for output - write (*, *) 'sc matrix is obtained normally' - end if + if (rank == 0) print *, 'sc matrix is obtained normally' Call timing(datetmp1, tsectmp1, datetmp0, tsectmp0) datetmp1 = datetmp0 tsectmp1 = tsectmp0 @@ -179,17 +173,13 @@ SUBROUTINE solvA_ord_ty(e0, e2a) Allocate (sc0(dimn, dimn)); Call memplus(KIND(sc0), SIZE(sc0), 2) sc0 = sc - if (rank == 0) then ! Process limits for output - write (*, *) 'before cdiag' - end if + if (rank == 0) print *, 'before cdiag' Call timing(datetmp1, tsectmp1, datetmp0, tsectmp0) datetmp1 = datetmp0 tsectmp1 = tsectmp0 Call cdiag(sc, dimn, dimm, ws, thresd, cutoff) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - if (rank == 0) then ! Process limits for output - write (*, *) 'after sc cdiag' - end if + if (rank == 0) print *, 'after sc cdiag' Call timing(datetmp1, tsectmp1, datetmp0, tsectmp0) datetmp1 = datetmp0 tsectmp1 = tsectmp0 @@ -199,38 +189,28 @@ SUBROUTINE solvA_ord_ty(e0, e2a) 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 + cycle ! Go to the next isym. End if If (debug) then - if (rank == 0) then ! Process limits for output - write (*, *) 'Check whether U*SU is diagonal' - end if + if (rank == 0) print *, 'Check whether U*SU is diagonal' Call checkdgc(dimn, sc0, sc, ws) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - if (rank == 0) then ! Process limits for output - write (*, *) 'Check whether U*SU is diagonal END' - end if + if (rank == 0) print *, 'Check whether U*SU is diagonal END' End if - if (rank == 0) then ! Process limits for output - write (*, *) 'OK cdiag', dimn, dimm - end if + if (rank == 0) print *, 'OK cdiag', dimn, dimm Allocate (bc(dimn, dimn)); Call memplus(KIND(bc), SIZE(bc), 2) ! br N*N bc = 0.0d+00 - if (rank == 0) then ! Process limits for output - write (*, *) 'before bAmat' - end if + if (rank == 0) print *, 'before bAmat' Call timing(datetmp1, tsectmp1, datetmp0, tsectmp0) datetmp1 = datetmp0 tsectmp1 = tsectmp0 Call bAmat(dimn, sc0, indsym, bc) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - if (rank == 0) then ! Process limits for output - write (*, *) 'bc matrix is obtained normally' - end if + if (rank == 0) print *, 'bc matrix is obtained normally' Call timing(datetmp1, tsectmp1, datetmp0, tsectmp0) datetmp1 = datetmp0 tsectmp1 = tsectmp0 @@ -241,26 +221,20 @@ SUBROUTINE solvA_ord_ty(e0, e2a) uc(:, :) = 0.0d+00 wsnew(:) = 0.0d+00 - if (rank == 0) then ! Process limits for output - write (*, *) 'before ccutoff' - end if + if (rank == 0) print *, 'before ccutoff' Call timing(datetmp1, tsectmp1, datetmp0, tsectmp0) datetmp1 = datetmp0 tsectmp1 = tsectmp0 Call ccutoff(sc, ws, dimn, dimm, uc, wsnew) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - if (rank == 0) then ! Process limits for output - write (*, *) 'OK ccutoff' - end if + if (rank == 0) print *, 'OK ccutoff' Call timing(datetmp1, tsectmp1, datetmp0, tsectmp0) datetmp1 = datetmp0 tsectmp1 = tsectmp0 deallocate (sc); Call memminus(KIND(sc), SIZE(sc), 2) deallocate (ws); Call memminus(KIND(ws), SIZE(ws), 1) - if (rank == 0) then ! Process limits for output - write (*, *) 'before ucramda_s_half' - end if + if (rank == 0) print *, 'before ucramda_s_half' Call timing(datetmp1, tsectmp1, datetmp0, tsectmp0) datetmp1 = datetmp0 tsectmp1 = tsectmp0 @@ -268,9 +242,7 @@ SUBROUTINE solvA_ord_ty(e0, e2a) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ deallocate (wsnew); Call memminus(KIND(wsnew), SIZE(wsnew), 1) - if (rank == 0) then ! Process limits for output - write (*, *) 'ucrams half OK' - end if + if (rank == 0) print *, 'ucrams half OK' Call timing(datetmp1, tsectmp1, datetmp0, tsectmp0) datetmp1 = datetmp0 tsectmp1 = tsectmp0 @@ -283,16 +255,16 @@ SUBROUTINE solvA_ord_ty(e0, e2a) bc1 = MATMUL(bc0, uc) If (debug) then - if (rank == 0) then ! Process limits for output - write (*, *) 'Check whether bc1 is hermite or not' + if (rank == 0) then + print *, '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) + print '(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' + print *, 'Check whether bc1 is hermite or not END' end if End if @@ -303,42 +275,32 @@ SUBROUTINE solvA_ord_ty(e0, e2a) Allocate (wb(dimm)); Call memplus(KIND(wb), SIZE(wb), 1) - if (rank == 0) then ! Process limits for output - write (*, *) 'bC matrix is transrated to bc1(M*M matrix)!' - end if + if (rank == 0) print *, '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 - if (rank == 0) then ! Process limits for output - write (*, *) 'before cdiag' - end if + if (rank == 0) print *, 'before cdiag' Call timing(datetmp1, tsectmp1, datetmp0, tsectmp0) datetmp1 = datetmp0 tsectmp1 = tsectmp0 Call cdiag(bc1, dimm, dammy, wb, thresd, cutoff) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - if (rank == 0) then ! Process limits for output - write (*, *) 'end cdiag' - end if + if (rank == 0) print *, 'end cdiag' Call timing(datetmp1, tsectmp1, datetmp0, tsectmp0) datetmp1 = datetmp0 tsectmp1 = tsectmp0 If (debug) then - if (rank == 0) then ! Process limits for output - write (*, *) 'Check whether bc is really diagonalized or not' - end if + if (rank == 0) print *, 'Check whether bc is really diagonalized or not' Call timing(datetmp1, tsectmp1, datetmp0, tsectmp0) datetmp1 = datetmp0 tsectmp1 = tsectmp0 Call checkdgc(dimm, bc0, bc1, wb) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - if (rank == 0) then ! Process limits for output - write (*, *) 'Check whether bc is really diagonalized or not END' - end if + if (rank == 0) print *, 'Check whether bc is really diagonalized or not END' Call timing(datetmp1, tsectmp1, datetmp0, tsectmp0) datetmp1 = datetmp0 tsectmp1 = tsectmp0 @@ -346,9 +308,7 @@ SUBROUTINE solvA_ord_ty(e0, e2a) End if deallocate (bc0); Call memminus(KIND(bc0), SIZE(bc0), 2) - if (rank == 0) then ! Process limits for output - write (*, *) 'bC1 matrix is diagonalized!' - end if + if (rank == 0) print *, 'bC1 matrix is diagonalized!' e2 = 0.0d+00 @@ -381,9 +341,7 @@ SUBROUTINE solvA_ord_ty(e0, e2a) End if End do - if (rank == 0) then ! Process limits for output - write (*, '("e2a(",I3,") = ",E20.10," a.u.")') isym, e2(isym) - end if + if (rank == 0) print '("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) @@ -391,27 +349,23 @@ SUBROUTINE solvA_ord_ty(e0, e2a) Deallocate (indsym); Call memminus(KIND(indsym), SIZE(indsym), 2) e2a = e2a + e2(isym) - if (rank == 0) then ! Process limits for output - write (*, *) 'End e2(isym) add' - end if + if (rank == 0) print *, 'End e2(isym) add' Call timing(datetmp1, tsectmp1, datetmp0, tsectmp0) datetmp1 = datetmp0 tsectmp1 = tsectmp0 -1000 End do ! isym + End do ! isym - if (rank == 0) then ! Process limits for output - write (*, '("e2a = ",E20.10," a.u.")') e2a + if (rank == 0) then + print '("e2a = ",E20.10," a.u.")', e2a - write (*, '("sumc2,a = ",E20.10)') sumc2local + print '("sumc2,a = ",E20.10)', sumc2local end if sumc2 = sumc2 + sumc2local Deallocate (v); Call memminus(KIND(v), SIZE(v), 2) continue - if (rank == 0) then ! Process limits for output - write (*, *) 'end solvA_ord_ty' - end if + if (rank == 0) print *, 'end solvA_ord_ty' end ! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= @@ -513,7 +467,7 @@ SUBROUTINE bAmat(dimn, sc, indsym, bc) ! Assume C1 molecule, overlap matrix B in bc(:, :) = 0.0d+00 if (rank == 0) then - write (*, *) 'bAmat loop: dimn', dimn + print *, 'bAmat loop: dimn', dimn end if !$OMP parallel do private(ix,iy,iz,jx,jy,jz,it,iu,iv,jt,ju,jv,e,j,iw,jw,denr,deni,den) Do i = rank + 1, dimn, nprocs ! MPI parallelization (Distributed loop: static scheduling, per nprocs) @@ -566,9 +520,7 @@ SUBROUTINE bAmat(dimn, sc, indsym, bc) ! Assume C1 molecule, overlap matrix B in call MPI_Allreduce(MPI_IN_PLACE, bc(1, 1), dimn**2, MPI_COMPLEX16, MPI_SUM, MPI_COMM_WORLD, ierr) #endif - if (rank == 0) then ! Process limits for output - write (*, *) 'bAmat is ended' - end if + if (rank == 0) print *, 'bAmat is ended' End subroutine bAmat ! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= @@ -604,8 +556,8 @@ SUBROUTINE vAmat_ord_ty(v) integer :: it, iu, iv, ii, ip integer :: jt, ju, jv, ji, jp - integer :: i, j, k, l, count, dim(nsymrpa) - integer :: dim2(nsymrpa), isym, i0, syma, symb, symc + integer :: i, j, k, l, dim(nsymrpa) + integer :: dim2(nsymrpa), isym, i0, syma, symb, symc, iostat integer, allocatable :: indt(:, :), indu(:, :), indv(:, :) integer, allocatable :: ind2u(:, :), ind2v(:, :) integer :: datetmp0, datetmp1 @@ -630,7 +582,7 @@ SUBROUTINE vAmat_ord_ty(v) ! effh is stored in memory while reading int2. ! ! effh(p,i) = h(pi)+ SIGUMA_k:inact{(pi|kk)-(pk|ki)} - if (rank == 0) write (*, *) 'Enter vAmat. Please ignore timer under this line.' + if (rank == 0) print *, 'Enter vAmat. Please ignore timer under this line.' datetmp1 = date0; datetmp0 = date0 Call timing(date0, tsec0, datetmp0, tsectmp0) tsectmp1 = tsectmp0 @@ -672,7 +624,7 @@ SUBROUTINE vAmat_ord_ty(v) End do !$OMP end parallel do do isym = 1, nsymrpa - if (rank == 0) write (*, *) 'solvA: isym, dim(isym)', isym, dim(isym) + if (rank == 0) print *, 'solvA: isym, dim(isym)', isym, dim(isym) end do Allocate (ind2u(nact**2, nsymrpa)); Call memplus(KIND(ind2u), SIZE(ind2u), 1) Allocate (ind2v(nact**2, nsymrpa)); Call memplus(KIND(ind2v), SIZE(ind2v), 1) @@ -700,9 +652,7 @@ SUBROUTINE vAmat_ord_ty(v) !$OMP end parallel do Do isym = 1, nsymrpa - if (rank == 0) then ! Process limits for output - write (*, '(2I4)') dim2(isym), isym - end if + if (rank == 0) print '(2I4)', dim2(isym), isym End do !$OMP parallel do private(ji,it,jt,cint1) Do ii = rank + 1, ninact, nprocs @@ -724,11 +674,17 @@ SUBROUTINE vAmat_ord_ty(v) !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ open (1, file=a1int, status='old', form='unformatted') - if (rank == 0) then ! Process limits for output - write (*, *) 'open A1int' - end if - -30 read (1, err=10, end=20) i, j, k, l, cint2 ! (ij|kl) + 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' + 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 !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ! V(tuv,i)= - SIGUMA_p,q,r:act <0|EvuEptEqr|0>(pi|qr) @@ -738,41 +694,41 @@ SUBROUTINE vAmat_ord_ty(v) !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ! write(*,'("TYPE 1 ",4I4,2E20.10)')i,j,k,l,cint2 - isym = irpmo(j) - !$OMP parallel do private(it,iu,iv,jt,ju,jv,dr,di,d) - 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 + isym = irpmo(j) + !$OMP parallel do private(it,iu,iv,jt,ju,jv,dr,di,d) + 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, it, k, l, dr, di) - d = DCMPLX(dr, di) - v(j, it, iu, iv) = v(j, it, iu, iv) - cint2*d + Call dim3_density(iv, iu, i, it, k, l, dr, di) + d = DCMPLX(dr, di) + v(j, it, iu, iv) = v(j, it, iu, iv) - cint2*d - End do - !$OMP end parallel do + End do + !$OMP end parallel do - isym = MULTB_D(irpmo(i + ninact), irpmo(j)) ! j coresponds to ii, i coresponds to it + isym = MULTB_D(irpmo(i + ninact), irpmo(j)) ! j coresponds to ii, i coresponds to it - !$OMP parallel do private(iu,iv,ju,jv,dr,di,d) - Do i0 = 1, dim2(isym) - iu = ind2u(i0, isym) - iv = ind2v(i0, isym) - ju = iu + ninact - jv = iv + ninact + !$OMP parallel do private(iu,iv,ju,jv,dr,di,d) + 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, l, dr, di) - d = DCMPLX(dr, di) - v(j, i, iu, iv) = v(j, i, iu, iv) + cint2*d - End do - !$OMP end parallel do + Call dim2_density(iv, iu, k, l, dr, di) + d = DCMPLX(dr, di) + v(j, i, iu, iv) = v(j, i, iu, iv) + cint2*d + End do + !$OMP end parallel do - goto 30 + end do -20 close (1) + close (1) Call timing(datetmp1, tsectmp1, datetmp0, tsectmp0) datetmp1 = datetmp0 @@ -780,30 +736,34 @@ SUBROUTINE vAmat_ord_ty(v) 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 - + 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' + 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)} ! !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - if (k == l .and. j /= k) then ! (PI|KK) type + if (k == l .and. j /= k) then ! (PI|KK) type - effh(i, j) = effh(i, j) + cint2 + effh(i, j) = effh(i, j) + cint2 - elseif (j == k .and. k /= l) then ! (PK|KI) type + elseif (j == k .and. k /= l) then ! (PK|KI) type - effh(i, l) = effh(i, l) - cint2 + effh(i, l) = effh(i, l) - cint2 - end if - - goto 300 + end if + end do -200 close (1) - if (rank == 0) then ! Process limits for output - write (*, *) 'reading A2int2 is over' - end if + close (1) + if (rank == 0) print *, 'reading A2int2 is over' #ifdef HAVE_MPI call MPI_Allreduce(MPI_IN_PLACE, effh(1, 1), nact*ninact, MPI_COMPLEX16, MPI_SUM, MPI_COMM_WORLD, ierr) @@ -842,12 +802,7 @@ SUBROUTINE vAmat_ord_ty(v) End do !ii !$OMP end parallel do - goto 100 - -10 write (*, *) 'error while opening file Aint'; goto 1000 -100 continue - -1000 if (rank == 0) write (*, *) 'vAmat_ord_ty is ended' + if (rank == 0) print *, 'vAmat_ord_ty is ended' deallocate (indt); Call memminus(KIND(indt), SIZE(indt), 1) deallocate (indu); Call memminus(KIND(indu), SIZE(indu), 1) @@ -858,8 +813,9 @@ SUBROUTINE vAmat_ord_ty(v) #ifdef HAVE_MPI call MPI_Allreduce(MPI_IN_PLACE, v(1, 1, 1, 1), ninact*nact*nact*nact, & MPI_COMPLEX16, MPI_SUM, MPI_COMM_WORLD, ierr) + + if (rank == 0) print *, 'end allreduce vAmat' #endif - if (rank == 0) write (*, *) 'end allreduce vAmat' Call timing(datetmp1, tsectmp1, datetmp0, tsectmp0) datetmp1 = datetmp0 tsectmp1 = tsectmp0 diff --git a/src/solvall_B_ord_ty.f90 b/src/solvall_B_ord_ty.f90 index 633a7928..33980a5a 100644 --- a/src/solvall_B_ord_ty.f90 +++ b/src/solvall_B_ord_ty.f90 @@ -27,7 +27,7 @@ SUBROUTINE solvB_ord_ty(e0, e2b) complex*16, allocatable :: bc0(:, :), bc1(:, :), v(:, :, :), vc(:), vc1(:) integer, allocatable :: ii0(:), ij0(:), iij(:, :) - integer :: nij + integer :: nij, count logical :: cutoff integer :: j, i, syma, isym, i0 @@ -77,9 +77,9 @@ SUBROUTINE solvB_ord_ty(e0, e2b) datetmp1 = date0; datetmp0 = date0 Call timing(date0, tsec0, datetmp0, tsectmp0) tsectmp1 = tsectmp0 - if (rank == 0) then ! Process limits for output - write (*, *) ' ENTER solv B part' - write (*, *) ' nsymrpa', nsymrpa + if (rank == 0) then + print *, ' ENTER solv B part' + print *, ' nsymrpa', nsymrpa end if i0 = 0 Do ii = 1, ninact @@ -109,7 +109,7 @@ SUBROUTINE solvB_ord_ty(e0, e2b) #ifdef HAVE_MPI call MPI_Barrier(MPI_COMM_WORLD, ierr) #endif - if (rank == 0) write (*, *) 'end before v matrices' + if (rank == 0) print *, 'end before v matrices' Call timing(datetmp1, tsectmp1, datetmp0, tsectmp0) datetmp1 = datetmp0 tsectmp1 = tsectmp0 @@ -136,10 +136,8 @@ SUBROUTINE solvB_ord_ty(e0, e2b) End do ! iu End do ! it - if (rank == 0) then ! Process limits for output - write (*, *) 'isym, dimn', isym, dimn - end if - If (dimn == 0) goto 1000 + if (rank == 0) print *, 'isym, dimn', isym, dimn + If (dimn == 0) cycle ! Go to the next isym. Allocate (indsym(2, dimn)); Call memplus(KIND(indsym), SIZE(indsym), 1) @@ -156,23 +154,19 @@ SUBROUTINE solvB_ord_ty(e0, e2b) indsym(1, dimn) = it indsym(2, dimn) = iu End if -200 End do ! iu + End do ! iu End do ! it Allocate (sc(dimn, dimn)); Call memplus(KIND(sc), SIZE(sc), 2) sc = 0.0d+00 ! sc N*N - if (rank == 0) then ! Process limits for output - write (*, *) 'before sBmat' - end if + if (rank == 0) print *, 'before sBmat' Call timing(datetmp1, tsectmp1, datetmp0, tsectmp0) datetmp1 = datetmp0 tsectmp1 = tsectmp0 Call sBmat(dimn, indsym, sc) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - if (rank == 0) then ! Process limits for output - write (*, *) 'sc matrix is obtained normally' - end if + if (rank == 0) print *, 'sc matrix is obtained normally' Call timing(datetmp1, tsectmp1, datetmp0, tsectmp0) datetmp1 = datetmp0 tsectmp1 = tsectmp0 @@ -183,16 +177,18 @@ SUBROUTINE solvB_ord_ty(e0, e2b) Allocate (sc0(dimn, dimn)); Call memplus(KIND(sc0), SIZE(sc0), 2) sc0 = sc - if (rank == 0) then ! Process limits for output - write (*, *) 'before cdiag' - end if + if (rank == 0) print *, 'before cdiag' Call timing(datetmp1, tsectmp1, datetmp0, tsectmp0) datetmp1 = datetmp0 tsectmp1 = tsectmp0 Call cdiag(sc, dimn, dimm, ws, thresd, cutoff) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - if (rank == 0) then ! Process limits for output - write (*, *) 'after s cdiag, new dimension is', dimm + if (rank == 0) print *, 'after s cdiag, new dimension is', dimm + if (rank == 0) then + print *, 'ws', ws + do count = 1, dimn + print *, count, sc(count, count) + end do end if Call timing(datetmp1, tsectmp1, datetmp0, tsectmp0) datetmp1 = datetmp0 @@ -202,75 +198,57 @@ SUBROUTINE solvB_ord_ty(e0, e2b) 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 + cycle ! Go to the next isym. End if Allocate (bc(dimn, dimn)); Call memplus(KIND(bc), SIZE(bc), 2) ! br N*N bc = 0.0d+00 - if (rank == 0) then ! Process limits for output - write (*, *) 'before bBmat' - end if + if (rank == 0) print *, 'before bBmat' Call timing(datetmp1, tsectmp1, datetmp0, tsectmp0) datetmp1 = datetmp0 tsectmp1 = tsectmp0 Call bBmat(e0, dimn, sc0, indsym, bc) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - if (rank == 0) then ! Process limits for output - write (*, *) 'bc matrix is obtained normally' - end if + if (rank == 0) print *, 'bc matrix is obtained normally' Call timing(datetmp1, tsectmp1, datetmp0, tsectmp0) datetmp1 = datetmp0 tsectmp1 = tsectmp0 If (debug) then - if (rank == 0) then ! Process limits for output - write (*, *) 'Check whether U*SU is diagonal' - end if + if (rank == 0) print *, 'Check whether U*SU is diagonal' Call checkdgc(dimn, sc0, sc, ws) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - if (rank == 0) then ! Process limits for output - write (*, *) 'Check whether U*SU is diagonal END' - end if + if (rank == 0) print *, 'Check whether U*SU is diagonal END' End if deallocate (sc0); Call memminus(KIND(sc0), SIZE(sc0), 2) - if (rank == 0) then ! Process limits for output - write (*, *) 'OK cdiag', dimn, dimm - end if + if (rank == 0) print *, '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 - if (rank == 0) then ! Process limits for output - write (*, *) 'before ccutoff' - end if + if (rank == 0) print *, 'before ccutoff' Call timing(datetmp1, tsectmp1, datetmp0, tsectmp0) datetmp1 = datetmp0 tsectmp1 = tsectmp0 Call ccutoff(sc, ws, dimn, dimm, uc, wsnew) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - if (rank == 0) then ! Process limits for output - write (*, *) 'OK ccutoff' - end if + if (rank == 0) print *, 'OK ccutoff' Call timing(datetmp1, tsectmp1, datetmp0, tsectmp0) datetmp1 = datetmp0 tsectmp1 = tsectmp0 deallocate (sc); Call memminus(KIND(sc), SIZE(sc), 2) deallocate (ws); Call memminus(KIND(ws), SIZE(ws), 1) - if (rank == 0) then ! Process limits for output - write (*, *) 'before ucramda_s_half' - end if + if (rank == 0) print *, 'before ucramda_s_half' Call timing(datetmp1, tsectmp1, datetmp0, tsectmp0) datetmp1 = datetmp0 tsectmp1 = tsectmp0 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) - if (rank == 0) then ! Process limits for output - write (*, *) 'ucrams half OK' - end if + if (rank == 0) print *, 'ucrams half OK' Call timing(datetmp1, tsectmp1, datetmp0, tsectmp0) datetmp1 = datetmp0 tsectmp1 = tsectmp0 @@ -284,21 +262,15 @@ SUBROUTINE solvB_ord_ty(e0, e2b) If (debug) then - if (rank == 0) then ! Process limits for output - write (*, *) 'Check whether bc1 is hermite or not' - end if + if (rank == 0) print *, '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 - if (rank == 0) then ! Process limits for output - write (*, '(2I4,2E15.7)') i, j, bc1(i, j) - bc1(j, i) - end if + if (rank == 0) print '(2I4,2E15.7)', i, j, bc1(i, j) - bc1(j, i) End if End do End do - if (rank == 0) then ! Process limits for output - write (*, *) 'Check whether bc1 is hermite or not END' - end if + if (rank == 0) print *, 'Check whether bc1 is hermite or not END' End if deallocate (bc); Call memminus(KIND(bc), SIZE(bc), 2) @@ -308,42 +280,30 @@ SUBROUTINE solvB_ord_ty(e0, e2b) Allocate (wb(dimm)); Call memplus(KIND(wb), SIZE(wb), 1) - if (rank == 0) then ! Process limits for output - write (*, *) 'bC matrix is transrated to bc1(M*M matrix)!' - end if + if (rank == 0) print *, '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 - if (rank == 0) then ! Process limits for output - write (*, *) 'before cdiag' - end if + if (rank == 0) print *, 'before cdiag' Call timing(datetmp1, tsectmp1, datetmp0, tsectmp0) datetmp1 = datetmp0 tsectmp1 = tsectmp0 Call cdiag(bc1, dimm, dammy, wb, thresd, cutoff) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - if (rank == 0) then ! Process limits for output - write (*, *) 'end cdiag' - end if + if (rank == 0) print *, 'end cdiag' Call timing(datetmp1, tsectmp1, datetmp0, tsectmp0) datetmp1 = datetmp0 tsectmp1 = tsectmp0 If (debug) then - if (rank == 0) then ! Process limits for output - write (*, *) 'Check whether bc is really diagonalized or not' - end if + if (rank == 0) print *, 'Check whether bc is really diagonalized or not' Call checkdgc(dimm, bc0, bc1, wb) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - if (rank == 0) then ! Process limits for output - write (*, *) 'Check whether bc is really diagonalized or not END' - end if + if (rank == 0) print *, 'Check whether bc is really diagonalized or not END' End if deallocate (bc0); Call memminus(KIND(bc0), SIZE(bc0), 2) - if (rank == 0) then ! Process limits for output - write (*, *) 'bC1 matrix is diagonalized!' - end if + if (rank == 0) print *, 'bC1 matrix is diagonalized!' e2 = 0.0d+00 Do i0 = 1, nij @@ -382,27 +342,23 @@ SUBROUTINE solvB_ord_ty(e0, e2b) End if End do !i0 - if (rank == 0) then ! Process limits for output - write (*, '("e2b(",I3,") = ",E20.10," a.u.")') isym, e2(isym) - end if + if (rank == 0) print '("e2b(",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) -1000 e2b = e2b + e2(isym) - if (rank == 0) then ! Process limits for output - write (*, *) 'End e2(isym) add' - end if + e2b = e2b + e2(isym) + if (rank == 0) print *, 'End e2(isym) add' Call timing(datetmp1, tsectmp1, datetmp0, tsectmp0) datetmp1 = datetmp0 tsectmp1 = tsectmp0 End do ! isym - if (rank == 0) then ! Process limits for output - write (*, '("e2b = ",E20.10," a.u.")') e2b - write (*, '("sumc2,b = ",E20.10)') sumc2local + if (rank == 0) then + print '("e2b = ",E20.10," a.u.")', e2b + print '("sumc2,b = ",E20.10)', sumc2local end if sumc2 = sumc2 + sumc2local @@ -412,9 +368,7 @@ SUBROUTINE solvB_ord_ty(e0, e2b) deallocate (v); Call memminus(KIND(v), SIZE(v), 2) continue - if (rank == 0) then ! Process limits for output - write (*, *) 'end solvB_ord_ty' - end if + if (rank == 0) print *, 'end solvB_ord_ty' end ! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= @@ -522,9 +476,7 @@ SUBROUTINE bBmat(e0, dimn, sc, indsym, bc) ! Assume C1 molecule, overlap matrix bc(:, :) = 0.0d+00 - if (rank == 0) then ! Process limits for output - write (*, *) 'B space Bmat iroot=', iroot - end if + if (rank == 0) print *, 'B space Bmat iroot=', iroot !$OMP parallel do schedule(dynamic,1) private(ix,iy,jx,jy,it,iu,jt,ju,e,j,iw,jw,denr,deni,den) Do i = rank + 1, dimn, nprocs ! MPI parallelization (Distributed loop: static scheduling, per nprocs) @@ -599,9 +551,7 @@ SUBROUTINE bBmat(e0, dimn, sc, indsym, bc) ! Assume C1 molecule, overlap matrix else call MPI_Reduce(bc(1, 1), bc(1, 1), dimn**2, MPI_COMPLEX16, MPI_SUM, 0, MPI_COMM_WORLD, ierr) end if - if (rank == 0) then ! Process limits for output - write (*, *) 'bBmat is ended' - end if + if (rank == 0) print *, 'bBmat is ended' #endif End subroutine bBmat @@ -632,15 +582,26 @@ 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 + integer :: it, jt, ju, iu, iostat v = 0.0d+00 open (1, file=bint, status='old', form='unformatted') ! (21|21) stored (ti|uj) i > j + do + read (1, iostat=iostat) i, j, k, l, cint2 ! (ij|kl) -30 read (1, err=10, end=20) 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 + 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) goto 30 + if (j <= l) cycle ! Read the next line if j <= l !------------------------------------------------------------------------------------------------ ! i > j @@ -653,55 +614,47 @@ SUBROUTINE vBmat_ord_ty(nij, iij, v) ! !------------------------------------------------------------------------------------------------ - tij = iij(j, l) + 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) - !$OMP parallel do schedule(dynamic,1) private(dr,di,dens,iu,ju) - Do it = 1, nact - - Call dim1_density(k, it, dr, di) - dens = DCMPLX(dr, di) - v(tij, it, i) = v(tij, it, i) + cint2*dens - v(tij, i, it) = v(tij, i, it) - cint2*dens + ! Term 3 ! + (ti|uj) - (ui|tj) (i > j) - Call dim1_density(i, it, dr, di) - dens = DCMPLX(dr, di) - v(tij, it, k) = v(tij, it, k) - cint2*dens + v(tij, i, k) = v(tij, i, k) + cint2 ! + (ti|uj) + v(tij, k, i) = v(tij, k, i) - cint2 ! - (ui|tj) - ! Term1 ! SIGUMA_p,q:active <0|EptEqu|0>(pi|qj) ! term1 - ! ================== - ! loop for t and u + ! 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) + Do it = 1, nact - Do iu = 1, it - 1 - ju = iu + ninact - Call dim2_density(i, it, k, iu, dr, di) + Call dim1_density(k, it, dr, di) dens = DCMPLX(dr, di) - v(tij, it, iu) = v(tij, it, iu) + cint2*dens - End do + v(tij, it, i) = v(tij, it, i) + cint2*dens + v(tij, i, it) = v(tij, i, it) - cint2*dens - End do - !$OMP end parallel do + Call dim1_density(i, it, dr, di) + dens = DCMPLX(dr, di) + v(tij, it, k) = v(tij, it, k) - cint2*dens - goto 30 + ! Term1 ! SIGUMA_p,q:active <0|EptEqu|0>(pi|qj) ! term1 + ! ================== + ! loop for t and u -20 close (1) - if (rank == 0) then ! Process limits for output - write (*, *) 'reading int2 is over' - end if - goto 100 + 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 + End do -10 write (*, *) 'error while opening file Bint'; goto 100 + End do + !$OMP end parallel do + end do -100 if (rank == 0) write (*, *) 'vBmat_ord_ty is ended' + close (1) + if (rank == 0) print *, 'vBmat_ord_ty is ended' #ifdef HAVE_MPI call MPI_Allreduce(MPI_IN_PLACE, v(1, 1, 1), nij*nact**2, MPI_COMPLEX16, MPI_SUM, MPI_COMM_WORLD, ierr) diff --git a/src/solvall_C_ord_ty.f90 b/src/solvall_C_ord_ty.f90 index 6677d054..82f2990d 100644 --- a/src/solvall_C_ord_ty.f90 +++ b/src/solvall_C_ord_ty.f90 @@ -72,22 +72,20 @@ SUBROUTINE solvC_ord_ty(e0, e2c) datetmp1 = date0; datetmp0 = date0 Call timing(date0, tsec0, datetmp0, tsectmp0) tsectmp1 = tsectmp0 - if (rank == 0) then ! Process limits for output - write (*, *) ' ENTER solv C part' - write (*, *) ' nsymrpa', nsymrpa + if (rank == 0) then + print *, ' ENTER solv C part' + print *, ' nsymrpa', nsymrpa end if Allocate (v(nsec, nact, nact, nact)) #ifdef HAVE_MPI call MPI_Barrier(MPI_COMM_WORLD, ierr) #endif - if (rank == 0) write (*, *) 'end before v matrices' + if (rank == 0) print *, 'end before v matrices' Call timing(datetmp1, tsectmp1, datetmp0, tsectmp0) datetmp1 = datetmp0 tsectmp1 = tsectmp0 Call vCmat_ord_ty(v) - if (rank == 0) then ! Process limits for output - write (*, *) 'come' - end if + if (rank == 0) print *, 'come' Call timing(datetmp1, tsectmp1, datetmp0, tsectmp0) datetmp1 = datetmp0 tsectmp1 = tsectmp0 @@ -113,13 +111,13 @@ SUBROUTINE solvC_ord_ty(e0, e2c) ixyz = ixyz + 1 End if -100 End do + End do End do End do dimn = ixyz - If (dimn == 0) goto 1000 + If (dimn == 0) cycle ! Go to the next isym Allocate (indsym(3, dimn)) indsym = 0 @@ -144,27 +142,21 @@ SUBROUTINE solvC_ord_ty(e0, e2c) indsym(3, ixyz) = iz End if -200 End do + End do End do End do - if (rank == 0) then ! Process limits for output - write (*, *) 'isym, dimn', isym, dimn - end if + if (rank == 0) print *, 'isym, dimn', isym, dimn Allocate (sc(dimn, dimn)) sc = 0.0d+00 ! sr N*N - if (rank == 0) then ! Process limits for output - write (*, *) 'before sCmat' - end if + if (rank == 0) print *, 'before sCmat' Call timing(datetmp1, tsectmp1, datetmp0, tsectmp0) datetmp1 = datetmp0 tsectmp1 = tsectmp0 Call sCmat(dimn, indsym, sc) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - if (rank == 0) then ! Process limits for output - write (*, *) 'sC matrix is obtained normally' - end if + if (rank == 0) print *, 'sC matrix is obtained normally' Call timing(datetmp1, tsectmp1, datetmp0, tsectmp0) datetmp1 = datetmp0 tsectmp1 = tsectmp0 @@ -176,17 +168,15 @@ SUBROUTINE solvC_ord_ty(e0, e2c) Allocate (sc0(dimn, dimn)) sc0 = 0.0d+00 sc0 = sc - if (rank == 0) then ! Process limits for output - write (*, *) 'before cdiag' - end if + if (rank == 0) print *, 'before cdiag' Call timing(datetmp1, tsectmp1, datetmp0, tsectmp0) datetmp1 = datetmp0 tsectmp1 = tsectmp0 Call cdiag(sc, dimn, dimm, ws, thresd, cutoff) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - if (rank == 0) then ! Process limits for output - write (*, *) 'after sc cdiag' - write (*, *) 'after s cdiag, new dimension is', dimm + if (rank == 0) then + print *, 'after sc cdiag' + print *, 'after s cdiag, new dimension is', dimm end if Call timing(datetmp1, tsectmp1, datetmp0, tsectmp0) datetmp1 = datetmp0 @@ -196,30 +186,22 @@ SUBROUTINE solvC_ord_ty(e0, e2c) deallocate (sc0) deallocate (sc) deallocate (ws) - goto 1000 + cycle ! Go to the next isym End if If (debug) then - if (rank == 0) then ! Process limits for output - write (*, *) 'Check whether U*SU is diagonal' - end if + if (rank == 0) print *, 'Check whether U*SU is diagonal' Call checkdgc(dimn, sc0, sc, ws) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - if (rank == 0) then ! Process limits for output - write (*, *) 'Check whether U*SU is diagonal END' - end if + if (rank == 0) print *, 'Check whether U*SU is diagonal END' End if - if (rank == 0) then ! Process limits for output - write (*, *) 'OK cdiag', dimn, dimm - end if + if (rank == 0) print *, 'OK cdiag', dimn, dimm Allocate (bc(dimn, dimn)) ! br N*N bc = 0.0d+00 - if (rank == 0) then ! Process limits for output - write (*, *) 'before bCmat' - end if + if (rank == 0) print *, 'before bCmat' Call timing(datetmp1, tsectmp1, datetmp0, tsectmp0) datetmp1 = datetmp0 tsectmp1 = tsectmp0 @@ -228,9 +210,7 @@ SUBROUTINE solvC_ord_ty(e0, e2c) deallocate (sc0) - if (rank == 0) then ! Process limits for output - write (*, *) 'bC matrix is obtained normally' - end if + if (rank == 0) print *, 'bC matrix is obtained normally' Call timing(datetmp1, tsectmp1, datetmp0, tsectmp0) datetmp1 = datetmp0 tsectmp1 = tsectmp0 @@ -238,26 +218,20 @@ SUBROUTINE solvC_ord_ty(e0, e2c) Allocate (wsnew(dimm)) ! wnew M uc(:, :) = 0.0d+00 wsnew(:) = 0.0d+00 - if (rank == 0) then ! Process limits for output - write (*, *) 'before ccutoff' - end if + if (rank == 0) print *, 'before ccutoff' Call timing(datetmp1, tsectmp1, datetmp0, tsectmp0) datetmp1 = datetmp0 tsectmp1 = tsectmp0 Call ccutoff(sc, ws, dimn, dimm, uc, wsnew) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - if (rank == 0) then ! Process limits for output - write (*, *) 'OK ccutoff' - end if + if (rank == 0) print *, 'OK ccutoff' Call timing(datetmp1, tsectmp1, datetmp0, tsectmp0) datetmp1 = datetmp0 tsectmp1 = tsectmp0 deallocate (ws) deallocate (sc) - if (rank == 0) then ! Process limits for output - write (*, *) 'before ucramda_s_half' - end if + if (rank == 0) print *, 'before ucramda_s_half' Call timing(datetmp1, tsectmp1, datetmp0, tsectmp0) datetmp1 = datetmp0 tsectmp1 = tsectmp0 @@ -265,9 +239,7 @@ SUBROUTINE solvC_ord_ty(e0, e2c) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ deallocate (wsnew) - if (rank == 0) then ! Process limits for output - write (*, *) 'ucrams half OK' - end if + if (rank == 0) print *, 'ucrams half OK' Call timing(datetmp1, tsectmp1, datetmp0, tsectmp0) datetmp1 = datetmp0 tsectmp1 = tsectmp0 @@ -279,16 +251,16 @@ SUBROUTINE solvC_ord_ty(e0, e2c) bc1 = MATMUL(bc0, uc) If (debug) then - if (rank == 0) then ! Process limits for output - write (*, *) 'Check whether bc1 is hermite or not' + if (rank == 0) then + print *, '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) + print '(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' + print *, 'Check whether bc1 is hermite or not END' end if End if @@ -299,43 +271,31 @@ SUBROUTINE solvC_ord_ty(e0, e2c) Allocate (wb(dimm)) wb = 0.0d+00 - if (rank == 0) then ! Process limits for output - write (*, *) 'bC matrix is transrated to bc1(M*M matrix)!' - end if + if (rank == 0) print *, 'bC matrix is transrated to bc1(M*M matrix)!' Allocate (bc0(dimm, dimm)) bc0 = 0.0d+00 bc0 = bc1 - if (rank == 0) then ! Process limits for output - write (*, *) 'before cdiag' - end if + if (rank == 0) print *, 'before cdiag' Call timing(datetmp1, tsectmp1, datetmp0, tsectmp0) datetmp1 = datetmp0 tsectmp1 = tsectmp0 Call cdiag(bc1, dimm, dammy, wb, thresd, cutoff) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - if (rank == 0) then ! Process limits for output - write (*, *) 'end cdiag' - end if + if (rank == 0) print *, 'end cdiag' Call timing(datetmp1, tsectmp1, datetmp0, tsectmp0) datetmp1 = datetmp0 tsectmp1 = tsectmp0 If (debug) then - if (rank == 0) then ! Process limits for output - write (*, *) 'Check whether bc is really diagonalized or not' - end if + if (rank == 0) print *, 'Check whether bc is really diagonalized or not' Call checkdgc(dimm, bc0, bc1, wb) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - if (rank == 0) then ! Process limits for output - write (*, *) 'Check whether bc is really diagonalized or not END' - end if + if (rank == 0) print *, 'Check whether bc is really diagonalized or not END' End if deallocate (bc0) - if (rank == 0) then ! Process limits for output - write (*, *) 'bC1 matrix is diagonalized!' - end if + if (rank == 0) print *, 'bC1 matrix is diagonalized!' Do ia = 1, nsec ja = ia + ninact + nact @@ -365,33 +325,27 @@ SUBROUTINE solvC_ord_ty(e0, e2c) End do - if (rank == 0) then ! Process limits for output - write (*, '("e2c(",I3,") = ",E20.10," a.u.")') isym, e2(isym) - end if + if (rank == 0) print '("e2c(",I3,") = ",E20.10," a.u.")', isym, e2(isym) deallocate (bc1) deallocate (indsym) Deallocate (uc) Deallocate (wb) e2c = e2c + e2(isym) - if (rank == 0) then ! Process limits for output - write (*, *) 'End e2(isym) add' - end if + if (rank == 0) print *, 'End e2(isym) add' Call timing(datetmp1, tsectmp1, datetmp0, tsectmp0) datetmp1 = datetmp0 tsectmp1 = tsectmp0 -1000 End do ! isym + End do ! isym - if (rank == 0) then ! Process limits for output - write (*, '("e2c = ",E20.10," a.u.")') e2c - write (*, '("sumc2,c = ",E20.10)') sumc2local + if (rank == 0) then + print '("e2c = ",E20.10," a.u.")', e2c + print '("sumc2,c = ",E20.10)', sumc2local end if sumc2 = sumc2 + sumc2local continue - if (rank == 0) then ! Process limits for output - write (*, *) 'end solvC_ord_ty' - end if + if (rank == 0) print *, 'end solvC_ord_ty' end ! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= @@ -438,9 +392,9 @@ SUBROUTINE sCmat(dimn, indsym, sc) ! Assume C1 molecule, overlap matrix S in spa sc(i, j) = DCMPLX(a, b) sc(j, i) = DCMPLX(a, -b) - if (rank == 0) then ! Process limits for output + if (rank == 0) then If (ABS(sc(i, j)) > 1.0d+00) then - write (*, '(2I4,2E20.10)') i, j, sc(i, j) + print '(2I4,2E20.10)', i, j, sc(i, j) End if end if End do !j @@ -492,9 +446,7 @@ SUBROUTINE bCmat(dimn, sc, indsym, bc) bc(:, :) = 0.0d+00 - if (rank == 0) then ! Process limits for output - write (*, *) 'C space Bmat iroot=', iroot - end if + if (rank == 0) print *, 'C space Bmat iroot=', iroot !$OMP parallel do schedule(dynamic,1) private(ix,iy,iz,jx,jy,jz,it,iu,iv,jt,ju,jv,e,j,iw,jw,denr,deni,den) Do i = rank + 1, dimn, nprocs ix = indsym(1, i) @@ -540,9 +492,7 @@ SUBROUTINE bCmat(dimn, sc, indsym, bc) call MPI_Reduce(bc(1, 1), bc(1, 1), dimn**2, MPI_COMPLEX16, MPI_SUM, 0, MPI_COMM_WORLD, ierr) end if #endif - if (rank == 0) then ! Process limits for output - write (*, *) 'bCmat is ended' - end if + if (rank == 0) print *, 'bCmat is ended' End subroutine bCmat ! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= @@ -580,7 +530,7 @@ SUBROUTINE vCmat_ord_ty(v) integer, allocatable :: indt(:, :), indu(:, :), indv(:, :) integer :: it, iu, iv, ia, ip integer :: jt, ju, jv, ja, jp - integer :: i0 + integer :: i0, iostat integer :: datetmp0, datetmp1 real(8) :: tsectmp0, tsectmp1 !^~^~^~^~^~^~^~^~^~^~^~^~^~^~^~^~^~^~^~^~^~^~^~^~^~^~^~^~^~^~^~^~^~^~^~^~^~^~^~^~^~^~^~^~^~^~^~^~ @@ -608,7 +558,7 @@ SUBROUTINE vCmat_ord_ty(v) ! !^~^~^~^~^~^~^~^~^~^~^~^~^~^~^~^~^~^~^~^~^~^~^~^~^~^~^~^~^~^~^~^~^~^~^~^~^~^~^~^~^~^~^~^~^~^~^~^~ - if (rank == 0) write (*, *) 'Enter vCmat. Please ignore timer under this line.' + if (rank == 0) print *, 'Enter vCmat. Please ignore timer under this line.' datetmp1 = date0; datetmp0 = date0 Call timing(date0, tsec0, datetmp0, tsectmp0) tsectmp1 = tsectmp0 @@ -646,13 +596,13 @@ SUBROUTINE vCmat_ord_ty(v) indu(dim(isym), isym) = iu indv(dim(isym), isym) = iv end if -100 End do + End do End do End do End do !$OMP end parallel do do isym = 1, nsymrpa - if (rank == 0) write (*, *) 'solvC: isym, dim(isym)', isym, dim(isym) + if (rank == 0) print *, 'solvC: isym, dim(isym)', isym, dim(isym) end do !$OMP parallel do schedule(dynamic,1) private(ia,ja,it,jt,cint1) @@ -671,88 +621,107 @@ SUBROUTINE vCmat_ord_ty(v) !$OMP end parallel do open (1, file=c1int, status='old', form='unformatted') -30 read (1, err=10, end=20) i, j, k, l, cint2 ! (ij|kl) - + 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' + 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) ! !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - isym = irpmo(i + ninact + nact) ! i corresponds to a - !$OMP parallel do schedule(static,1) private(it,iu,iv,dr,di,d) - Do i0 = 1, dim(isym) - it = indt(i0, isym) - iu = indu(i0, isym) - iv = indv(i0, isym) + isym = irpmo(i + ninact + nact) ! i corresponds to a + !$OMP parallel do schedule(static,1) private(it,iu,iv,dr,di,d) + Do i0 = 1, dim(isym) + it = indt(i0, isym) + iu = indu(i0, isym) + iv = indv(i0, isym) - Call dim3_density(iv, iu, it, j, k, l, dr, di) - d = DCMPLX(dr, di) - v(i, it, iu, iv) = v(i, it, iu, iv) + cint2*d + Call dim3_density(iv, iu, it, j, k, l, dr, di) + d = DCMPLX(dr, di) + v(i, it, iu, iv) = v(i, it, iu, iv) + cint2*d - End do - !$OMP end parallel do + End do + !$OMP end parallel do ! 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 - end if - - goto 30 + if (j == k) then + effh(i, l) = effh(i, l) - cint2 + end if + end do -20 close (1) - if (rank == 0) then ! Process limits for output - write (*, *) 'reading C1int2 is over' - end if + close (1) + 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 -300 read (1, err=10, end=200) i, j, k, l, cint2 - + 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 + exit + else if (iostat > 0) then + ! Stop the program if the iostat is greater than 0 + stop 'Error: Error in reading C2int' + end if ! !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ! effh(a,p) = hap + Siguma_k(is oqqupied)[(ap|kk)-(ak|kp)] - Siguma_w(aw|wp) ! ======== !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - if (k == l) then + if (k == l) then - effh(i, j) = effh(i, j) + cint2 + effh(i, j) = effh(i, j) + cint2 - end if - - goto 300 + end if + end do -200 close (1) - if (rank == 0) then ! Process limits for output - write (*, *) 'reading C2int2 is over' - end if + 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 -3000 read (1, err=10, end=2000) i, j, k, l, cint2 ! (ij|kl):=> (ak|kp) - + 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 + exit + else if (iostat > 0) then + ! Stop the program if the iostat is greater than 0 + stop 'Error: Error in reading C3int' + end if ! !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ! effh(a,p) = hap + Siguma_k(is oqqupied)[(ap|kk)-(ak|kp)] - Siguma_w(aw|wp) ! ========= !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - if (j == k) then + if (j == k) then - effh(i, l) = effh(i, l) - cint2 + effh(i, l) = effh(i, l) - cint2 - end if - - goto 3000 + end if -2000 close (1) - if (rank == 0) then ! Process limits for output - write (*, *) 'reading C3int2 is over' - end if + end do + close (1) + if (rank == 0) print *, 'reading C3int2 is over' Call timing(datetmp1, tsectmp1, datetmp0, tsectmp0) datetmp1 = datetmp0 tsectmp1 = tsectmp0 @@ -768,7 +737,8 @@ SUBROUTINE vCmat_ord_ty(v) Do ip = 1, nact - if (ABS(effh(ia, ip)) < 1.0d-10) goto 70 + ! Go to the next ip if the value of effh(ja,jp) is nearly zero + if (ABS(effh(ia, ip)) < 1.0d-10) cycle Do i0 = 1, dim(isym) it = indt(i0, isym) @@ -785,15 +755,11 @@ SUBROUTINE vCmat_ord_ty(v) End do !i0 -70 End do !ip + End do !ip End do !ia !$OMP end parallel do - goto 101 - -10 write (*, *) 'error while opening file Cint'; goto 101 - -101 if (rank == 0) write (*, *) 'vCmat_ord is ended' + if (rank == 0) print *, 'vCmat_ord is ended' deallocate (indt) deallocate (indu) @@ -801,8 +767,8 @@ SUBROUTINE vCmat_ord_ty(v) #ifdef HAVE_MPI call MPI_Allreduce(MPI_IN_PLACE, v(1, 1, 1, 1), nsec*nact**3, MPI_COMPLEX16, MPI_SUM, MPI_COMM_WORLD, ierr) + if (rank == 0) print *, 'end Allreduce vCmat' #endif - if (rank == 0) write (*, *) 'end Allreduce vCmat' Call timing(datetmp1, tsectmp1, datetmp0, tsectmp0) datetmp1 = datetmp0 tsectmp1 = tsectmp0 diff --git a/src/solvall_D_ord_ty.f90 b/src/solvall_D_ord_ty.f90 index e5553ce0..207ad241 100644 --- a/src/solvall_D_ord_ty.f90 +++ b/src/solvall_D_ord_ty.f90 @@ -64,13 +64,13 @@ SUBROUTINE solvD_ord_ty(e0, e2d) ! ! E2 = SIGUMA_a,i, dimm |V1(dimm,ai)|^2|/{(alpha(ai) + wb(dimm)} - if (rank == 0) then ! Process limits for output - write (*, *) ' ENTER solv D part' - write (*, *) ' nsymrpa', nsymrpa + if (rank == 0) then + print *, ' ENTER solv D part' + print *, ' nsymrpa', nsymrpa end if datetmp1 = date0; datetmp0 = date0 Call timing(date0, tsec0, datetmp0, tsectmp0) - tsectmp1 = tsectmp0; + tsectmp1 = tsectmp0; thresd = 1.0D-08 thres = 1.0D-08 @@ -106,7 +106,7 @@ SUBROUTINE solvD_ord_ty(e0, e2d) #ifdef HAVE_MPI call MPI_Barrier(MPI_COMM_WORLD, ierr) #endif - if (rank == 0) write (*, *) 'end before v matrices' + if (rank == 0) print *, 'end before v matrices' Call timing(datetmp1, tsectmp1, datetmp0, tsectmp0) datetmp1 = datetmp0 tsectmp1 = tsectmp0 @@ -114,13 +114,11 @@ SUBROUTINE solvD_ord_ty(e0, e2d) #ifdef HAVE_MPI call MPI_Barrier(MPI_COMM_WORLD, ierr) #endif - if (rank == 0) write (*, *) 'end after vDmat' + if (rank == 0) print *, 'end after vDmat' Call timing(datetmp1, tsectmp1, datetmp0, tsectmp0) datetmp1 = datetmp0 tsectmp1 = tsectmp0 - if (rank == 0) then ! Process limits for output - write (*, *) 'come' - end if + if (rank == 0) print *, 'come' Do isym = 1, nsymrpa @@ -135,12 +133,12 @@ SUBROUTINE solvD_ord_ty(e0, e2d) if (nsymrpa == 1 .or. (nsymrpa /= 1 .and. syma == isym)) then dimn = dimn + 1 End if -100 End do ! iu + End do ! iu End do ! it if (rank == 0) print *, 'isym, dimn', isym, dimn - If (dimn == 0) goto 1000 + If (dimn == 0) cycle ! Go to the next isym Allocate (indsym(2, dimn)) indsym = 0 @@ -158,23 +156,19 @@ SUBROUTINE solvD_ord_ty(e0, e2d) indsym(1, dimn) = it indsym(2, dimn) = iu End if -200 End do ! iu + End do ! iu End do ! it Allocate (sc(dimn, dimn)) sc = 0.0d+00 ! sc N*N - if (rank == 0) then ! Process limits for output - write (*, *) 'before sDmat' - end if + if (rank == 0) print *, 'before sDmat' Call timing(datetmp1, tsectmp1, datetmp0, tsectmp0) datetmp1 = datetmp0 tsectmp1 = tsectmp0 Call sDmat(dimn, indsym, sc) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - if (rank == 0) then ! Process limits for output - write (*, *) 'sc matrix is obtained normally' - end if + if (rank == 0) print *, 'sc matrix is obtained normally' Call timing(datetmp1, tsectmp1, datetmp0, tsectmp0) datetmp1 = datetmp0 tsectmp1 = tsectmp0 @@ -186,85 +180,65 @@ SUBROUTINE solvD_ord_ty(e0, e2d) Allocate (sc0(dimn, dimn)) sc0 = sc - if (rank == 0) then ! Process limits for output - write (*, *) 'before cdiag' - end if + if (rank == 0) print *, 'before cdiag' Call timing(datetmp1, tsectmp1, datetmp0, tsectmp0) datetmp1 = datetmp0 tsectmp1 = tsectmp0 Call cdiag(sc, dimn, dimm, ws, thresd, cutoff) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - if (rank == 0) then ! Process limits for output - write (*, *) 'after s cdiag' - end if + if (rank == 0) print *, 'after s cdiag' If (dimm == 0) then deallocate (indsym) deallocate (sc0) deallocate (sc) deallocate (ws) - goto 1000 + cycle ! Go to the next isym End if If (debug) then - if (rank == 0) then ! Process limits for output - write (*, *) 'Check whether U*SU is diagonal' - end if + if (rank == 0) print *, 'Check whether U*SU is diagonal' Call checkdgc(dimn, sc0, sc, ws) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - if (rank == 0) then ! Process limits for output - write (*, *) 'Check whether U*SU is diagonal END' - end if + if (rank == 0) print *, 'Check whether U*SU is diagonal END' End if Allocate (bc(dimn, dimn)) ! bc N*N bc = 0.0d+00 - if (rank == 0) then ! Process limits for output - write (*, *) 'before bDmat' - end if + if (rank == 0) print *, 'before bDmat' Call timing(datetmp1, tsectmp1, datetmp0, tsectmp0) datetmp1 = datetmp0 tsectmp1 = tsectmp0 Call bDmat(dimn, sc0, indsym, bc) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - if (rank == 0) then ! Process limits for output - write (*, *) 'bc matrix is obtained normally' - end if + if (rank == 0) print *, 'bc matrix is obtained normally' Call timing(datetmp1, tsectmp1, datetmp0, tsectmp0) datetmp1 = datetmp0 tsectmp1 = tsectmp0 deallocate (sc0) - if (rank == 0) then ! Process limits for output - write (*, *) 'OK cdiag', dimn, dimm - end if + if (rank == 0) print *, 'OK cdiag', dimn, dimm Allocate (uc(dimn, dimm)) ! uc N*M Allocate (wsnew(dimm)) ! wnew M uc(:, :) = 0.0d+00 wsnew(:) = 0.0d+00 - if (rank == 0) then ! Process limits for output - write (*, *) 'before ccutoff' - end if + if (rank == 0) print *, 'before ccutoff' Call timing(datetmp1, tsectmp1, datetmp0, tsectmp0) datetmp1 = datetmp0 tsectmp1 = tsectmp0 Call ccutoff(sc, ws, dimn, dimm, uc, wsnew) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - if (rank == 0) then ! Process limits for output - write (*, *) 'OK ccutoff' - end if + if (rank == 0) print *, 'OK ccutoff' Call timing(datetmp1, tsectmp1, datetmp0, tsectmp0) datetmp1 = datetmp0 tsectmp1 = tsectmp0 deallocate (ws) deallocate (sc) - if (rank == 0) then ! Process limits for output - write (*, *) 'before ucramda_s_half' - end if + if (rank == 0) print *, 'before ucramda_s_half' Call timing(datetmp1, tsectmp1, datetmp0, tsectmp0) datetmp1 = datetmp0 tsectmp1 = tsectmp0 @@ -272,9 +246,7 @@ SUBROUTINE solvD_ord_ty(e0, e2d) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ deallocate (wsnew) - if (rank == 0) then ! Process limits for output - write (*, *) 'ucrams half OK' - end if + if (rank == 0) print *, 'ucrams half OK' Call timing(datetmp1, tsectmp1, datetmp0, tsectmp0) datetmp1 = datetmp0 tsectmp1 = tsectmp0 @@ -285,18 +257,18 @@ SUBROUTINE solvD_ord_ty(e0, e2d) bc1 = 0.0d+00 bc1 = MATMUL(bc0, uc) - if (rank == 0) then ! Process limits for output + if (rank == 0) then IF (debug) then - write (*, *) 'Check whether bc1 is hermite or not' + print *, '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) + print '(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' + print *, 'Check whether bc1 is hermite or not END' End if end if @@ -309,42 +281,30 @@ SUBROUTINE solvD_ord_ty(e0, e2d) Allocate (wb(dimm)) wb = 0.0d+00 - if (rank == 0) then ! Process limits for output - write (*, *) 'bC matrix is transrated to bc1(M*M matrix)!' - end if + if (rank == 0) print *, 'bC matrix is transrated to bc1(M*M matrix)!' Allocate (bc0(dimm, dimm)) bc0 = bc1 - if (rank == 0) then ! Process limits for output - write (*, *) 'before cdiag' - end if + if (rank == 0) print *, 'before cdiag' Call timing(datetmp1, tsectmp1, datetmp0, tsectmp0) datetmp1 = datetmp0 tsectmp1 = tsectmp0 Call cdiag(bc1, dimm, dammy, wb, thresd, cutoff) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - if (rank == 0) then ! Process limits for output - write (*, *) 'end cdiag' - end if + if (rank == 0) print *, 'end cdiag' Call timing(datetmp1, tsectmp1, datetmp0, tsectmp0) datetmp1 = datetmp0 tsectmp1 = tsectmp0 If (debug) then - if (rank == 0) then ! Process limits for output - write (*, *) 'Check whether bc is really diagonalized or not' - end if + if (rank == 0) print *, 'Check whether bc is really diagonalized or not' Call checkdgc(dimm, bc0, bc1, wb) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - if (rank == 0) then ! Process limits for output - write (*, *) 'Check whether bc is really diagonalized or not END' - end if + if (rank == 0) print *, 'Check whether bc is really diagonalized or not END' End if deallocate (bc0) - if (rank == 0) then ! Process limits for output - write (*, *) 'bC1 matrix is diagonalized!' - end if + if (rank == 0) print *, 'bC1 matrix is diagonalized!' e2 = 0.0d+00 Do i0 = 1, nai ja = ia0(i0) @@ -386,20 +346,18 @@ SUBROUTINE solvD_ord_ty(e0, e2d) deallocate (wb) Deallocate (bc1) -1000 if (rank == 0) write (*, '("e2d(",I3,") = ",E20.10," a.u.")') isym, e2(isym) + if (rank == 0) print '("e2d(",I3,") = ",E20.10," a.u.")', isym, e2(isym) e2d = e2d + e2(isym) - if (rank == 0) then ! Process limits for output - write (*, *) 'End e2(isym) add' - end if + if (rank == 0) print *, 'End e2(isym) add' Call timing(datetmp1, tsectmp1, datetmp0, tsectmp0) datetmp1 = datetmp0 tsectmp1 = tsectmp0 End do ! isym - if (rank == 0) then ! Process limits for output - write (*, '("e2d = ",E20.10," a.u.")') e2d + if (rank == 0) then + print '("e2d = ",E20.10," a.u.")', e2d - write (*, '("sumc2,d = ",E20.10)') sumc2local + print '("sumc2,d = ",E20.10)', sumc2local end if sumc2 = sumc2 + sumc2local @@ -408,10 +366,7 @@ SUBROUTINE solvD_ord_ty(e0, e2d) deallocate (ii0) deallocate (v) - continue - if (rank == 0) then ! Process limits for output - write (*, *) 'end solvD_ord_ty' - end if + if (rank == 0) print *, 'end solvD_ord_ty' end ! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= @@ -491,9 +446,7 @@ SUBROUTINE bDmat(dimn, sc, indsym, bc) ! Assume C1 molecule, overlap matrix B in bc(:, :) = 0.0d+00 - if (rank == 0) then ! Process limits for output - write (*, *) 'F space Bmat iroot=', iroot - end if + if (rank == 0) print *, 'F space Bmat iroot=', iroot !$OMP parallel do schedule(dynamic,1) private(ix,iy,jx,jy,it,iu,jt,ju,e,j,iw,jw,denr,deni,den) Do i = rank + 1, dimn, nprocs @@ -536,9 +489,7 @@ SUBROUTINE bDmat(dimn, sc, indsym, bc) ! Assume C1 molecule, overlap matrix B in call MPI_Reduce(bc(1, 1), bc(1, 1), dimn**2, MPI_COMPLEX16, MPI_SUM, 0, MPI_COMM_WORLD, ierr) end if #endif - if (rank == 0) then ! Process limits for output - write (*, *) 'bDmat is ended' - end if + if (rank == 0) print *, 'bDmat is ended' End subroutine bDmat ! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= @@ -563,14 +514,14 @@ SUBROUTINE vDmat_ord_ty(nai, iai, v) integer, intent(in) :: nai, iai(nsec, ninact) complex*16, intent(out) :: v(nai, nact, nact) real*8 :: dr, di - complex*16 :: cint1, cint2, d + complex*16 :: cint1, cint2, d complex*16 :: effh(nsec, ninact) - integer :: i, j, k, l, tai + integer :: i, j, k, l, tai, iostat integer :: it, jt, ju, iu, ia, ii, ja, ji integer :: datetmp0, datetmp1 real(8) :: tsectmp0, tsectmp1 - if (rank == 0) write (*, *) 'Enter vDmat. Please ignore timer under this line.' + if (rank == 0) print *, 'Enter vDmat. Please ignore timer under this line.' datetmp1 = date0; datetmp0 = date0 Call timing(date0, tsec0, datetmp0, tsectmp0) tsectmp1 = tsectmp0 @@ -610,13 +561,21 @@ SUBROUTINE vDmat_ord_ty(nai, iai, v) ! !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - if (rank == 0) write (*, *) 'before d1int' + if (rank == 0) print *, 'before d1int' Call timing(datetmp1, tsectmp1, datetmp0, tsectmp0) datetmp1 = datetmp0 tsectmp1 = tsectmp0 open (1, file=d1int, status='old', form='unformatted') - -30 read (1, err=10, end=20) i, j, k, l, cint2 ! (ij|kl) + 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' + 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 !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ! V(a,i, jt, ju) = SIGUMA_pq:active <0|EutEpq|0>{(ai|pq) - (aq|pi)} @@ -624,29 +583,26 @@ SUBROUTINE vDmat_ord_ty(nai, iai, v) ! + <0|Eut|0>[hai +{ SIGUMA_k:inactive(ai|kk) - (ak|ki)}] ! !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - ja = i - ji = j - tai = iai(ja, ji) - - !$OMP parallel do schedule(dynamic,1) private(it,jt,iu,ju,dr,di,d) - Do it = 1, nact - jt = it + ninact - Do iu = 1, nact - ju = iu + ninact + ja = i + ji = j + tai = iai(ja, ji) - Call dim2_density(iu, it, k, l, dr, di) - d = DCMPLX(dr, di) - v(tai, it, iu) = v(tai, it, iu) + d*cint2 + !$OMP parallel do schedule(dynamic,1) private(it,jt,iu,ju,dr,di,d) + Do it = 1, nact + jt = it + ninact + Do iu = 1, nact + ju = iu + ninact - End do - End do - !$OMP end parallel do + Call dim2_density(iu, it, k, l, dr, di) + d = DCMPLX(dr, di) + v(tai, it, iu) = v(tai, it, iu) + d*cint2 - goto 30 -20 close (1) - if (rank == 0) then ! Process limits for output - write (*, *) 'reading D1int2 is over' - end if + End do + End do + !$OMP end parallel do + end do + close (1) + if (rank == 0) print *, 'reading D1int2 is over' !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ! V(a,i, jt, ju) = SIGUMA_pq:active <0|EutEpq|0>{(ai|pq) - (aq|pi)} ! @@ -654,60 +610,72 @@ SUBROUTINE vDmat_ord_ty(nai, iai, v) ! !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - if (rank == 0) write (*, *) 'before d2int' + if (rank == 0) print *, 'before d2int' Call timing(datetmp1, tsectmp1, datetmp0, tsectmp0) datetmp1 = datetmp0 tsectmp1 = tsectmp0 open (1, file=d2int, status='old', form='unformatted') + 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' + 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 -31 read (1, err=10, end=21) i, j, k, l, cint2 ! (ij|kl) - ja = i - ji = l - tai = iai(ja, ji) - !$OMP parallel do schedule(dynamic,1) private(it,ju,dr,di,d) - Do it = 1, nact - Do iu = 1, nact + ja = i + ji = l + tai = iai(ja, ji) + !$OMP parallel do schedule(dynamic,1) private(it,ju,dr,di,d) + Do it = 1, nact + Do iu = 1, nact - Call dim2_density(iu, it, k, j, dr, di) - d = DCMPLX(dr, di) + Call dim2_density(iu, it, k, j, dr, di) + d = DCMPLX(dr, di) - v(tai, it, iu) = v(tai, it, iu) - d*cint2 + v(tai, it, iu) = v(tai, it, iu) - d*cint2 + End do End do - End do - !$OMP end parallel do - - goto 31 + !$OMP end parallel do + end do -21 close (1) - if (rank == 0) then ! Process limits for output - write (*, *) 'reading D2int2 is over' - end if - if (rank == 0) write (*, *) 'before d3int' + close (1) + if (rank == 0) print *, 'reading D2int2 is over' + if (rank == 0) print *, 'before d3int' 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' + 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 -300 read (1, err=10, end=200) i, j, k, l, cint2 ! (ij|kl) - - if (j /= k .and. k == l) then !(ai|kk) - - effh(i, j) = effh(i, j) + cint2 + if (j /= k .and. k == l) then !(ai|kk) - elseif (j == k .and. k /= l) then !(ak|ki) + effh(i, j) = effh(i, j) + cint2 - effh(i, l) = effh(i, l) - cint2 + elseif (j == k .and. k /= l) then !(ak|ki) - end if + effh(i, l) = effh(i, l) - cint2 - goto 300 + end if + end do -200 close (1) - if (rank == 0) then ! Process limits for output - write (*, *) 'reading D3int2 is over' - end if - if (rank == 0) write (*, *) 'end d3int' + 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 @@ -715,7 +683,7 @@ SUBROUTINE vDmat_ord_ty(nai, iai, v) #ifdef HAVE_MPI call MPI_Allreduce(MPI_IN_PLACE, effh(1, 1), nsec*ninact, MPI_COMPLEX16, MPI_SUM, MPI_COMM_WORLD, ierr) #endif - if (rank == 0) write (*, *) 'end allreduce effh' + if (rank == 0) print *, 'end allreduce effh' Call timing(datetmp1, tsectmp1, datetmp0, tsectmp0) datetmp1 = datetmp0 tsectmp1 = tsectmp0 @@ -737,15 +705,11 @@ SUBROUTINE vDmat_ord_ty(nai, iai, v) End do !$OMP end parallel do - goto 100 - -10 write (*, *) 'error while opening file Dint'; goto 100 - -100 if (rank == 0) write (*, *) 'vDmat_ord_ty is ended' + if (rank == 0) print *, 'vDmat_ord_ty is ended' #ifdef HAVE_MPI call MPI_Allreduce(MPI_IN_PLACE, v(1, 1, 1), nai*nact**2, MPI_COMPLEX16, MPI_SUM, MPI_COMM_WORLD, ierr) + if (rank == 0) print *, 'end Allreduce vDmat' #endif - if (rank == 0) write (*, *) 'end Allreduce vDmat' Call timing(datetmp1, tsectmp1, datetmp0, tsectmp0) datetmp1 = datetmp0 tsectmp1 = tsectmp0 diff --git a/src/solvall_E_ord_ty.f90 b/src/solvall_E_ord_ty.f90 index 654bd289..7e1fc2de 100644 --- a/src/solvall_E_ord_ty.f90 +++ b/src/solvall_E_ord_ty.f90 @@ -70,9 +70,9 @@ SUBROUTINE solvE_ord_ty(e0, e2e) datetmp1 = date0; datetmp0 = date0 Call timing(date0, tsec0, datetmp0, tsectmp0) tsectmp1 = tsectmp0 - if (rank == 0) then ! Process limits for output - write (*, *) ' ENTER solv E part' - write (*, *) ' nsymrpa', nsymrpa + if (rank == 0) then + print *, ' ENTER solv E part' + print *, ' nsymrpa', nsymrpa end if i0 = 0 Do ia = 1, nsec @@ -109,14 +109,12 @@ SUBROUTINE solvE_ord_ty(e0, e2e) #ifdef HAVE_MPI call MPI_Barrier(MPI_COMM_WORLD, ierr) #endif - if (rank == 0) write (*, *) 'end before v matrices' + if (rank == 0) print *, 'end before v matrices' Call timing(datetmp1, tsectmp1, datetmp0, tsectmp0) datetmp1 = datetmp0 tsectmp1 = tsectmp0 Call vEmat_ord_ty(naij, iaij, v) - if (rank == 0) then ! Process limits for output - write (*, *) 'come' - end if + if (rank == 0) print *, 'come' Call timing(datetmp1, tsectmp1, datetmp0, tsectmp0) datetmp1 = datetmp0 tsectmp1 = tsectmp0 @@ -132,25 +130,19 @@ SUBROUTINE solvE_ord_ty(e0, e2e) End if End do ! it - if (rank == 0) then ! Process limits for output - write (*, *) 'isym, dimn', isym, dimn - end if - If (dimn == 0) goto 1000 + if (rank == 0) print *, 'isym, dimn', isym, dimn + If (dimn == 0) cycle ! Go to the next isym Allocate (sc(dimn, dimn)) sc = 0.0d+00 ! sc N*N - if (rank == 0) then ! Process limits for output - write (*, *) 'before sEmat' - end if + if (rank == 0) print *, 'before sEmat' Call timing(datetmp1, tsectmp1, datetmp0, tsectmp0) datetmp1 = datetmp0 tsectmp1 = tsectmp0 Call sEmat(dimn, indt(1:dimn), sc) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - if (rank == 0) then ! Process limits for output - write (*, *) 'sc matrix is obtained normally' - end if + if (rank == 0) print *, 'sc matrix is obtained normally' Call timing(datetmp1, tsectmp1, datetmp0, tsectmp0) datetmp1 = datetmp0 tsectmp1 = tsectmp0 @@ -161,17 +153,13 @@ SUBROUTINE solvE_ord_ty(e0, e2e) Allocate (sc0(dimn, dimn)) sc0 = sc - if (rank == 0) then ! Process limits for output - write (*, *) 'before cdiag' - end if + if (rank == 0) print *, 'before cdiag' Call timing(datetmp1, tsectmp1, datetmp0, tsectmp0) datetmp1 = datetmp0 tsectmp1 = tsectmp0 Call cdiag(sc, dimn, dimm, ws, thresd, cutoff) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - if (rank == 0) then ! Process limits for output - write (*, *) 'after s cdiag, new dimension is', dimm - end if + if (rank == 0) print *, 'after s cdiag, new dimension is', dimm Call timing(datetmp1, tsectmp1, datetmp0, tsectmp0) datetmp1 = datetmp0 tsectmp1 = tsectmp0 @@ -179,65 +167,49 @@ SUBROUTINE solvE_ord_ty(e0, e2e) deallocate (sc0) deallocate (sc) deallocate (ws) - goto 1000 + cycle ! Go to the next isym End if If (debug) then - if (rank == 0) then ! Process limits for output - write (*, *) 'Check whether U*SU is diagonal' - end if + if (rank == 0) print *, 'Check whether U*SU is diagonal' Call checkdgc(dimn, sc0, sc, ws) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - if (rank == 0) then ! Process limits for output - write (*, *) 'Check whether U*SU is diagonal END' - end if + if (rank == 0) print *, 'Check whether U*SU is diagonal END' End if Allocate (bc(dimn, dimn)) ! bc N*N bc = 0.0d+00 - if (rank == 0) then ! Process limits for output - write (*, *) 'before bEmat' - end if + if (rank == 0) print *, 'before bEmat' Call timing(datetmp1, tsectmp1, datetmp0, tsectmp0) datetmp1 = datetmp0 tsectmp1 = tsectmp0 Call bEmat(e0, dimn, sc0, indt(1:dimn), bc) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - if (rank == 0) then ! Process limits for output - write (*, *) 'bc matrix is obtained normally' - end if + if (rank == 0) print *, 'bc matrix is obtained normally' Call timing(datetmp1, tsectmp1, datetmp0, tsectmp0) datetmp1 = datetmp0 tsectmp1 = tsectmp0 deallocate (sc0) - if (rank == 0) then ! Process limits for output - write (*, *) 'OK cdiag', dimn, dimm - end if + if (rank == 0) print *, 'OK cdiag', dimn, dimm Allocate (uc(dimn, dimm)) ! uc N*M Allocate (wsnew(dimm)) ! wnew M uc(:, :) = 0.0d+00 wsnew(:) = 0.0d+00 - if (rank == 0) then ! Process limits for output - write (*, *) 'before ccutoff' - end if + if (rank == 0) print *, 'before ccutoff' Call timing(datetmp1, tsectmp1, datetmp0, tsectmp0) datetmp1 = datetmp0 tsectmp1 = tsectmp0 Call ccutoff(sc, ws, dimn, dimm, uc, wsnew) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - if (rank == 0) then ! Process limits for output - write (*, *) 'OK ccutoff' - end if + if (rank == 0) print *, 'OK ccutoff' Call timing(datetmp1, tsectmp1, datetmp0, tsectmp0) datetmp1 = datetmp0 tsectmp1 = tsectmp0 deallocate (ws) deallocate (sc) - if (rank == 0) then ! Process limits for output - write (*, *) 'before ucramda_s_half' - end if + if (rank == 0) print *, 'before ucramda_s_half' Call timing(datetmp1, tsectmp1, datetmp0, tsectmp0) datetmp1 = datetmp0 tsectmp1 = tsectmp0 @@ -245,9 +217,7 @@ SUBROUTINE solvE_ord_ty(e0, e2e) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ deallocate (wsnew) - if (rank == 0) then ! Process limits for output - write (*, *) 'ucrams half OK' - end if + if (rank == 0) print *, 'ucrams half OK' Call timing(datetmp1, tsectmp1, datetmp0, tsectmp0) datetmp1 = datetmp0 tsectmp1 = tsectmp0 @@ -260,16 +230,16 @@ SUBROUTINE solvE_ord_ty(e0, e2e) If (debug) then - if (rank == 0) then ! Process limits for output - write (*, *) 'Check whether bc1 is hermite or not' + if (rank == 0) then + print *, '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) + print '(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' + print *, 'Check whether bc1 is hermite or not END' end if End if @@ -281,41 +251,29 @@ SUBROUTINE solvE_ord_ty(e0, e2e) Allocate (wb(dimm)) - if (rank == 0) then ! Process limits for output - write (*, *) 'bC matrix is transrated to bc1(M*M matrix)!' - end if + if (rank == 0) print *, 'bC matrix is transrated to bc1(M*M matrix)!' Allocate (bc0(dimm, dimm)) bc0 = bc1 - if (rank == 0) then ! Process limits for output - write (*, *) 'before cdiag' - end if + if (rank == 0) print *, 'before cdiag' Call timing(datetmp1, tsectmp1, datetmp0, tsectmp0) datetmp1 = datetmp0 tsectmp1 = tsectmp0 Call cdiag(bc1, dimm, dammy, wb, thresd, cutoff) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - if (rank == 0) then ! Process limits for output - write (*, *) 'end cdiag' - end if + if (rank == 0) print *, 'end cdiag' Call timing(datetmp1, tsectmp1, datetmp0, tsectmp0) datetmp1 = datetmp0 tsectmp1 = tsectmp0 If (debug) then - if (rank == 0) then ! Process limits for output - write (*, *) 'Check whether bc is really diagonalized or not' - end if + if (rank == 0) print *, 'Check whether bc is really diagonalized or not' Call checkdgc(dimm, bc0, bc1, wb) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - if (rank == 0) then ! Process limits for output - write (*, *) 'Check whether bc is really diagonalized or not END' - end if + if (rank == 0) print *, 'Check whether bc is really diagonalized or not END' End if deallocate (bc0) - if (rank == 0) then ! Process limits for output - write (*, *) 'bC1 matrix is diagonalized!' - end if + if (rank == 0) print *, 'bC1 matrix is diagonalized!' e2 = 0.0d+00 Do i0 = 1, naij @@ -363,20 +321,17 @@ SUBROUTINE solvE_ord_ty(e0, e2e) deallocate (wb) Deallocate (bc1) -1000 if (rank == 0) write (*, '("e2e(",I3,") = ",E20.10," a.u.")') isym, e2(isym) + if (rank == 0) print '("e2e(",I3,") = ",E20.10," a.u.")', isym, e2(isym) e2e = e2e + e2(isym) - if (rank == 0) then ! Process limits for output - write (*, *) 'End e2(isym) add' - end if + if (rank == 0) print *, 'End e2(isym) add' Call timing(datetmp1, tsectmp1, datetmp0, tsectmp0) datetmp1 = datetmp0 tsectmp1 = tsectmp0 End do ! isym - if (rank == 0) then ! Process limits for output - write (*, '("e2e = ",E20.10," a.u.")') e2e - - write (*, '("sumc2,e = ",E20.10)') sumc2local + if (rank == 0) then + print '("e2e = ",E20.10," a.u.")', e2e + print '("sumc2,e = ",E20.10)', sumc2local end if sumc2 = sumc2 + sumc2local @@ -387,9 +342,7 @@ SUBROUTINE solvE_ord_ty(e0, e2e) deallocate (v) continue - if (rank == 0) then ! Process limits for output - write (*, *) 'end solveE_ord_ty' - end if + if (rank == 0) print *, 'end solveE_ord_ty' end ! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= @@ -482,9 +435,7 @@ SUBROUTINE bEmat(e0, dimn, sc, indt, bc) ! Assume C1 molecule, overlap matrix B bc(:, :) = 0.0d+00 - if (rank == 0) then ! Process limits for output - write (*, *) 'E space Bmat iroot=', iroot - end if + if (rank == 0) print *, 'E space Bmat iroot=', iroot !$OMP parallel do schedule(dynamic,1) private(iu,ju,j,it,jt,iw,jw,denr,deni,den) Do i = rank + 1, dimn, nprocs @@ -522,9 +473,7 @@ SUBROUTINE bEmat(e0, dimn, sc, indt, bc) ! Assume C1 molecule, overlap matrix B call MPI_Reduce(bc(1, 1), bc(1, 1), dimn**2, MPI_COMPLEX16, MPI_SUM, 0, MPI_COMM_WORLD, ierr) end if #endif - if (rank == 0) then ! Process limits for output - write (*, *) 'bEmat is ended' - end if + if (rank == 0) print *, 'bEmat is ended' End subroutine bEmat ! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= @@ -552,11 +501,11 @@ SUBROUTINE vEmat_ord_ty(naij, iaij, v) complex*16 :: cint2, dens integer :: i, j, k, l, taij - integer :: it, jt, ik + integer :: it, jt, ik, iostat integer :: datetmp0, datetmp1 real(8) :: tsectmp0, tsectmp1 - if (rank == 0) write (*, *) 'Enter vEmat. Please ignore timer under this line.' + if (rank == 0) print *, 'Enter vEmat. Please ignore timer under this line.' datetmp1 = date0; datetmp0 = date0 Call timing(date0, tsec0, datetmp0, tsectmp0) tsectmp1 = tsectmp0 @@ -565,18 +514,27 @@ SUBROUTINE vEmat_ord_ty(naij, iaij, v) ! 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 + 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' + 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) goto 30 + if (j == l) cycle ! Read the next 2-integral if j equal to l - taij = iaij(i, j, l) - ik = k - ninact + taij = iaij(i, j, l) + ik = k - ninact - if (j < l) then - cint2 = -1.0d+00*cint2 - end if + if (j < l) then + cint2 = -1.0d+00*cint2 + end if - v(taij, k) = v(taij, k) - cint2 + v(taij, k) = v(taij, k) - cint2 !$OMP parallel do schedule(dynamic,1) private(it,dr,di,dens) Do it = 1, nact @@ -586,9 +544,9 @@ SUBROUTINE vEmat_ord_ty(naij, iaij, v) End do ! it !$OMP end parallel do - if (j < l) then - cint2 = -1.0d+00*cint2 ! data cint2 becomes initial values! - end if + if (j < l) then + cint2 = -1.0d+00*cint2 ! data cint2 becomes initial values! + end if !! Take Kramers conjugate ! ! @@ -611,18 +569,15 @@ SUBROUTINE vEmat_ord_ty(naij, iaij, v) ! dens = DCMPLX(dr, di) ! v(taij,jt) = v(taij, jt) + cint2*dens ! End do ! it + end do - goto 30 - -20 close (1); goto 100 - -10 write (*, *) 'error while opening file Eint'; goto 100 + close (1) + if (rank == 0) print *, 'vEmat_ord_ty is ended' -100 if (rank == 0) write (*, *) 'vEmat_ord_ty is ended' #ifdef HAVE_MPI call MPI_Allreduce(MPI_IN_PLACE, v(1, 1), naij*nact, MPI_COMPLEX16, MPI_SUM, MPI_COMM_WORLD, ierr) + if (rank == 0) print *, 'end Allreduce vEmat' #endif - if (rank == 0) write (*, *) 'end Allreduce vEmat' Call timing(datetmp1, tsectmp1, datetmp0, tsectmp0) datetmp1 = datetmp0 tsectmp1 = tsectmp0 diff --git a/src/solvall_F_ord_ty.f90 b/src/solvall_F_ord_ty.f90 index 04f2c01d..581fb19d 100644 --- a/src/solvall_F_ord_ty.f90 +++ b/src/solvall_F_ord_ty.f90 @@ -65,9 +65,7 @@ SUBROUTINE solvF_ord_ty(e0, e2f) e2f = 0.0d+00 dimn = 0 syma = 0 - if (rank == 0) then ! Process limits for output - write (*, *) ' ENTER solv F part' - end if + if (rank == 0) print *, ' ENTER solv F part' datetmp1 = date0; datetmp0 = date0 Call timing(date0, tsec0, datetmp0, tsectmp0) tsectmp1 = tsectmp0 @@ -102,12 +100,12 @@ SUBROUTINE solvF_ord_ty(e0, e2f) #ifdef HAVE_MPI call MPI_Barrier(MPI_COMM_WORLD, ierr) #endif - if (rank == 0) write (*, *) 'end before v matrices' + if (rank == 0) print *, 'end before v matrices' Call timing(datetmp1, tsectmp1, datetmp0, tsectmp0) datetmp1 = datetmp0 tsectmp1 = tsectmp0 Call vFmat_ord(nab, iab, v) - if (rank == 0) write (*, *) 'end after vFmat' + if (rank == 0) print *, 'end after vFmat' Call timing(datetmp1, tsectmp1, datetmp0, tsectmp0) datetmp1 = datetmp0 tsectmp1 = tsectmp0 @@ -129,10 +127,8 @@ SUBROUTINE solvF_ord_ty(e0, e2f) End do ! iu End do ! it - if (rank == 0) then ! Process limits for output - write (*, *) 'isym, dimn', isym, dimn - end if - If (dimn == 0) goto 1000 + if (rank == 0) print *, 'isym, dimn', isym, dimn + If (dimn == 0) cycle ! Go to the next isym if dimn (dimention of matrix) is zero Allocate (indsym(2, dimn)) @@ -156,18 +152,14 @@ SUBROUTINE solvF_ord_ty(e0, e2f) Allocate (sc(dimn, dimn)) sc = 0.0d+00 ! sc N*N - if (rank == 0) then ! Process limits for output - write (*, *) 'before sFmat' - end if + if (rank == 0) print *, 'before sFmat' Call timing(datetmp1, tsectmp1, datetmp0, tsectmp0) datetmp1 = datetmp0 tsectmp1 = tsectmp0 Call sFmat(dimn, indsym, sc) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - if (rank == 0) then ! Process limits for output - write (*, *) 'sc matrix is obtained normally' - end if + if (rank == 0) print *, 'sc matrix is obtained normally' Call timing(datetmp1, tsectmp1, datetmp0, tsectmp0) datetmp1 = datetmp0 tsectmp1 = tsectmp0 @@ -178,17 +170,13 @@ SUBROUTINE solvF_ord_ty(e0, e2f) Allocate (sc0(dimn, dimn)) sc0 = sc - if (rank == 0) then ! Process limits for output - write (*, *) 'before cdiag' - end if + if (rank == 0) print *, 'before cdiag' Call timing(datetmp1, tsectmp1, datetmp0, tsectmp0) datetmp1 = datetmp0 tsectmp1 = tsectmp0 Call cdiag(sc, dimn, dimm, ws, thresd, cutoff) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - if (rank == 0) then ! Process limits for output - write (*, *) 'after s cdiag, new dimension is', dimm - end if + if (rank == 0) print *, 'after s cdiag, new dimension is', dimm Call timing(datetmp1, tsectmp1, datetmp0, tsectmp0) datetmp1 = datetmp0 tsectmp1 = tsectmp0 @@ -197,66 +185,50 @@ SUBROUTINE solvF_ord_ty(e0, e2f) deallocate (sc0) deallocate (sc) deallocate (ws) - goto 1000 + cycle ! Go to the next isym if dimm (dimention of matrix) is zero End if If (debug) then - if (rank == 0) then ! Process limits for output - write (*, *) 'Check whether U*SU is diagonal' - end if + if (rank == 0) print *, 'Check whether U*SU is diagonal' Call checkdgc(dimn, sc0, sc, ws) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - if (rank == 0) then ! Process limits for output - write (*, *) 'Check whether U*SU is diagonal END' - end if + if (rank == 0) print *, 'Check whether U*SU is diagonal END' End if Allocate (bc(dimn, dimn)) ! bc N*N bc = 0.0d+00 - if (rank == 0) then ! Process limits for output - write (*, *) 'before bFmat' - end if + if (rank == 0) print *, 'before bFmat' Call timing(datetmp1, tsectmp1, datetmp0, tsectmp0) datetmp1 = datetmp0 tsectmp1 = tsectmp0 Call bFmat(dimn, sc0, indsym, bc) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - if (rank == 0) then ! Process limits for output - write (*, *) 'bc matrix is obtained normally' - end if + if (rank == 0) print *, 'bc matrix is obtained normally' Call timing(datetmp1, tsectmp1, datetmp0, tsectmp0) datetmp1 = datetmp0 tsectmp1 = tsectmp0 deallocate (sc0) - if (rank == 0) then ! Process limits for output - write (*, *) 'OK cdiag', dimn, dimm - end if + if (rank == 0) print *, 'OK cdiag', dimn, dimm Allocate (uc(dimn, dimm)) ! uc N*M Allocate (wsnew(dimm)) ! wnew M uc(:, :) = 0.0d+00 wsnew(:) = 0.0d+00 - if (rank == 0) then ! Process limits for output - write (*, *) 'before ccutoff' - end if + if (rank == 0) print *, 'before ccutoff' Call timing(datetmp1, tsectmp1, datetmp0, tsectmp0) datetmp1 = datetmp0 tsectmp1 = tsectmp0 Call ccutoff(sc, ws, dimn, dimm, uc, wsnew) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - if (rank == 0) then ! Process limits for output - write (*, *) 'OK ccutoff' - end if + if (rank == 0) print *, 'OK ccutoff' Call timing(datetmp1, tsectmp1, datetmp0, tsectmp0) datetmp1 = datetmp0 tsectmp1 = tsectmp0 deallocate (ws) deallocate (sc) - if (rank == 0) then ! Process limits for output - write (*, *) 'before ucramda_s_half' - end if + if (rank == 0) print *, 'before ucramda_s_half' Call timing(datetmp1, tsectmp1, datetmp0, tsectmp0) datetmp1 = datetmp0 tsectmp1 = tsectmp0 @@ -264,9 +236,7 @@ SUBROUTINE solvF_ord_ty(e0, e2f) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ deallocate (wsnew) - if (rank == 0) then ! Process limits for output - write (*, *) 'ucrams half OK' - end if + if (rank == 0) print *, 'ucrams half OK' Call timing(datetmp1, tsectmp1, datetmp0, tsectmp0) datetmp1 = datetmp0 tsectmp1 = tsectmp0 @@ -279,16 +249,16 @@ SUBROUTINE solvF_ord_ty(e0, e2f) If (debug) then - if (rank == 0) then ! Process limits for output - write (*, *) 'Check whether bc1 is hermite or not' + if (rank == 0) then + print *, '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) + print '(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' + print *, 'Check whether bc1 is hermite or not END' end if End if @@ -299,42 +269,30 @@ SUBROUTINE solvF_ord_ty(e0, e2f) Allocate (wb(dimm)) - if (rank == 0) then ! Process limits for output - write (*, *) 'bC matrix is transrated to bc1(M*M matrix)!' - end if + if (rank == 0) print *, 'bC matrix is transrated to bc1(M*M matrix)!' Allocate (bc0(dimm, dimm)) bc0 = bc1 - if (rank == 0) then ! Process limits for output - write (*, *) 'before cdiag' - end if + if (rank == 0) print *, 'before cdiag' Call timing(datetmp1, tsectmp1, datetmp0, tsectmp0) datetmp1 = datetmp0 tsectmp1 = tsectmp0 Call cdiag(bc1, dimm, dammy, wb, thresd, cutoff) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - if (rank == 0) then ! Process limits for output - write (*, *) 'end cdiag' - end if + if (rank == 0) print *, 'end cdiag' Call timing(datetmp1, tsectmp1, datetmp0, tsectmp0) datetmp1 = datetmp0 tsectmp1 = tsectmp0 If (debug) then - if (rank == 0) then ! Process limits for output - write (*, *) 'Check whether bc is really diagonalized or not' - end if + if (rank == 0) print *, 'Check whether bc is really diagonalized or not' Call checkdgc(dimm, bc0, bc1, wb) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - if (rank == 0) then ! Process limits for output - write (*, *) 'Check whether bc is really diagonalized or not END' - end if + if (rank == 0) print *, 'Check whether bc is really diagonalized or not END' End if deallocate (bc0) - if (rank == 0) then ! Process limits for output - write (*, *) 'bC1 matrix is diagonalized!' - end if + if (rank == 0) print *, 'bC1 matrix is diagonalized!' e2 = 0.0d+00 Do i0 = 1, nab @@ -379,19 +337,17 @@ SUBROUTINE solvF_ord_ty(e0, e2f) deallocate (wb) Deallocate (bc1) -1000 if (rank == 0) write (*, '("e2f(",I3,") = ",E20.10," a.u.")') isym, e2(isym) + if (rank == 0) print '("e2f(",I3,") = ",E20.10," a.u.")', isym, e2(isym) e2f = e2f + e2(isym) - if (rank == 0) then ! Process limits for output - write (*, *) 'End e2(isym) add' - end if + if (rank == 0) print *, 'End e2(isym) add' Call timing(datetmp1, tsectmp1, datetmp0, tsectmp0) datetmp1 = datetmp0 tsectmp1 = tsectmp0 End do ! isym - if (rank == 0) then ! Process limits for output - write (*, '("e2f = ",E20.10," a.u.")') e2f - write (*, '("sumc2,f = ",E20.10)') sumc2local + if (rank == 0) then + print '("e2f = ",E20.10," a.u.")', e2f + print '("sumc2,f = ",E20.10)', sumc2local end if sumc2 = sumc2 + sumc2local @@ -400,10 +356,7 @@ SUBROUTINE solvF_ord_ty(e0, e2f) deallocate (ib0) deallocate (v) - continue - if (rank == 0) then ! Process limits for output - write (*, *) 'end solvF_ord_ty' - end if + if (rank == 0) print *, 'end solvF_ord_ty' end ! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= @@ -492,9 +445,7 @@ SUBROUTINE bFmat(dimn, sc, indsym, bc) ! Assume C1 molecule, overlap matrix B in bc(:, :) = 0.0d+00 - if (rank == 0) then ! Process limits for output - write (*, *) 'F space Bmat iroot=', iroot - end if + if (rank == 0) print *, 'F space Bmat iroot=', iroot !$OMP parallel do schedule(dynamic,1) private(iv,jv,ix,jx,j,it,jt,iu,ju,e,iw,jw,denr,deni,den) Do i = rank + 1, dimn, nprocs @@ -546,9 +497,7 @@ SUBROUTINE bFmat(dimn, sc, indsym, bc) ! Assume C1 molecule, overlap matrix B in call MPI_Reduce(bc(1, 1), bc(1, 1), dimn**2, MPI_COMPLEX16, MPI_SUM, 0, MPI_COMM_WORLD, ierr) end if #endif - if (rank == 0) then ! Process limits for output - write (*, *) 'bFmat is ended' - end if + if (rank == 0) print *, 'bFmat is ended' End subroutine bFmat ! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= @@ -576,11 +525,11 @@ SUBROUTINE vFmat_ord(nab, iab, v) complex*16 :: cint2, dens integer :: i, j, k, l, tab, ip, iq - integer :: it, jt, ju, iu + integer :: it, jt, ju, iu, iostat integer :: datetmp0, datetmp1 real(8) :: tsectmp0, tsectmp1 - if (rank == 0) write (*, *) 'Enter vFmat. Please ignore timer under this line.' + if (rank == 0) print *, 'Enter vFmat. Please ignore timer under this line.' datetmp1 = date0; datetmp0 = date0 Call timing(date0, tsec0, datetmp0, tsectmp0) tsectmp1 = tsectmp0 @@ -589,46 +538,51 @@ SUBROUTINE vFmat_ord(nab, iab, v) ! 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 + 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' + 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 + 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) ! ! p=j, q=l loop for t and u u=j, p=l loop for t ! - !$OMP parallel do schedule(dynamic,1) private(it,iu,dr,di,dens) - Do it = 1, nact - Do iu = 1, it - 1 - Call dim2_density(it, j, iu, l, dr, di) - dens = DCMPLX(dr, di) - v(tab, it, iu) = v(tab, it, iu) + cint2*dens - End do ! iu - - Call dim1_density(it, l, dr, di) - dens = DCMPLX(dr, di) - v(tab, it, j) = v(tab, it, j) - cint2*dens - - End do ! ip - !$OMP end parallel do + !$OMP parallel do schedule(dynamic,1) private(it,iu,dr,di,dens) + Do it = 1, nact + Do iu = 1, it - 1 + Call dim2_density(it, j, iu, l, dr, di) + dens = DCMPLX(dr, di) + v(tab, it, iu) = v(tab, it, iu) + cint2*dens + End do ! iu - goto 30 + Call dim1_density(it, l, dr, di) + dens = DCMPLX(dr, di) + v(tab, it, j) = v(tab, it, j) - cint2*dens -20 close (1); goto 100 + End do ! ip + !$OMP end parallel do + end do -10 write (*, *) 'error while opening file Fint'; goto 100 + close (1) -100 if (rank == 0) write (*, *) 'vFmat_ord is ended' + if (rank == 0) print *, 'vFmat_ord is ended' #ifdef HAVE_MPI call MPI_Allreduce(MPI_IN_PLACE, v(1, 1, 1), nab*nact**2, MPI_COMPLEX16, MPI_SUM, MPI_COMM_WORLD, ierr) + if (rank == 0) print *, 'end allreduce vFmat' #endif - if (rank == 0) write (*, *) 'end allreduce vFmat' Call timing(datetmp1, tsectmp1, datetmp0, tsectmp0) datetmp1 = datetmp0 tsectmp1 = tsectmp0 diff --git a/src/solvall_G_ord_ty.f90 b/src/solvall_G_ord_ty.f90 index 67ae1aa7..0e4b44d2 100644 --- a/src/solvall_G_ord_ty.f90 +++ b/src/solvall_G_ord_ty.f90 @@ -58,9 +58,9 @@ SUBROUTINE solvG_ord_ty(e0, e2g) ! ! E2 = SIGUMA_iab, dimm |V1(t,iab)|^2|/{(alpha(iab) + wb(t)} ! - if (rank == 0) then ! Process limits for output - write (*, *) ' ENTER solv G part' - write (*, *) ' nsymrpa', nsymrpa + if (rank == 0) then + print *, ' ENTER solv G part' + print *, ' nsymrpa', nsymrpa end if datetmp1 = date0; datetmp0 = date0 @@ -113,18 +113,16 @@ SUBROUTINE solvG_ord_ty(e0, e2g) Allocate (v(nabi, nact)) v = 0.0d+00 - if (rank == 0) then ! Process limits for output - write (*, *) 'come' - end if + if (rank == 0) print *, 'come' #ifdef HAVE_MPI call MPI_Barrier(MPI_COMM_WORLD, ierr) #endif - if (rank == 0) write (*, *) 'end before v matrices' + if (rank == 0) print *, 'end before v matrices' Call timing(datetmp1, tsectmp1, datetmp0, tsectmp0) datetmp1 = datetmp0 tsectmp1 = tsectmp0 Call vGmat_ord_ty(nabi, iabi, v) - if (rank == 0) write (*, *) 'end after vGmat' + if (rank == 0) print *, 'end after vGmat' Call timing(datetmp1, tsectmp1, datetmp0, tsectmp0) datetmp1 = datetmp0 tsectmp1 = tsectmp0 @@ -140,24 +138,18 @@ SUBROUTINE solvG_ord_ty(e0, e2g) End if End do ! it - if (rank == 0) then ! Process limits for output - write (*, *) 'isym, dimn', isym, dimn - end if - If (dimn == 0) goto 1000 + if (rank == 0) print *, 'isym, dimn', isym, dimn + If (dimn == 0) cycle ! Go to the next isym Allocate (sc(dimn, dimn)) sc = 0.0d+00 ! sc N*N - if (rank == 0) then ! Process limits for output - write (*, *) 'before sGmat' - end if + if (rank == 0) print *, 'before sGmat' Call timing(datetmp1, tsectmp1, datetmp0, tsectmp0) datetmp1 = datetmp0 tsectmp1 = tsectmp0 Call sGmat(dimn, indt(1:dimn), sc) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - if (rank == 0) then ! Process limits for output - write (*, *) 'sG matrix is obtained normally' - end if + if (rank == 0) print *, 'sG matrix is obtained normally' Call timing(datetmp1, tsectmp1, datetmp0, tsectmp0) datetmp1 = datetmp0 tsectmp1 = tsectmp0 @@ -168,17 +160,13 @@ SUBROUTINE solvG_ord_ty(e0, e2g) Allocate (sc0(dimn, dimn)) sc0 = sc - if (rank == 0) then ! Process limits for output - write (*, *) 'before cdiag' - end if + if (rank == 0) print *, 'before cdiag' Call timing(datetmp1, tsectmp1, datetmp0, tsectmp0) datetmp1 = datetmp0 tsectmp1 = tsectmp0 Call cdiag(sc, dimn, dimm, ws, thresd, cutoff) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - if (rank == 0) then ! Process limits for output - write (*, *) 'after s cdiag, new dimension is', dimm - end if + if (rank == 0) print *, 'after s cdiag, new dimension is', dimm Call timing(datetmp1, tsectmp1, datetmp0, tsectmp0) datetmp1 = datetmp0 tsectmp1 = tsectmp0 @@ -186,68 +174,52 @@ SUBROUTINE solvG_ord_ty(e0, e2g) deallocate (sc0) deallocate (sc) deallocate (ws) - goto 1000 + cycle ! Go to the next isym End if If (debug) then - if (rank == 0) then ! Process limits for output - write (*, *) 'Check whether U*SU is diagonal' - end if + if (rank == 0) print *, 'Check whether U*SU is diagonal' Call checkdgc(dimn, sc0, sc, ws) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - if (rank == 0) then ! Process limits for output - write (*, *) 'Check whether U*SU is diagonal END' - end if + if (rank == 0) print *, 'Check whether U*SU is diagonal END' End if Allocate (bc(dimn, dimn)) ! bc N*N bc = 0.0d+00 - if (rank == 0) then ! Process limits for output - write (*, *) 'before bGmat' - end if + if (rank == 0) print *, 'before bGmat' Call timing(datetmp1, tsectmp1, datetmp0, tsectmp0) datetmp1 = datetmp0 tsectmp1 = tsectmp0 Call bGmat(dimn, sc0, indt(1:dimn), bc) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - if (rank == 0) then ! Process limits for output - write (*, *) 'bC matrix is obtained normally' - end if + if (rank == 0) print *, 'bC matrix is obtained normally' Call timing(datetmp1, tsectmp1, datetmp0, tsectmp0) datetmp1 = datetmp0 tsectmp1 = tsectmp0 deallocate (sc0) - if (rank == 0) then ! Process limits for output - write (*, *) 'OK cdiag', dimn, dimm - end if + if (rank == 0) print *, 'OK cdiag', dimn, dimm Allocate (uc(dimn, dimm)) ! uc N*M Allocate (wsnew(dimm)) ! wnew M uc(:, :) = 0.0d+00 wsnew(:) = 0.0d+00 - if (rank == 0) then ! Process limits for output - write (*, *) 'before ccutoff' - end if + if (rank == 0) print *, 'before ccutoff' Call timing(datetmp1, tsectmp1, datetmp0, tsectmp0) datetmp1 = datetmp0 tsectmp1 = tsectmp0 Call ccutoff(sc, ws, dimn, dimm, uc, wsnew) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - if (rank == 0) then ! Process limits for output - write (*, *) 'OK ccutoff' - end if + if (rank == 0) print *, 'OK ccutoff' Call timing(datetmp1, tsectmp1, datetmp0, tsectmp0) datetmp1 = datetmp0 tsectmp1 = tsectmp0 deallocate (ws) deallocate (sc) - if (rank == 0) then ! Process limits for output - write (*, *) 'before ucramda_s_half' - end if + if (rank == 0) print *, 'before ucramda_s_half' Call timing(datetmp1, tsectmp1, datetmp0, tsectmp0) datetmp1 = datetmp0 tsectmp1 = tsectmp0 @@ -255,9 +227,7 @@ SUBROUTINE solvG_ord_ty(e0, e2g) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ deallocate (wsnew) - if (rank == 0) then ! Process limits for output - write (*, *) 'ucrams half OK' - end if + if (rank == 0) print *, 'ucrams half OK' Call timing(datetmp1, tsectmp1, datetmp0, tsectmp0) datetmp1 = datetmp0 tsectmp1 = tsectmp0 @@ -270,16 +240,16 @@ SUBROUTINE solvG_ord_ty(e0, e2g) If (debug) then - if (rank == 0) then ! Process limits for output - write (*, *) 'Check whether bc1 is hermite or not' + if (rank == 0) then + print *, '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) + print '(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' + print *, 'Check whether bc1 is hermite or not END' end if End if @@ -290,43 +260,31 @@ SUBROUTINE solvG_ord_ty(e0, e2g) Allocate (wb(dimm)) - if (rank == 0) then ! Process limits for output - write (*, *) 'bC matrix is transrated to bc1(M*M matrix)!' - end if + if (rank == 0) print *, 'bC matrix is transrated to bc1(M*M matrix)!' Allocate (bc0(dimm, dimm)) bc0 = bc1 - if (rank == 0) then ! Process limits for output - write (*, *) 'before cdiag' - end if + if (rank == 0) print *, 'before cdiag' Call timing(datetmp1, tsectmp1, datetmp0, tsectmp0) datetmp1 = datetmp0 tsectmp1 = tsectmp0 Call cdiag(bc1, dimm, dammy, wb, thresd, cutoff) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - if (rank == 0) then ! Process limits for output - write (*, *) 'end cdiag' - end if + if (rank == 0) print *, 'end cdiag' Call timing(datetmp1, tsectmp1, datetmp0, tsectmp0) datetmp1 = datetmp0 tsectmp1 = tsectmp0 If (debug) then - if (rank == 0) then ! Process limits for output - write (*, *) 'Check whether bc is really diagonalized or not' - end if + if (rank == 0) print *, 'Check whether bc is really diagonalized or not' Call checkdgc(dimm, bc0, bc1, wb) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - if (rank == 0) then ! Process limits for output - write (*, *) 'Check whether bc is really diagonalized or not END' - end if + if (rank == 0) print *, 'Check whether bc is really diagonalized or not END' End if deallocate (bc0) - if (rank == 0) then ! Process limits for output - write (*, *) 'bC1 matrix is diagonalized!' - end if + if (rank == 0) print *, 'bC1 matrix is diagonalized!' e2 = 0.0d+00 @@ -375,19 +333,17 @@ SUBROUTINE solvG_ord_ty(e0, e2g) deallocate (wb) Deallocate (bc1) -1000 if (rank == 0) write (*, '("e2g(",I3,") = ",E20.10," a.u.")') isym, e2(isym) + if (rank == 0) print '("e2g(",I3,") = ",E20.10," a.u.")', isym, e2(isym) e2g = e2g + e2(isym) - if (rank == 0) then ! Process limits for output - write (*, *) 'End e2(isym) add' - end if + if (rank == 0) print *, 'End e2(isym) add' Call timing(datetmp1, tsectmp1, datetmp0, tsectmp0) datetmp1 = datetmp0 tsectmp1 = tsectmp0 End do ! isym - if (rank == 0) then ! Process limits for output - write (*, '("e2g = ",E20.10," a.u.")') e2g - write (*, '("sumc2,g = ",E20.10)') sumc2local + if (rank == 0) then + print '("e2g = ",E20.10," a.u.")', e2g + print '("sumc2,g = ",E20.10)', sumc2local end if sumc2 = sumc2 + sumc2local @@ -398,9 +354,7 @@ SUBROUTINE solvG_ord_ty(e0, e2g) deallocate (v) continue - if (rank == 0) then ! Process limits for output - write (*, *) 'end solvG_ord_ty' - end if + if (rank == 0) print *, 'end solvG_ord_ty' end ! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= @@ -482,9 +436,7 @@ SUBROUTINE bGmat(dimn, sc, indt, bc) ! Assume C1 molecule, overlap matrix B in s bc(:, :) = 0.0d+00 - if (rank == 0) then ! Process limits for output - write (*, *) 'G space Bmat iroot=', iroot - end if + if (rank == 0) print *, 'G space Bmat iroot=', iroot ! !$OMP parallel do schedule(dynamic,1) private(iu,ju,j,it,jt,iw,jw,denr,deni,den) Do i = rank + 1, dimn, nprocs @@ -520,9 +472,7 @@ SUBROUTINE bGmat(dimn, sc, indt, bc) ! Assume C1 molecule, overlap matrix B in s call MPI_Reduce(bc(1, 1), bc(1, 1), dimn**2, MPI_COMPLEX16, MPI_SUM, 0, MPI_COMM_WORLD, ierr) end if #endif - if (rank == 0) then ! Process limits for output - write (*, *) 'bGmat is ended' - end if + if (rank == 0) print *, 'bGmat is ended' End subroutine bGmat ! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= @@ -550,11 +500,11 @@ SUBROUTINE vGmat_ord_ty(nabi, iabi, v) complex*16 :: cint2, dens integer :: i, j, k, l, tabi - integer :: it, jt, il + integer :: it, jt, il, iostat integer :: datetmp0, datetmp1 real(8) :: tsectmp0, tsectmp1 - if (rank == 0) write (*, *) 'Enter vGmat. Please ignore timer under this line.' + 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 @@ -562,34 +512,39 @@ SUBROUTINE vGmat_ord_ty(nabi, iabi, v) ! 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 - - tabi = iabi(i, k, j) - - if (i < k) then - cint2 = -1.0d+00*cint2 - end if + 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' + 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 - ! il = l - ninact + tabi = iabi(i, k, j) - Do it = 1, nact - Call dim1_density(it, l, dr, di) - dens = DCMPLX(dr, di) - v(tabi, it) = v(tabi, it) + cint2*dens - End do ! it + if (i < k) then + cint2 = -1.0d+00*cint2 + end if + ! il = l - ninact - goto 30 + Do it = 1, nact + Call dim1_density(it, l, dr, di) + dens = DCMPLX(dr, di) + v(tabi, it) = v(tabi, it) + cint2*dens + End do ! it -20 close (1); goto 100 -10 if (rank == 0) write (*, *) 'error while opening file Gint'; goto 100 + end do -100 if (rank == 0) write (*, *) 'vGmat_ord_ty is ended' + 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) + if (rank == 0) print *, 'end allreduce vGmat' #endif - if (rank == 0) write (*, *) 'end allreduce vGmat' Call timing(datetmp1, tsectmp1, datetmp0, tsectmp0) datetmp1 = datetmp0 tsectmp1 = tsectmp0 diff --git a/src/solvall_H_ord_ty.f90 b/src/solvall_H_ord_ty.f90 index 3b721c76..8dee13d8 100644 --- a/src/solvall_H_ord_ty.f90 +++ b/src/solvall_H_ord_ty.f90 @@ -15,7 +15,7 @@ SUBROUTINE solvH_ord_ty(e0, e2h) 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, count + Integer :: i0, j0, tab, nab, tij, nij, iostat Integer, allocatable :: ia0(:), ib0(:), ii0(:), ij0(:), iab(:, :), iij(:, :) Complex*16 :: cint2 Complex*16, allocatable :: v(:, :) @@ -98,37 +98,42 @@ SUBROUTINE solvH_ord_ty(e0, e2h) 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 + 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 Hint' + 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 Hint' + end if + if (i <= k .or. j == l) cycle ! Read the next line if i <= k or j == l - if (i <= k .or. j == l) goto 30 + tab = iab(i, k) + tij = iij(j, l) - tab = iab(i, k) - tij = iij(j, l) + if (i > k .and. j > l) then + v(tab, tij) = v(tab, tij) + cint2 - 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 - 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 ! (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 - elseif (i < k .and. j < l) then - v(tab, tij) = v(tab, tij) + cint2 + end if - end if - - goto 30 + end do -20 close (1) + 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) then ! Process limits for output - write (*, *) 'reading int2 is over' - end if + if (rank == 0) print *, 'reading Hint is over' Do i0 = 1, nab ia = ia0(i0) @@ -154,9 +159,9 @@ SUBROUTINE solvH_ord_ty(e0, e2h) End do End do - if (rank == 0) then ! Process limits for output - write (*, '("e2h = ",E20.10," a.u.")') e2h - write (*, '("sumc2,h = ",E20.10)') sumc2local + if (rank == 0) then + print '("e2h = ",E20.10," a.u.")', e2h + print '("sumc2,h = ",E20.10)', sumc2local end if sumc2 = sumc2 + sumc2local @@ -168,8 +173,5 @@ SUBROUTINE solvH_ord_ty(e0, e2h) deallocate (ii0) deallocate (ij0) -10 continue !write(*,*)'error about opening Hint file' ;stop - if (rank == 0) then ! Process limits for output - write (*, *) 'end solvH_ord_ty' - end if + if (rank == 0) print *, 'end solvH_ord_ty' End SUBROUTINE solvH_ord_ty diff --git a/src/timing.f90 b/src/timing.f90 index 7cff04b4..045187fc 100644 --- a/src/timing.f90 +++ b/src/timing.f90 @@ -24,14 +24,13 @@ SUBROUTINE timing(date0, tsec0, date, tsec) difsec = tsec - tsec0 - if (rank == 0) then ! Process limits for output - write (*, '("Present time is")') - write (*, '("year = ",I4,"month = ",I4,"date = ",I4 )') val(1), val(2), val(3) - write (*, '(14X,I4,"h ",I4,"min ",I2,".",I3,"sec " )')& + if (rank == 0) then + print '("Present time is")' + print '("year = ",I4,"month = ",I4,"date = ",I4 )', val(1), val(2), val(3) + print '(14X,I4,"h ",I4,"min ",I2,".",I3,"sec " )',& & val(5), val(6), val(7), val(8) end if - day = AINT(difsec)/(3600*24) resd = difsec - day*3600*24 @@ -42,8 +41,8 @@ SUBROUTINE timing(date0, tsec0, date, tsec) resd = resd - min*60 sec = resd - if (rank == 0) then ! Process limits for output + if (rank == 0) then write (*, '("computational time = ",I3,"day",I3,"h ",I3, & &"min",F7.3,"sec")') day, hour, min, sec end if -100 end subroutine timing +end subroutine timing diff --git a/src/trac.f90 b/src/trac.f90 index 3d8ce34f..57a69368 100644 --- a/src/trac.f90 +++ b/src/trac.f90 @@ -24,9 +24,7 @@ SUBROUTINE traci(fa) ! Transform CI matrix for new spinor basis ! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= occ = 0 - if (rank == 0) then ! Process limits for output - write (*, *) 'Enter TRACI' - end if + if (rank == 0) print *, 'Enter TRACI' Do i0 = 1, ndet i = 0 @@ -103,9 +101,7 @@ SUBROUTINE traci(fa) ! Transform CI matrix for new spinor basis ! for a while ! End do ! for a while ! End do - if (rank == 0) then ! Process limits for output - write (*, *) 'Obtain inverse of ds matrix' - end if + if (rank == 0) print *, 'Obtain inverse of ds matrix' Allocate (IPIV(ndet)) Allocate (dsold(ndet, ndet)) @@ -113,16 +109,12 @@ SUBROUTINE traci(fa) ! Transform CI matrix for new spinor basis dsold = ds Call ZGETRF(ndet, ndet, ds, ndet, IPIV, INFO)! SUBROUTINE ZGETRF( M, N, A, LDA, IPIV, INFO ) - if (rank == 0) then ! Process limits for output - write (*, *) 'info', info - end if + if (rank == 0) print *, 'info', info Allocate (work(ndet)) Call ZGETRI(ndet, ds, ndet, IPIV, WORK, ndet, INFO) - if (rank == 0) then ! Process limits for output - write (*, *) 'info', info - end if + if (rank == 0) print *, 'info', info ! for a while ! write(*,'(/,"REAL")') ! for a while ! Do i0 = 1, ndet @@ -151,9 +143,7 @@ SUBROUTINE traci(fa) ! Transform CI matrix for new spinor basis Deallocate (work) Deallocate (IPIV) - if (rank == 0) then ! Process limits for output - write (*, *) 'Check whether inverese matrix is really so' - end if + if (rank == 0) print *, 'Check whether inverese matrix is really so' error = .FALSE. @@ -163,22 +153,16 @@ SUBROUTINE traci(fa) ! Transform CI matrix for new spinor basis If ((i0 /= j0) .and. ABS(dsold(i0, j0)) > 1.0d-10) then error = .TRUE. - if (rank == 0) then ! Process limits for output - write (*, '(2I4,2E13.5)') i0, j0, dsold(i0, j0) - end if + if (rank == 0) print '(2I4,2E13.5)', i0, j0, dsold(i0, j0) Elseif (i0 == j0 .and. ABS(dsold(i0, j0) - 1.0d+00) > 1.0d-10) then error = .TRUE. - if (rank == 0) then ! Process limits for output - write (*, '(2I4,2E13.5)') i0, j0, dsold(i0, j0) - end if + if (rank == 0) print '(2I4,2E13.5)', i0, j0, dsold(i0, j0) End if End do End do - if (rank == 0) then ! Process limits for output - If (.not. error) write (*, *) 'Inverse matrix is obtained correclty' - end if + if (rank == 0) print *, 'Inverse matrix is obtained correclty' Deallocate (dsold) ! Now ds is inverse matrix! @@ -238,9 +222,7 @@ SUBROUTINE tracic(fac) ! Transform CI matrix for new spinor basis ! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= occ = 0 - if (rank == 0) then ! Process limits for output - write (*, *) 'Enter TRACI' - end if + if (rank == 0) print *, 'Enter TRACI' datetmp1 = date0; datetmp0 = date0 Call timing(date0, tsec0, datetmp0, tsectmp0) @@ -248,28 +230,24 @@ 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) write (*, *) 'Before allocate a matrix named ds' + if (rank == 0) print *, 'Before allocate a matrix named ds' Call timing(datetmp1, tsectmp1, datetmp0, tsectmp0) datetmp1 = datetmp0 tsectmp1 = tsectmp0 Allocate (ds(ndet, ndet)) ds = 0.0d+00 - if (rank == 0) write (*, *) 'Initialized a matrix named ds' + if (rank == 0) print *, 'Initialized a matrix named ds' Call timing(datetmp1, tsectmp1, datetmp0, tsectmp0) datetmp1 = datetmp0 tsectmp1 = tsectmp0 @@ -282,18 +260,16 @@ SUBROUTINE tracic(fac) ! Transform CI matrix for new spinor basis End do End do - if (rank == 0) write (*, *) 'End detsc' + if (rank == 0) print *, 'End detsc' Call timing(datetmp1, tsectmp1, datetmp0, tsectmp0) datetmp1 = datetmp0 tsectmp1 = tsectmp0 - if (rank == 0) then ! Process limits for output - write (*, *) 'Obtain inverse of ds matrix' - end if + if (rank == 0) print *, 'Obtain inverse of ds matrix' Allocate (IPIV(ndet)) Allocate (dsold(ndet, ndet)) dsold = ds - if (rank == 0) write (*, *) 'Start get LU factorization of ds' + if (rank == 0) print *, 'Start get LU factorization of ds' Call timing(datetmp1, tsectmp1, datetmp0, tsectmp0) datetmp1 = datetmp0 tsectmp1 = tsectmp0 @@ -303,38 +279,32 @@ SUBROUTINE tracic(fac) ! Transform CI matrix for new spinor basis ! ZGETRIはLU分解したものを使って逆行列を計算する ! つまりZGETRF+ZGETRIの計算量はO(n^3)でcdiagと同等の計算量が必要 Call ZGETRF(ndet, ndet, ds, ndet, IPIV, INFO) - if (rank == 0) then ! Process limits for output - write (*, *) 'info', info - end if + if (rank == 0) print *, 'info', info #ifdef HAVE_MPI call MPI_Barrier(MPI_COMM_WORLD, ierr) #endif - if (rank == 0) write (*, *) 'End get LU factorization of ds' + if (rank == 0) print *, 'End get LU factorization of ds' Call timing(datetmp1, tsectmp1, datetmp0, tsectmp0) datetmp1 = datetmp0 tsectmp1 = tsectmp0 Allocate (work(ndet)) - if (rank == 0) write (*, *) 'Start get a inverse matrix of ds' + if (rank == 0) print *, 'Start get a inverse matrix of ds' Call timing(datetmp1, tsectmp1, datetmp0, tsectmp0) datetmp1 = datetmp0 tsectmp1 = tsectmp0 Call ZGETRI(ndet, ds, ndet, IPIV, WORK, ndet, INFO) - if (rank == 0) then ! Process limits for output - write (*, *) 'info', info - end if + if (rank == 0) print *, 'info', info #ifdef HAVE_MPI call MPI_Barrier(MPI_COMM_WORLD, ierr) #endif - if (rank == 0) write (*, *) 'End get a inverse matrix of ds, ndet', ndet + if (rank == 0) print *, 'End get a inverse matrix of ds, ndet', ndet Call timing(datetmp1, tsectmp1, datetmp0, tsectmp0) datetmp1 = datetmp0 tsectmp1 = tsectmp0 Deallocate (work) Deallocate (IPIV) #ifdef DEBUG - if (rank == 0) then ! Process limits for output - write (*, *) 'Check whether inverese matrix is really so' - end if + if (rank == 0) print *, 'Check whether inverese matrix is really so' error = .FALSE. ! Noda ndet^2で回っているので遅くなりそう @@ -345,7 +315,7 @@ SUBROUTINE tracic(fac) ! Transform CI matrix for new spinor basis #ifdef HAVE_MPI call MPI_Barrier(MPI_COMM_WORLD, ierr) #endif - if (rank == 0) write (*, *) 'End dsold = matmul(ds, dsold) so dsold should be a identity matrix.' + if (rank == 0) print *, 'End dsold = matmul(ds, dsold) so dsold should be a identity matrix.' Call timing(datetmp1, tsectmp1, datetmp0, tsectmp0) datetmp1 = datetmp0 tsectmp1 = tsectmp0 @@ -354,7 +324,7 @@ SUBROUTINE tracic(fac) ! Transform CI matrix for new spinor basis ! end do ! if (maxval(abs(real(dsold))) > 1.0d-10) then ! if (rank == 0) then - ! write (*, '(E13.5)') maxval(abs(real(dsold))) + ! print '(E13.5)', maxval(abs(real(dsold))) ! end if ! end if Do i0 = 1, ndet @@ -362,22 +332,16 @@ SUBROUTINE tracic(fac) ! Transform CI matrix for new spinor basis If ((i0 /= j0) .and. ABS(dsold(i0, j0)) > 1.0d-10) then error = .TRUE. - if (rank == 0) then ! Process limits for output - write (*, '(2I4,2E13.5)') i0, j0, dsold(i0, j0) - end if + if (rank == 0) print '(2I4,2E13.5)', i0, j0, dsold(i0, j0) Elseif (i0 == j0 .and. ABS(dsold(i0, j0) - 1.0d+00) > 1.0d-10) then error = .TRUE. - if (rank == 0) then ! Process limits for output - write (*, '(2I4,2E13.5)') i0, j0, dsold(i0, j0) - end if + if (rank == 0) print '(2I4,2E13.5)', i0, j0, dsold(i0, j0) End if End do End do - if (rank == 0) then ! Process limits for output - If (.not. error) write (*, *) 'Inverse matrix is obtained correclty' - end if + if (rank == 0) print *, 'Inverse matrix is obtained correclty' #endif Call timing(datetmp1, tsectmp1, datetmp0, tsectmp0) datetmp1 = datetmp0 diff --git a/test/h2/test_h2.py b/test/h2/test_h2.py index 346730ef..12523d8c 100644 --- a/test/h2/test_h2.py +++ b/test/h2/test_h2.py @@ -1,20 +1,17 @@ -import shutil -import subprocess import os -import sys +import shutil import pytest -import glob - +from module_testing import ( + delete_scratch_files, + is_binary_file_exist, + create_test_command, + run_test, + check_test_returncode, + get_caspt2_energy_from_output_file, +) -# Delete delete_files in the test_path -def delete_scratch_files(delete_files: "list[str]", test_path: str) -> None: - for d in delete_files: - files = glob.glob(os.path.abspath(os.path.join(test_path, d))) - for f in files: - os.remove(f) - -def test_h2(the_number_of_process: int) -> None: +def test_h2o(the_number_of_process: int) -> None: # Set file names ref_filename = "reference.H2.out" # Reference @@ -29,14 +26,16 @@ def test_h2(the_number_of_process: int) -> None: # Set file paths ref_file_path = os.path.abspath(os.path.join(test_path, ref_filename)) output_file_path = os.path.abspath(os.path.join(test_path, output_filename)) - latest_passed_path = os.path.abspath(os.path.join(test_path, latest_passed_output)) + latest_passed_file_path = os.path.abspath( + os.path.join(test_path, latest_passed_output) + ) binary_dir = os.path.abspath( os.path.join(test_path, "../../bin") ) # Set the Built binary directory - r4dcasci: str = os.path.abspath( + r4dcasci = os.path.abspath( os.path.join(binary_dir, "r4dcascicoexe") ) # CASCI binary - r4dcaspt2: str = os.path.abspath( + r4dcaspt2 = os.path.abspath( os.path.join(binary_dir, "r4dcaspt2ocoexe") ) # CASPT2 binary @@ -56,75 +55,24 @@ def test_h2(the_number_of_process: int) -> None: # Delete files because of previous test may illegally failed and created files that are not expected delete_scratch_files(delete_files, test_path) - # Check binary files are exist - if os.path.exists(r4dcasci) is False: - error_message = ( - f"ERROR: {r4dcasci} is not exist.\nPlease build {r4dcasci} first." - ) - print(error_message, file=sys.stderr) - # Exit with error message - sys.exit(error_message) - if os.path.exists(r4dcaspt2) is False: - error_message = ( - f"ERROR: {r4dcaspt2} is not exist.\nPlease build {r4dcaspt2} first." - ) - print(error_message, file=sys.stderr) - # Exit with error message - sys.exit(error_message) + is_binary_file_exist(r4dcasci) + is_binary_file_exist(r4dcaspt2) - # Set test command - test_command = "" - if the_number_of_process > 1: # If the number of process is greater than 1, use MPI - test_command = f"mpirun -np {the_number_of_process} {r4dcasci} && mpirun -np {the_number_of_process} {r4dcaspt2}" - else: # If the number of process is 1, use serial - test_command = f"{r4dcasci} && {r4dcaspt2}" - # Run calculation - with open(output_file_path, "w") as file_output: - p = subprocess.run( - test_command, - shell=True, - encoding="utf-8", - stdout=file_output, # Redirect output to file_output - ) - status = "CASCI/CASPT2 status " + str(p.returncode) - # If the return code is not 0, print error message, probably calculation failed - if p.returncode != 0: - print(status, file=sys.stderr) + binaries = [r4dcasci, r4dcaspt2] + test_command = create_test_command(the_number_of_process, binaries) - # Delete scratch files - delete_scratch_files(delete_files, test_path) + process = run_test(test_command, output_file_path) + check_test_returncode(process) - # Check output - with open(ref_file_path, encoding="utf-8", mode="r") as file_ref: - try: # Try to get the reference data - # (e.g. ['Total energy is -1.117672932144052 a.u.']) - grep_str_ref: list[str] = [ - s.strip() for s in file_ref.readlines() if "Total energy is" in s - ] - ref_energy = float( - grep_str_ref[-1].split()[-2] - ) # (e.g. -1.117672932144052) - except Exception as error: # Failed to get the reference data - error_message = f"{error}\nERROR: Failed to get the CASPT2 energy from the reference file {ref_file_path}." - # Exit with error message - sys.exit(error_message) + delete_scratch_files(delete_files, test_path) - # Grep the test output file - with open(output_file_path, encoding="utf-8", mode="r") as file_output: - try: # Try to get the test data - grep_str_output: list[str] = [ - s.strip() for s in file_output.readlines() if "Total energy is" in s - ] - output_energy = float(grep_str_output[-1].split()[-2]) - except Exception as error: # Failed to get the test data - error_message = f"{error}\nERROR: Failed to get the CASPT2 energy from the test file {output_file_path}." - # Exit with error message - sys.exit(error_message) + ref_energy = get_caspt2_energy_from_output_file(ref_file_path) + test_energy = get_caspt2_energy_from_output_file(output_file_path) # Check whether the output of test run # matches the reference to 7th decimal places. - assert output_energy == pytest.approx(ref_energy, abs=1e-8) + assert test_energy == pytest.approx(ref_energy, abs=1e-8) # If it reaches this point, the result of assert is true. # The latest passed output file is overwritten by the current output file if assert is True. - shutil.copy(output_file_path, latest_passed_path) + shutil.copy(output_file_path, latest_passed_file_path) diff --git a/test/h2o/.gitignore b/test/h2o/.gitignore new file mode 100644 index 00000000..8b137891 --- /dev/null +++ b/test/h2o/.gitignore @@ -0,0 +1 @@ + diff --git a/test/h2o/test_h2o.py b/test/h2o/test_h2o.py index b7d18f56..2f115266 100644 --- a/test/h2o/test_h2o.py +++ b/test/h2o/test_h2o.py @@ -1,17 +1,14 @@ -import shutil -import subprocess import os -import sys +import shutil import pytest -import glob - - -# Delete delete_files in the test_path -def delete_scratch_files(delete_files: "list[str]", test_path: str) -> None: - for d in delete_files: - files = glob.glob(os.path.abspath(os.path.join(test_path, d))) - for f in files: - os.remove(f) +from module_testing import ( + delete_scratch_files, + is_binary_file_exist, + create_test_command, + run_test, + check_test_returncode, + get_caspt2_energy_from_output_file, +) def test_h2o(the_number_of_process: int) -> None: @@ -29,14 +26,16 @@ def test_h2o(the_number_of_process: int) -> None: # Set file paths ref_file_path = os.path.abspath(os.path.join(test_path, ref_filename)) output_file_path = os.path.abspath(os.path.join(test_path, output_filename)) - latest_passed_path = os.path.abspath(os.path.join(test_path, latest_passed_output)) + latest_passed_file_path = os.path.abspath( + os.path.join(test_path, latest_passed_output) + ) binary_dir = os.path.abspath( os.path.join(test_path, "../../bin") ) # Set the Built binary directory - r4dcasci: str = os.path.abspath( + r4dcasci = os.path.abspath( os.path.join(binary_dir, "r4dcascicoexe") ) # CASCI binary - r4dcaspt2: str = os.path.abspath( + r4dcaspt2 = os.path.abspath( os.path.join(binary_dir, "r4dcaspt2ocoexe") ) # CASPT2 binary @@ -56,75 +55,24 @@ def test_h2o(the_number_of_process: int) -> None: # Delete files because of previous test may illegally failed and created files that are not expected delete_scratch_files(delete_files, test_path) - # Check binary files are exist - if os.path.exists(r4dcasci) is False: - error_message = ( - f"ERROR: {r4dcasci} is not exist.\nPlease build {r4dcasci} first." - ) - print(error_message, file=sys.stderr) - # Exit with error message - sys.exit(error_message) - if os.path.exists(r4dcaspt2) is False: - error_message = ( - f"ERROR: {r4dcaspt2} is not exist.\nPlease build {r4dcaspt2} first." - ) - print(error_message, file=sys.stderr) - # Exit with error message - sys.exit(error_message) + is_binary_file_exist(r4dcasci) + is_binary_file_exist(r4dcaspt2) - # Set test command - test_command = "" - if the_number_of_process > 1: # If the number of process is greater than 1, use MPI - test_command = f"mpirun -np {the_number_of_process} {r4dcasci} && mpirun -np {the_number_of_process} {r4dcaspt2}" - else: # If the number of process is 1, use serial - test_command = f"{r4dcasci} && {r4dcaspt2}" - # Run calculation - with open(output_file_path, "w") as file_output: - p = subprocess.run( - test_command, - shell=True, - encoding="utf-8", - stdout=file_output, # Redirect output to file_output - ) - status = "CASCI/CASPT2 status " + str(p.returncode) - # If the return code is not 0, print error message, probably calculation failed - if p.returncode != 0: - print(status, file=sys.stderr) + binaries = [r4dcasci, r4dcaspt2] + test_command = create_test_command(the_number_of_process, binaries) - # Delete scratch files - delete_scratch_files(delete_files, test_path) + process = run_test(test_command, output_file_path) + check_test_returncode(process) - # Check output - with open(ref_file_path, encoding="utf-8", mode="r") as file_ref: - try: # Try to get the reference data - # (e.g. ['Total energy is -1.117672932144052 a.u.']) - grep_str_ref: list[str] = [ - s.strip() for s in file_ref.readlines() if "Total energy is" in s - ] - ref_energy = float( - grep_str_ref[-1].split()[-2] - ) # (e.g. -1.117672932144052) - except Exception as error: # Failed to get the reference data - error_message = f"{error}\nERROR: Failed to get the CASPT2 energy from the reference file {ref_file_path}." - # Exit with error message - sys.exit(error_message) + delete_scratch_files(delete_files, test_path) - # Grep the test output file - with open(output_file_path, encoding="utf-8", mode="r") as file_output: - try: # Try to get the test data - grep_str_output: list[str] = [ - s.strip() for s in file_output.readlines() if "Total energy is" in s - ] - output_energy = float(grep_str_output[-1].split()[-2]) - except Exception as error: # Failed to get the test data - error_message = f"{error}\nERROR: Failed to get the CASPT2 energy from the test file {output_file_path}." - # Exit with error message - sys.exit(error_message) + ref_energy = get_caspt2_energy_from_output_file(ref_file_path) + test_energy = get_caspt2_energy_from_output_file(output_file_path) # Check whether the output of test run # matches the reference to 7th decimal places. - assert output_energy == pytest.approx(ref_energy, abs=1e-8) + assert test_energy == pytest.approx(ref_energy, abs=1e-8) # If it reaches this point, the result of assert is true. # The latest passed output file is overwritten by the current output file if assert is True. - shutil.copy(output_file_path, latest_passed_path) + shutil.copy(output_file_path, latest_passed_file_path) diff --git a/test/lower_MPI_h2/test_lower_MPI_h2.py b/test/lower_MPI_h2/test_lower_MPI_h2.py index bc94816b..12523d8c 100644 --- a/test/lower_MPI_h2/test_lower_MPI_h2.py +++ b/test/lower_MPI_h2/test_lower_MPI_h2.py @@ -1,20 +1,17 @@ -import shutil -import subprocess import os -import sys +import shutil import pytest -import glob - +from module_testing import ( + delete_scratch_files, + is_binary_file_exist, + create_test_command, + run_test, + check_test_returncode, + get_caspt2_energy_from_output_file, +) -# Delete delete_files in the test_path -def delete_scratch_files(delete_files: "list[str]", test_path: str) -> None: - for d in delete_files: - files = glob.glob(os.path.abspath(os.path.join(test_path, d))) - for f in files: - os.remove(f) - -def test_lower_MPI_h2(the_number_of_process: int) -> None: +def test_h2o(the_number_of_process: int) -> None: # Set file names ref_filename = "reference.H2.out" # Reference @@ -29,14 +26,16 @@ def test_lower_MPI_h2(the_number_of_process: int) -> None: # Set file paths ref_file_path = os.path.abspath(os.path.join(test_path, ref_filename)) output_file_path = os.path.abspath(os.path.join(test_path, output_filename)) - latest_passed_path = os.path.abspath(os.path.join(test_path, latest_passed_output)) + latest_passed_file_path = os.path.abspath( + os.path.join(test_path, latest_passed_output) + ) binary_dir = os.path.abspath( os.path.join(test_path, "../../bin") ) # Set the Built binary directory - r4dcasci: str = os.path.abspath( + r4dcasci = os.path.abspath( os.path.join(binary_dir, "r4dcascicoexe") ) # CASCI binary - r4dcaspt2: str = os.path.abspath( + r4dcaspt2 = os.path.abspath( os.path.join(binary_dir, "r4dcaspt2ocoexe") ) # CASPT2 binary @@ -56,75 +55,24 @@ def test_lower_MPI_h2(the_number_of_process: int) -> None: # Delete files because of previous test may illegally failed and created files that are not expected delete_scratch_files(delete_files, test_path) - # Check binary files are exist - if os.path.exists(r4dcasci) is False: - error_message = ( - f"ERROR: {r4dcasci} is not exist.\nPlease build {r4dcasci} first." - ) - print(error_message, file=sys.stderr) - # Exit with error message - sys.exit(error_message) - if os.path.exists(r4dcaspt2) is False: - error_message = ( - f"ERROR: {r4dcaspt2} is not exist.\nPlease build {r4dcaspt2} first." - ) - print(error_message, file=sys.stderr) - # Exit with error message - sys.exit(error_message) + is_binary_file_exist(r4dcasci) + is_binary_file_exist(r4dcaspt2) - # Set test command - test_command = "" - if the_number_of_process > 1: # If the number of process is greater than 1, use MPI - test_command = f"mpirun -np {the_number_of_process} {r4dcasci} && mpirun -np {the_number_of_process} {r4dcaspt2}" - else: # If the number of process is 1, use serial - test_command = f"{r4dcasci} && {r4dcaspt2}" - # Run calculation - with open(output_file_path, "w") as file_output: - p = subprocess.run( - test_command, - shell=True, - encoding="utf-8", - stdout=file_output, # Redirect output to file_output - ) - status = "CASCI/CASPT2 status " + str(p.returncode) - # If the return code is not 0, print error message, probably calculation failed - if p.returncode != 0: - print(status, file=sys.stderr) + binaries = [r4dcasci, r4dcaspt2] + test_command = create_test_command(the_number_of_process, binaries) - # Delete scratch files - delete_scratch_files(delete_files, test_path) + process = run_test(test_command, output_file_path) + check_test_returncode(process) - # Check output - with open(ref_file_path, encoding="utf-8", mode="r") as file_ref: - try: # Try to get the reference data - # (e.g. ['Total energy is -1.117672932144052 a.u.']) - grep_str_ref: list[str] = [ - s.strip() for s in file_ref.readlines() if "Total energy is" in s - ] - ref_energy = float( - grep_str_ref[-1].split()[-2] - ) # (e.g. -1.117672932144052) - except Exception as error: # Failed to get the reference data - error_message = f"{error}\nERROR: Failed to get the CASPT2 energy from the reference file {ref_file_path}." - # Exit with error message - sys.exit(error_message) + delete_scratch_files(delete_files, test_path) - # Grep the test output file - with open(output_file_path, encoding="utf-8", mode="r") as file_output: - try: # Try to get the test data - grep_str_output: list[str] = [ - s.strip() for s in file_output.readlines() if "Total energy is" in s - ] - output_energy = float(grep_str_output[-1].split()[-2]) - except Exception as error: # Failed to get the test data - error_message = f"{error}\nERROR: Failed to get the CASPT2 energy from the test file {output_file_path}." - # Exit with error message - sys.exit(error_message) + ref_energy = get_caspt2_energy_from_output_file(ref_file_path) + test_energy = get_caspt2_energy_from_output_file(output_file_path) # Check whether the output of test run # matches the reference to 7th decimal places. - assert output_energy == pytest.approx(ref_energy, abs=1e-8) + assert test_energy == pytest.approx(ref_energy, abs=1e-8) # If it reaches this point, the result of assert is true. # The latest passed output file is overwritten by the current output file if assert is True. - shutil.copy(output_file_path, latest_passed_path) + shutil.copy(output_file_path, latest_passed_file_path) diff --git a/test/module_testing.py b/test/module_testing.py new file mode 100644 index 00000000..60cacde4 --- /dev/null +++ b/test/module_testing.py @@ -0,0 +1,106 @@ +import glob +import os +import subprocess + + +def delete_scratch_files(delete_files: "list[str]", test_path: str) -> None: + for d in delete_files: + files = glob.glob(os.path.abspath(os.path.join(test_path, d))) + for f in files: + os.remove(f) + + +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." + ) + raise Exception(error_message) + + +def create_test_command(the_number_of_process: int, binaries: "list[str]") -> str: + 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}" + 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}" + return test_command + + +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, + shell=True, + encoding="utf-8", + stdout=file_output, # Redirect output to file_output + ) + return process + + +def check_test_returncode(process: "subprocess.CompletedProcess[str]") -> None: + if process.returncode != 0: + 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 + ] + 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 + error_message = f"{error}\nERROR: Failed to get the CASPT2 energy from the reference file {file_path}." + raise Exception(error_message) + + +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() + 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) + + +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() + 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) + + +def convert_string_list_to_integer_list(string_list: "list[str]") -> "list[int]": + try: + integer_list = list(map(int, string_list)) + return integer_list + except Exception as error: # Failed to get the reference data + error_message = f"{error}\nERROR: Failed to convert the string list to integer list. string_list : {string_list}" + raise Exception(error_message) + + +def convert_string_list_to_float_list(string_list: "list[str]") -> "list[float]": + try: + float_list = list(map(float, string_list)) + return float_list + except Exception as error: # Failed to get the reference data + error_message = f"{error}\nERROR: Failed to convert the string list to float list. string_list : {string_list}" + raise Exception(error_message) diff --git a/test/unit_test/CMakeLists.txt b/test/unit_test/CMakeLists.txt index 0e3211ec..31059090 100644 --- a/test/unit_test/CMakeLists.txt +++ b/test/unit_test/CMakeLists.txt @@ -1,6 +1,7 @@ cmake_minimum_required(VERSION 3.7) add_subdirectory(ras_input_reader) +add_subdirectory(ras3_bitcheck) add_subdirectory(sort_test) add_subdirectory(lowercase) add_subdirectory(uppercase) diff --git a/test/unit_test/lowercase/test_lowercase.py b/test/unit_test/lowercase/test_lowercase.py index a83284c0..48c81792 100644 --- a/test/unit_test/lowercase/test_lowercase.py +++ b/test/unit_test/lowercase/test_lowercase.py @@ -1,8 +1,13 @@ -import subprocess import os import shutil -import sys -import pytest +from module_testing import ( + is_binary_file_exist, + create_test_command, + run_test, + check_test_returncode, + get_stripped_string_from_output_file, +) + def test_lowercase(): @@ -10,7 +15,7 @@ def test_lowercase(): ref_filename = "expected" # Reference output_filename = "result.out" # Output (This file is compared with Reference) latest_passed_output = "latest_passed.result.out" # latest passed output (After test, the output file is moved to this) - exe_filename = "test_lowercase_exe" # Executable file + exe_filename = "test_lowercase_exe" # Executable file # Get this files path and change directory to this path test_path = os.path.dirname(os.path.abspath(__file__)) # The path of this file @@ -23,34 +28,13 @@ def test_lowercase(): 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]) + + process = run_test(test_command, output_file_path) + check_test_returncode(process) - # Run tests - p = subprocess.run(exe_file_path, shell=True) - status = test_path + "status " + str(p.returncode) - # If the return code is not 0, print error message, probably calculation failed - if p.returncode != 0: - print(status, file=sys.stderr) - - - # Get values from reference - with open(ref_file_path) as file_ref: - try: - string_ref = file_ref.read() - string_ref = string_ref.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 {ref_file_path}." - # Exit with error message - sys.exit(error_message) - - # Get values from result - with open(output_file_path) as file_result: - try: # Try to get the result data - string_result = file_result.read() - string_result = string_result.strip() - except Exception as error: # Failed to get the result data - error_message = f"{error}\nERROR: Failed to get the data from the test file {output_file_path}." - # Exit with error message - sys.exit(error_message) + string_ref = get_stripped_string_from_output_file(ref_file_path) + string_result = get_stripped_string_from_output_file(output_file_path) # Evaluate the difference between references and results assert string_ref == string_result diff --git a/test/unit_test/ras3_bitcheck/.gitignore b/test/unit_test/ras3_bitcheck/.gitignore new file mode 100644 index 00000000..96e3fd80 --- /dev/null +++ b/test/unit_test/ras3_bitcheck/.gitignore @@ -0,0 +1,3 @@ +*_exe +result.prev +result diff --git a/test/unit_test/ras3_bitcheck/CMakeLists.txt b/test/unit_test/ras3_bitcheck/CMakeLists.txt new file mode 100644 index 00000000..d39922a0 --- /dev/null +++ b/test/unit_test/ras3_bitcheck/CMakeLists.txt @@ -0,0 +1,16 @@ +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/active.inp b/test/unit_test/ras3_bitcheck/active.inp new file mode 100644 index 00000000..3f6c9963 --- /dev/null +++ b/test/unit_test/ras3_bitcheck/active.inp @@ -0,0 +1,30 @@ +ninact +4 +nact +8 +nsec +0 +nelec +4 +nbas +12 +totsym +0 +nroot +0 +ncore +0 +selectroot +0 +ptgrp +dummy + +diracver +0 +ras1 +1,2 +2 +ras3 +3..8 +4 +end diff --git a/test/unit_test/ras3_bitcheck/expected b/test/unit_test/ras3_bitcheck/expected new file mode 100644 index 00000000..e40deecd --- /dev/null +++ b/test/unit_test/ras3_bitcheck/expected @@ -0,0 +1,227 @@ +1 1 +2 10 +3 11 +4 100 +5 101 +6 110 +7 111 +8 1000 +9 1001 +10 1010 +11 1011 +12 1100 +13 1101 +14 1110 +15 1111 +16 10000 +17 10001 +18 10010 +19 10011 +20 10100 +21 10101 +22 10110 +23 10111 +24 11000 +25 11001 +26 11010 +27 11011 +28 11100 +29 11101 +30 11110 +31 11111 +32 100000 +33 100001 +34 100010 +35 100011 +36 100100 +37 100101 +38 100110 +39 100111 +40 101000 +41 101001 +42 101010 +43 101011 +44 101100 +45 101101 +46 101110 +47 101111 +48 110000 +49 110001 +50 110010 +51 110011 +52 110100 +53 110101 +54 110110 +55 110111 +56 111000 +57 111001 +58 111010 +59 111011 +60 111100 +61 111101 +62 111110 +63 111111 +64 1000000 +65 1000001 +66 1000010 +67 1000011 +68 1000100 +69 1000101 +70 1000110 +71 1000111 +72 1001000 +73 1001001 +74 1001010 +75 1001011 +76 1001100 +77 1001101 +78 1001110 +79 1001111 +80 1010000 +81 1010001 +82 1010010 +83 1010011 +84 1010100 +85 1010101 +86 1010110 +87 1010111 +88 1011000 +89 1011001 +90 1011010 +91 1011011 +92 1011100 +93 1011101 +94 1011110 +95 1011111 +96 1100000 +97 1100001 +98 1100010 +99 1100011 +100 1100100 +101 1100101 +102 1100110 +103 1100111 +104 1101000 +105 1101001 +106 1101010 +107 1101011 +108 1101100 +109 1101101 +110 1101110 +111 1101111 +112 1110000 +113 1110001 +114 1110010 +115 1110011 +116 1110100 +117 1110101 +118 1110110 +119 1110111 +120 1111000 +121 1111001 +122 1111010 +123 1111011 +128 10000000 +129 10000001 +130 10000010 +131 10000011 +132 10000100 +133 10000101 +134 10000110 +135 10000111 +136 10001000 +137 10001001 +138 10001010 +139 10001011 +140 10001100 +141 10001101 +142 10001110 +143 10001111 +144 10010000 +145 10010001 +146 10010010 +147 10010011 +148 10010100 +149 10010101 +150 10010110 +151 10010111 +152 10011000 +153 10011001 +154 10011010 +155 10011011 +156 10011100 +157 10011101 +158 10011110 +159 10011111 +160 10100000 +161 10100001 +162 10100010 +163 10100011 +164 10100100 +165 10100101 +166 10100110 +167 10100111 +168 10101000 +169 10101001 +170 10101010 +171 10101011 +172 10101100 +173 10101101 +174 10101110 +175 10101111 +176 10110000 +177 10110001 +178 10110010 +179 10110011 +180 10110100 +181 10110101 +182 10110110 +183 10110111 +184 10111000 +185 10111001 +186 10111010 +187 10111011 +192 11000000 +193 11000001 +194 11000010 +195 11000011 +196 11000100 +197 11000101 +198 11000110 +199 11000111 +200 11001000 +201 11001001 +202 11001010 +203 11001011 +204 11001100 +205 11001101 +206 11001110 +207 11001111 +208 11010000 +209 11010001 +210 11010010 +211 11010011 +212 11010100 +213 11010101 +214 11010110 +215 11010111 +216 11011000 +217 11011001 +218 11011010 +219 11011011 +224 11100000 +225 11100001 +226 11100010 +227 11100011 +228 11100100 +229 11100101 +230 11100110 +231 11100111 +232 11101000 +233 11101001 +234 11101010 +235 11101011 +240 11110000 +241 11110001 +242 11110010 +243 11110011 diff --git a/test/unit_test/ras3_bitcheck/test_ras3_bitcheck.f90 b/test/unit_test/ras3_bitcheck/test_ras3_bitcheck.f90 new file mode 100644 index 00000000..7ba9733a --- /dev/null +++ b/test/unit_test/ras3_bitcheck/test_ras3_bitcheck.f90 @@ -0,0 +1,19 @@ +program ras3_bitcheck + use four_caspt2_module + use read_input_module + use ras_det_check + implicit none + integer :: i + logical :: is_allow + + call read_input + open (10, file="result", form="formatted") + 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 + end if + end do + close (10) +end program ras3_bitcheck diff --git a/test/unit_test/ras3_bitcheck/test_ras3_bitcheck.py b/test/unit_test/ras3_bitcheck/test_ras3_bitcheck.py new file mode 100644 index 00000000..a9f9c592 --- /dev/null +++ b/test/unit_test/ras3_bitcheck/test_ras3_bitcheck.py @@ -0,0 +1,48 @@ +import shutil +import os +from module_testing import ( + check_test_returncode, + create_test_command, + run_test, + get_split_string_list_from_output_file, +) + + +def test_ras3_bitcheck(): + # Current path + test_path = os.path.dirname(os.path.abspath(__file__)) + + # Change directory to the current path + os.chdir(test_path) + + # input/output/executable file names + ref_filename = "expected" + result_filename = "result" + move_filename = "result.prev" + exe_filename = "ras3_bitcheck_exe" + + # Absolute path to input/output/executable files + ref_file_path = os.path.abspath(os.path.join(test_path, ref_filename)) + result_file_path = os.path.abspath(os.path.join(test_path, result_filename)) + move_file_path = os.path.abspath(os.path.join(test_path, move_filename)) + 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] + ) + + process = run_test(test_command, result_file_path) + check_test_returncode(process) + + string_ref = get_split_string_list_from_output_file(ref_file_path) + string_result = get_split_string_list_from_output_file(result_file_path) + + # Move result files to move_file_path + shutil.move(result_file_path, move_file_path) + + # Evaluate the difference between references and results + assert string_ref == string_result + + +if __name__ == "__main__": + test_ras3_bitcheck() diff --git a/test/unit_test/ras_input_reader/expected b/test/unit_test/ras_input_reader/expected index 0f49ee84..6686ace4 100644 --- a/test/unit_test/ras_input_reader/expected +++ b/test/unit_test/ras_input_reader/expected @@ -1 +1 @@ -1 3 5 8 9 10 11 12 13 14 15 16 156 169 170 171 172 173 174 175 189 +1 2 3 4 9 10 11 12 13 14 15 16 155 156 169 170 171 172 173 174 175 176 diff --git a/test/unit_test/ras_input_reader/input b/test/unit_test/ras_input_reader/input index 1ad72644..3d8c8b9a 100644 --- a/test/unit_test/ras_input_reader/input +++ b/test/unit_test/ras_input_reader/input @@ -1 +1 @@ -1,3,5,8..16,156 169..175 189 +1..4,9..16 155,156 169..176 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 1475ba5f..904ae9f1 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 @@ -1,8 +1,14 @@ -import subprocess import os import shutil -import sys -import pytest + +from module_testing import ( + check_test_returncode, + convert_string_list_to_integer_list, + create_test_command, + get_split_string_list_from_output_file, + run_test, +) + def test_ras_input_reader(): @@ -10,7 +16,7 @@ def test_ras_input_reader(): ref_filename = "expected" # Reference output_filename = "result.out" # Output (This file is compared with Reference) latest_passed_output = "latest_passed.result.out" # latest passed output (After test, the output file is moved to this) - exe_filename = "test_ras_input_reader_exe" # Executable file + exe_filename = "test_ras_input_reader_exe" # Executable file # Get this files path and change directory to this path test_path = os.path.dirname(os.path.abspath(__file__)) # The path of this file @@ -23,36 +29,18 @@ 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] + ) + 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) + - # Run tests - p = subprocess.run(exe_file_path, shell=True) - status = test_path + "status " + str(p.returncode) - # If the return code is not 0, print error message, probably calculation failed - if p.returncode != 0: - print(status, file=sys.stderr) - - - # Get values from reference - with open(ref_file_path) as file_ref: - try: - string_ref = file_ref.read() - string_ref = string_ref.strip().split() - ref_int_list = list(map(int, string_ref)) - except Exception as error: # Failed to get the reference data - error_message = f"{error}\nERROR: Failed to get the data from the reference file {ref_file_path}." - # Exit with error message - sys.exit(error_message) - - # Get values from result - with open(output_file_path) as file_result: - try: # Try to get the result data - string_result = file_result.read() - string_result = string_result.strip().split() - result_int_list = list(map(int, string_result)) - except Exception as error: # Failed to get the result data - error_message = f"{error}\nERROR: Failed to get the data from the test file {output_file_path}." - # Exit with error message - sys.exit(error_message) + string_result = get_split_string_list_from_output_file(output_file_path) + result_int_list = convert_string_list_to_integer_list(string_result) # Evaluate the difference between references and results assert ref_int_list == result_int_list diff --git a/test/unit_test/sort_test/test_sort.py b/test/unit_test/sort_test/test_sort.py index 644e3c45..ac54a380 100644 --- a/test/unit_test/sort_test/test_sort.py +++ b/test/unit_test/sort_test/test_sort.py @@ -1,8 +1,15 @@ -import subprocess import os -import shutil -import sys import pytest +import shutil + +from module_testing import ( + check_test_returncode, + convert_string_list_to_float_list, + convert_string_list_to_integer_list, + create_test_command, + run_test, + get_split_string_list_from_output_file, +) def test_int_sort(): @@ -22,15 +29,15 @@ 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)) - # Run tests - p = subprocess.run(exe_file_path, shell=True) - status = test_path + "status " + str(p.returncode) - # If the return code is not 0, print error message, probably calculation failed - if p.returncode != 0: - print(status, file=sys.stderr) + 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[int] = [ + reference_list = [ 8, 9, 10, @@ -55,19 +62,11 @@ def test_int_sort(): ] reference_list.sort() # 1,3,5,8,9,10,11,12,13,14,15,16,156,169,170,171,172,173,174,175,189 - # Get values from result - with open(output_file_path) as file_result: - try: # Try to get the result data - string_result = file_result.read() - string_result = string_result.strip().split() - result_real_list = list(map(float, string_result)) - except Exception as error: # Failed to get the result data - error_message = f"{error}\nERROR: Failed to get the data from the test file {output_file_path}." - # Exit with error message - sys.exit(error_message) + string_result = get_split_string_list_from_output_file(output_file_path) + result_int_list = convert_string_list_to_integer_list(string_result) # Evaluate the difference between references and results - for out, ref in zip(result_real_list, reference_list): + for out, ref in zip(result_int_list, reference_list): assert ref == out # If it reaches this point, the result of assert is true. @@ -92,15 +91,15 @@ 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)) - # Run tests - p = subprocess.run(exe_file_path, shell=True) - status = test_path + "status " + str(p.returncode) - # If the return code is not 0, print error message, probably calculation failed - if p.returncode != 0: - print(status, file=sys.stderr) + 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[int] = [ + reference_list = [ 8, 9, 10, @@ -127,19 +126,11 @@ def test_int_sort_reverse(): reverse=True ) # 189,175,174,173,172,171,170,169,156,16,15,14,13,12,11,10,9,8,5,3,1 - # Get values from result - with open(output_file_path) as file_result: - try: # Try to get the result data - string_result = file_result.read() - string_result = string_result.strip().split() - result_real_list = list(map(float, string_result)) - except Exception as error: # Failed to get the result data - error_message = f"{error}\nERROR: Failed to get the data from the test file {output_file_path}." - # Exit with error message - sys.exit(error_message) + string_result = get_split_string_list_from_output_file(output_file_path) + result_int_list = convert_string_list_to_integer_list(string_result) # Evaluate the difference between references and results - for out, ref in zip(result_real_list, reference_list): + for out, ref in zip(result_int_list, reference_list): assert ref == out # If it reaches this point, the result of assert is true. @@ -164,31 +155,23 @@ 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)) - # Run tests - p = subprocess.run(exe_file_path, shell=True) - status = test_path + "status " + str(p.returncode) - # If the return code is not 0, print error message, probably calculation failed - if p.returncode != 0: - print(status, file=sys.stderr) + 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() # -897, -9.2, 0.0000000010, 8.1, 10000.58, 123456789 - # Get values from result - with open(output_file_path) as file_result: - try: # Try to get the result data - string_result = file_result.read() - string_result = string_result.strip().split() - result_real_list = list(map(float, string_result)) - except Exception as error: # Failed to get the result data - error_message = f"{error}\nERROR: Failed to get the data from the test file {output_file_path}." - # Exit with error message - sys.exit(error_message) + string_result = get_split_string_list_from_output_file(output_file_path) + result_real_list = convert_string_list_to_float_list(string_result) # Evaluate the difference between references and results for out, ref in zip(result_real_list, reference_list): - assert ref == pytest.approx(out, 5e-7) + assert ref == pytest.approx(out) # If it reaches this point, the result of assert is true. # The latest passed output file is overwritten by the current output file if assert is True. @@ -214,12 +197,12 @@ 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)) - # Run tests - p = subprocess.run(exe_file_path, shell=True) - status = test_path + "status " + str(p.returncode) - # If the return code is not 0, print error message, probably calculation failed - if p.returncode != 0: - print(status, file=sys.stderr) + 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] @@ -227,20 +210,12 @@ def test_real_sort_reverse(): reverse=True ) # 123456789, 10000.58, 8.1, 0.0000000010, -9.2, -897 - # Get values from result - with open(output_file_path) as file_result: - try: # Try to get the result data - string_result = file_result.read() - string_result = string_result.strip().split() - result_real_list: list[float] = list(map(float, string_result)) - except Exception as error: # Failed to get the result data - error_message = f"{error}\nERROR: Failed to get the data from the test file {output_file_path}." - # Exit with error message - sys.exit(error_message) + string_result = get_split_string_list_from_output_file(output_file_path) + result_real_list = convert_string_list_to_float_list(string_result) # Evaluate the difference between references and results for out, ref in zip(result_real_list, reference_list): - assert ref == pytest.approx(out, 5e-7) + assert ref == pytest.approx(out) # If it reaches this point, the result of assert is true. # The latest passed output file is overwritten by the current output file if assert is True. diff --git a/test/unit_test/uppercase/test_uppercase.py b/test/unit_test/uppercase/test_uppercase.py index 04558c54..3b4eb519 100644 --- a/test/unit_test/uppercase/test_uppercase.py +++ b/test/unit_test/uppercase/test_uppercase.py @@ -1,8 +1,12 @@ -import subprocess import os import shutil -import sys -import pytest +from module_testing import ( + check_test_returncode, + create_test_command, + get_stripped_string_from_output_file, + run_test, +) + def test_uppercase(): @@ -10,7 +14,7 @@ def test_uppercase(): ref_filename = "expected" # Reference output_filename = "result.out" # Output (This file is compared with Reference) latest_passed_output = "latest_passed.result.out" # latest passed output (After test, the output file is moved to this) - exe_filename = "test_uppercase_exe" # Executable file + exe_filename = "test_uppercase_exe" # Executable file # Get this files path and change directory to this path test_path = os.path.dirname(os.path.abspath(__file__)) # The path of this file @@ -23,34 +27,13 @@ def test_uppercase(): 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]) + + process = run_test(test_command, output_file_path) + check_test_returncode(process) - # Run tests - p = subprocess.run(exe_file_path, shell=True) - status = test_path + "status " + str(p.returncode) - # If the return code is not 0, print error message, probably calculation failed - if p.returncode != 0: - print(status, file=sys.stderr) - - - # Get values from reference - with open(ref_file_path) as file_ref: - try: - string_ref = file_ref.read() - string_ref = string_ref.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 {ref_file_path}." - # Exit with error message - sys.exit(error_message) - - # Get values from result - with open(output_file_path) as file_result: - try: # Try to get the result data - string_result = file_result.read() - string_result = string_result.strip() - except Exception as error: # Failed to get the result data - error_message = f"{error}\nERROR: Failed to get the data from the test file {output_file_path}." - # Exit with error message - sys.exit(error_message) + string_ref = get_stripped_string_from_output_file(ref_file_path) + string_result = get_stripped_string_from_output_file(output_file_path) # Evaluate the difference between references and results assert string_ref == string_result From 208f13455a14f0fa27c024473a882d053372ea10 Mon Sep 17 00:00:00 2001 From: Kohei Noda <103017367+kohei-noda-qcrg@users.noreply.github.com> Date: Wed, 3 Aug 2022 15:45:57 +0900 Subject: [PATCH 2/4] Remove U-CASPT2 and unnecessary files (#35) * Remove unnecessary files * Ordering filename in CMakeLists.txt * Update README.md * Remove shellscript from testing directory * Fix indent --- README.md | 118 ++--- src/#test_abe.f90# | 323 ------------- src/CMakeLists.txt | 74 +-- src/casci.f90 | 133 ------ src/casdet.f90 | 67 --- src/casdet_ty_utchem.f90 | 91 ---- src/create_mdcint | 102 ----- src/e0after_tra.f90 | 699 ---------------------------- src/eeff_casci.f90 | 115 ----- src/eeff_casci_new.f90 | 127 ------ src/fockcasci.f90 | 146 ------ src/fockdiag.f90 | 161 ------- src/fockhf.f90 | 101 ----- src/fockhf1.f90 | 100 ---- src/fockivo.f90 | 229 ---------- src/fockivo_ty.f90 | 196 -------- src/hfc_casci.f90 | 139 ------ src/hfc_casci_per.f90 | 122 ----- src/intmo.f90 | 76 ---- src/matrixinv.f90 | 31 -- src/nrintread.f90 | 122 ----- src/nrinttest.f90 | 140 ------ src/pgsym_co.f90 | 496 -------------------- src/pgsym_ty.f90 | 460 ------------------- src/r4dcasci.f90 | 290 ------------ src/r4dcaspt2_tra.f90 | 383 ---------------- src/r4divo.f90 | 207 --------- src/rcutoff.f90 | 42 -- src/read1mo.f90 | 75 --- src/readint2.f90 | 235 ---------- src/readint2_ivo.f90 | 372 --------------- src/readint2_ivo_ty.f90 | 338 -------------- src/readint2_nr.f90 | 250 ---------- src/readint2_ord.f90 | 689 ---------------------------- src/readint2_ty.f90 | 182 -------- src/readorb_enesym.f90 | 356 --------------- src/readvec.f90 | 112 ----- src/solvall_A_ord.f90 | 805 --------------------------------- src/solvall_B_ord.f90 | 649 -------------------------- src/solvall_C_ord.f90 | 752 ------------------------------ src/solvall_C_ord_original.f90 | 760 ------------------------------- src/solvall_D_ord.f90 | 666 --------------------------- src/solvall_E_ord.f90 | 551 ---------------------- src/solvall_F_ord.f90 | 571 ----------------------- src/solvall_G_ord.f90 | 525 --------------------- src/solvall_G_ord_original.f90 | 512 --------------------- src/solvall_H_ord.f90 | 201 -------- src/tramo.f90 | 201 -------- src/utchem.makeconfig | 82 ---- test/conftest.py | 1 + test/h2o/sh_new | 8 - test/module_testing.py | 21 +- 52 files changed, 112 insertions(+), 14092 deletions(-) delete mode 100644 src/#test_abe.f90# delete mode 100644 src/casci.f90 delete mode 100644 src/casdet.f90 delete mode 100644 src/casdet_ty_utchem.f90 delete mode 100644 src/create_mdcint delete mode 100644 src/e0after_tra.f90 delete mode 100644 src/eeff_casci.f90 delete mode 100644 src/eeff_casci_new.f90 delete mode 100644 src/fockcasci.f90 delete mode 100644 src/fockdiag.f90 delete mode 100644 src/fockhf.f90 delete mode 100644 src/fockhf1.f90 delete mode 100644 src/fockivo.f90 delete mode 100644 src/fockivo_ty.f90 delete mode 100644 src/hfc_casci.f90 delete mode 100644 src/hfc_casci_per.f90 delete mode 100644 src/intmo.f90 delete mode 100644 src/matrixinv.f90 delete mode 100644 src/nrintread.f90 delete mode 100644 src/nrinttest.f90 delete mode 100644 src/pgsym_co.f90 delete mode 100644 src/pgsym_ty.f90 delete mode 100644 src/r4dcasci.f90 delete mode 100644 src/r4dcaspt2_tra.f90 delete mode 100644 src/r4divo.f90 delete mode 100644 src/rcutoff.f90 delete mode 100644 src/read1mo.f90 delete mode 100644 src/readint2.f90 delete mode 100644 src/readint2_ivo.f90 delete mode 100644 src/readint2_ivo_ty.f90 delete mode 100644 src/readint2_nr.f90 delete mode 100644 src/readint2_ord.f90 delete mode 100644 src/readint2_ty.f90 delete mode 100644 src/readorb_enesym.f90 delete mode 100644 src/readvec.f90 delete mode 100644 src/solvall_A_ord.f90 delete mode 100644 src/solvall_B_ord.f90 delete mode 100644 src/solvall_C_ord.f90 delete mode 100644 src/solvall_C_ord_original.f90 delete mode 100644 src/solvall_D_ord.f90 delete mode 100644 src/solvall_E_ord.f90 delete mode 100644 src/solvall_F_ord.f90 delete mode 100644 src/solvall_G_ord.f90 delete mode 100644 src/solvall_G_ord_original.f90 delete mode 100644 src/solvall_H_ord.f90 delete mode 100644 src/tramo.f90 delete mode 100644 src/utchem.makeconfig delete mode 100644 test/h2o/sh_new 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/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_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/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/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/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/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/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/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/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/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/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_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_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/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_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_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_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_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_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_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_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/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/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/module_testing.py b/test/module_testing.py index 60cacde4..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 From bf4b4f7b086343b41dc69c9ab51ba558f3bc4ee7 Mon Sep 17 00:00:00 2001 From: Kohei Noda <103017367+kohei-noda-qcrg@users.noreply.github.com> Date: Wed, 3 Aug 2022 16:07:26 +0900 Subject: [PATCH 3/4] Add fileunit provider (open_unformatted_file, open_formatted_file) (#36), resolve #25 * Add file_manage_module * Change test_lower_MPI_h2 to test_multiple_mdcint_h2 * Add default_unit in the four_caspt2_module * Use module_file_manager when open files. * file_unit_number search procedule always starts from 21 * Remove intmo_ty --- src/CMakeLists.txt | 2 + src/casci_ty.f90 | 31 +-- src/create_binmdcint.f90 | 45 ++-- src/e0after_tra_ty.f90 | 18 +- src/fockdiag_ty.f90 | 12 +- src/four_caspt2_module.f90 | 2 +- src/intmo_ty.f90 | 70 ------- src/intra.f90 | 194 ++++++++---------- src/module_file_manager.f90 | 103 ++++++++++ src/r4dcasci_co.f90 | 16 +- src/r4dcaspt2_tra_co.f90 | 44 ++-- src/read_input_module.f90 | 67 +++--- src/readint2_ord_co.f90 | 67 +++--- src/readorb_enesym_co.f90 | 57 +++-- src/solvall_A_ord_ty.f90 | 17 +- src/solvall_B_ord_ty.f90 | 13 +- src/solvall_C_ord_ty.f90 | 30 +-- src/solvall_D_ord_ty.f90 | 35 ++-- src/solvall_E_ord_ty.f90 | 10 +- src/solvall_F_ord_ty.f90 | 17 +- src/solvall_G_ord_ty.f90 | 11 +- src/solvall_H_ord_ty.f90 | 10 +- src/trac.f90 | 11 +- test/lower_MPI_h2/decimal.py | 3 - .../MDCINT | Bin .../MDCINXXXX1 | Bin .../MDCINXXXX2 | Bin .../MRCONEE | Bin .../active.inp | 0 .../reference.H2.out | 0 .../test_multiple_mdcint_h2.py} | 2 +- test/unit_test/lowercase/CMakeLists.txt | 1 + test/unit_test/lowercase/test_lowercase.f90 | 18 +- test/unit_test/ras3_bitcheck/CMakeLists.txt | 1 + .../ras3_bitcheck/test_ras3_bitcheck.f90 | 15 +- .../unit_test/ras_input_reader/CMakeLists.txt | 1 + .../test_ras_input_reader.f90 | 14 +- .../ras_input_reader/test_ras_input_reader.py | 5 +- test/unit_test/sort_test/CMakeLists.txt | 12 ++ test/unit_test/sort_test/test_sort.py | 28 +-- test/unit_test/sort_test/test_sort_int.f90 | 8 +- .../sort_test/test_sort_int_reverse.f90 | 7 +- test/unit_test/sort_test/test_sort_real.f90 | 8 +- .../sort_test/test_sort_real_reverse.f90 | 8 +- test/unit_test/uppercase/CMakeLists.txt | 1 + test/unit_test/uppercase/test_uppercase.f90 | 14 +- 46 files changed, 553 insertions(+), 475 deletions(-) delete mode 100644 src/intmo_ty.f90 create mode 100644 src/module_file_manager.f90 delete mode 100644 test/lower_MPI_h2/decimal.py rename test/{lower_MPI_h2 => multiple_mdcint_h2}/MDCINT (100%) rename test/{lower_MPI_h2 => multiple_mdcint_h2}/MDCINXXXX1 (100%) rename test/{lower_MPI_h2 => multiple_mdcint_h2}/MDCINXXXX2 (100%) rename test/{lower_MPI_h2 => multiple_mdcint_h2}/MRCONEE (100%) rename test/{lower_MPI_h2 => multiple_mdcint_h2}/active.inp (100%) rename test/{lower_MPI_h2 => multiple_mdcint_h2}/reference.H2.out (100%) rename test/{lower_MPI_h2/test_lower_MPI_h2.py => multiple_mdcint_h2/test_multiple_mdcint_h2.py} (97%) diff --git a/src/CMakeLists.txt b/src/CMakeLists.txt index 6158c9ce..2a3b81ee 100644 --- a/src/CMakeLists.txt +++ b/src/CMakeLists.txt @@ -18,6 +18,7 @@ add_executable(r4dcascicoexe four_caspt2_module.f90 get_filename.f90 mem.f90 + module_file_manager.f90 module_sort_swap.f90 one_e_exct.f90 prtoutfock.f90 @@ -46,6 +47,7 @@ add_executable(r4dcaspt2ocoexe get_filename.f90 intra.f90 mem.f90 + module_file_manager.f90 module_sort_swap.f90 one_e_exct.f90 r4dcaspt2_tra_co.f90 diff --git a/src/casci_ty.f90 b/src/casci_ty.f90 index d97d7644..dbe231e0 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! diff --git a/src/create_binmdcint.f90 b/src/create_binmdcint.f90 index 81b41eaf..c178e2dc 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 + integer :: mdcint_unit, mdcintnew_unit logical :: is_file_exist + 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,11 +112,11 @@ 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 @@ -202,7 +201,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 +209,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 +217,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 +225,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 +244,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/e0after_tra_ty.f90 b/src/e0after_tra_ty.f90 index cc8aca0e..4b663cce 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 @@ -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 @@ -318,7 +321,7 @@ 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) @@ -333,6 +336,7 @@ SUBROUTINE e0aftertrac_ty ! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= ! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= + use module_file_manager use four_caspt2_module Implicit NONE @@ -341,6 +345,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 +359,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 @@ -597,7 +603,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 @@ -686,7 +692,7 @@ 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) 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/four_caspt2_module.f90 b/src/four_caspt2_module.f90 index b56cd3d7..dcdaef29 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/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 01414db8..33c1a7a6 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 @@ -15,7 +16,8 @@ SUBROUTINE intra_1(spi, spj, spk, spl, fname) integer, intent(in) :: spi, spj, spk, spl character(50), intent(in) :: fname - integer, allocatable :: indsym(:, :, :), nsym(:, :) + integer :: unit + integer, allocatable :: indsym(:, :, :), nsym(:, :) complex*16, allocatable :: traint2(:, :, :, :) real*8 :: thresd @@ -26,7 +28,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,9 +75,9 @@ 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 + read (unit, 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 the first index integral transformation '//trim(fname) @@ -100,10 +102,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 +115,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,9 +126,9 @@ 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 + read (unit, 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 the second index integral transformation '//trim(fname) @@ -144,9 +144,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 +157,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,9 +167,9 @@ 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 + read (unit, 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 the third index integral transformation '//trim(fname) @@ -186,10 +185,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 +198,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,9 +208,9 @@ 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 + read (unit, 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 the fourth index integral transformation '//trim(fname) @@ -229,9 +226,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 +239,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 +257,7 @@ SUBROUTINE intra_2(spi, spj, spk, spl, fname) ! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= ! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= + use module_file_manager use four_caspt2_module Implicit NONE @@ -270,7 +267,8 @@ SUBROUTINE intra_2(spi, spj, spk, spl, fname) integer, intent(in) :: spi, spj, spk, spl character(50), intent(in) :: fname - integer, allocatable :: indsym(:, :, :), nsym(:, :) + integer :: unit = 20 + integer, allocatable :: indsym(:, :, :), nsym(:, :) complex*16, allocatable :: traint2(:, :, :, :) real*8 :: thresd @@ -282,6 +280,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,9 +330,9 @@ 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 + read (unit, 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 the first index integral transformation '//trim(fname) @@ -397,10 +396,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 +409,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,10 +419,10 @@ 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 + read (unit, 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 the second index integral transformation '//trim(fname) @@ -444,8 +440,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 +452,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,9 +462,9 @@ 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 + read (unit, 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 the third index integral transformation '//trim(fname) @@ -486,10 +481,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 +494,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,9 +504,9 @@ 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 + read (unit, iostat=iostat) i, j, k, l, cint2 ! Exit the loop if the end of the file is reached if (iostat < 0) then @@ -531,10 +524,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 +537,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 +554,7 @@ SUBROUTINE intra_3(spi, spj, spk, spl, fname) ! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= ! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= + use module_file_manager use four_caspt2_module Implicit NONE @@ -572,6 +564,7 @@ SUBROUTINE intra_3(spi, spj, spk, spl, fname) integer, intent(in) :: spi, spj, spk, spl character(50), intent(in) :: fname + integer :: unit = 20 integer, allocatable :: indsym(:, :, :), nsym(:, :) complex*16, allocatable :: traint2(:, :, :, :) @@ -585,6 +578,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,9 +630,9 @@ 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 + read (unit, iostat=iostat) i, j, k, l, cint2 ! Exit the loop if the end of the file is reached if (iostat < 0) then @@ -696,10 +690,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 +703,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,9 +713,9 @@ 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 + read (unit, iostat=iostat) i, j, k, l, cint2 ! Exit the loop if the end of the file is reached if (iostat < 0) then @@ -741,10 +733,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) @@ -754,10 +745,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 !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~! @@ -765,9 +756,9 @@ 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 + read (unit, iostat=iostat) i, j, k, l, cint2 ! Exit the loop if the end of the file is reached if (iostat < 0) then @@ -785,10 +776,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) @@ -799,10 +789,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 !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~! @@ -810,9 +799,9 @@ 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 + read (unit, iostat=iostat) i, j, k, l, cint2 ! Exit the loop if the end of the file is reached if (iostat < 0) then @@ -830,10 +819,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) @@ -844,9 +832,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) @@ -855,7 +843,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. @@ -869,7 +857,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 @@ -902,7 +890,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 @@ -940,11 +928,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重ループに変換する方法 @@ -965,7 +953,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/module_file_manager.f90 b/src/module_file_manager.f90 new file mode 100644 index 00000000..fd96974d --- /dev/null +++ b/src/module_file_manager.f90 @@ -0,0 +1,103 @@ +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 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) + file_status = 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 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 + trimmed_action = trim(optional_action) + call lowercase(trimmed_action) + if (trimmed_action /= 'read' .and. trimmed_action /= 'write' .and. trimmed_action /= 'readwrite') then + print *, 'ERROR: trimmed_action must be read, write or readwrite. trimmed_action = ', trimmed_action + print *, 'FILE NAME: ', file + print *, 'Exiting...' + stop + end if + actual_action = trimmed_action + else + actual_action = 'readwrite' + end if + form = '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 + trimmed_action = trim(optional_action) + call lowercase(trimmed_action) + if (trimmed_action /= 'read' .and. trimmed_action /= 'write' .and. trimmed_action /= 'readwrite') then + print *, 'ERROR: trimmed_action must be read, write or readwrite. trimmed_action = ', trimmed_action + print *, 'FILE NAME: ', file + print *, 'Exiting...' + stop + end if + actual_action = trimmed_action + else + actual_action = 'readwrite' + end if + form = '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/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_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/read_input_module.f90 b/src/read_input_module.f90 index feecc244..365431c5 100644 --- a/src/read_input_module.f90 +++ b/src/read_input_module.f90 @@ -15,12 +15,13 @@ module read_input_module 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(:) @@ -31,9 +32,8 @@ subroutine read_input (/"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 +43,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,17 +57,17 @@ 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 logical :: is_comment @@ -76,44 +76,44 @@ subroutine check_input_type(string, is_filled) select case (trim(string)) case ("ninact") - call read_an_integer(0, 10**9, ninact) + call read_an_integer(unit_num, 0, 10**9, ninact) is_filled(1) = .true. case ("nact") - call read_an_integer(0, 10**9, nact) + call read_an_integer(unit_num, 0, 10**9, nact) is_filled(2) = .true. case ("nsec") - call read_an_integer(0, 10**9, nsec) + call read_an_integer(unit_num, 0, 10**9, nsec) is_filled(3) = .true. case ("nelec") - call read_an_integer(0, 10**9, nelec) + call read_an_integer(unit_num, 0, 10**9, nelec) is_filled(4) = .true. case ("nroot") - call read_an_integer(0, 10**9, nroot) + call read_an_integer(unit_num, 0, 10**9, nroot) is_filled(5) = .true. case ("selectroot") - call read_an_integer(0, 10**9, selectroot) + call read_an_integer(unit_num, 0, 10**9, selectroot) is_filled(6) = .true. case ("totsym") - call read_an_integer(0, 10**9, totsym) + call read_an_integer(unit_num, 0, 10**9, totsym) is_filled(7) = .true. case ("ncore") - call read_an_integer(0, 10**9, ncore) + call read_an_integer(unit_num, 0, 10**9, ncore) is_filled(8) = .true. case ("nbas") - call read_an_integer(0, 10**9, nbas) + call read_an_integer(unit_num, 0, 10**9, 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 +122,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, 10**9, 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 +155,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, 10**9, min_hole_ras1) case ("end") is_end = .true. @@ -166,7 +166,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,7 +176,7 @@ 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 + integer, intent(in) :: unit_num, ras_num character(100) :: tmp_ras_chr character(:), allocatable :: ras_chr integer, parameter :: max_str_length = 100 @@ -187,7 +187,7 @@ subroutine ras_read(ras_list, ras_num) write (tmp_ras_chr, *) ras_num 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 @@ -624,16 +624,16 @@ 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 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? @@ -654,13 +654,14 @@ subroutine read_an_integer(allowed_min_int, allowed_max_int, result_int) stop 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 diff --git a/src/readint2_ord_co.f90 b/src/readint2_ord_co.f90 index 21e1a82e..db6d03c4 100644 --- a/src/readint2_ord_co.f90 +++ b/src/readint2_ord_co.f90 @@ -5,13 +5,14 @@ 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 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 +29,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,33 +53,24 @@ 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 @@ -100,9 +92,7 @@ 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) + read (mdcint_unit, 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) @@ -891,12 +881,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/readorb_enesym_co.f90 b/src/readorb_enesym_co.f90 index 94eb91a8..99b90588 100644 --- a/src/readorb_enesym_co.f90 +++ b/src/readorb_enesym_co.f90 @@ -5,10 +5,11 @@ 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(:, :) @@ -23,17 +24,18 @@ 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 + + if (iostat /= 0) then + print *, 'Error in reading NMO, BREIT, ECORE' + print *, 'iostat = ', iostat stop - end if + endif - 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 +52,24 @@ 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 + if (iostat /= 0) then + print *, 'Error in reading NSYMRP, REPN' + print *, 'iostat = ', iostat + stop + endif 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) + if (iostat /= 0) then + print *, 'Error in reading nsymrpa, repna' + print *, 'iostat = ', iostat + stop + endif if (rank == 0) then print *, nsymrpa, (repna(i0), i0=1, nsymrpa*2) end if @@ -81,20 +93,25 @@ 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) + if (iostat /= 0) then + print *, 'Error in reading multb' + print *, 'iostat = ', iostat + stop + endif -! 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 +365,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/solvall_A_ord_ty.f90 b/src/solvall_A_ord_ty.f90 index 656b4ff8..de4db187 100644 --- a/src/solvall_A_ord_ty.f90 +++ b/src/solvall_A_ord_ty.f90 @@ -543,6 +543,7 @@ SUBROUTINE vAmat_ord_ty(v) ! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= use four_caspt2_module + use module_file_manager Implicit NONE #ifdef HAVE_MPI @@ -557,7 +558,7 @@ SUBROUTINE vAmat_ord_ty(v) 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 @@ -590,6 +591,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) @@ -673,10 +675,10 @@ 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) + read (twoint_unit, 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' @@ -728,16 +730,15 @@ 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) + read (twoint_unit, 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' @@ -762,7 +763,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_ty.f90 b/src/solvall_B_ord_ty.f90 index 33980a5a..5c54474e 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,13 +583,14 @@ 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 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) + read (twoint_unit, iostat=iostat) i, j, k, l, cint2 ! (ij|kl) ! Exit the loop if iostat is less than 0 if (iostat < 0) then @@ -626,7 +628,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 +645,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 +654,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_ty.f90 b/src/solvall_C_ord_ty.f90 index 82f2990d..5b7ea7c6 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,8 +530,8 @@ 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 !^~^~^~^~^~^~^~^~^~^~^~^~^~^~^~^~^~^~^~^~^~^~^~^~^~^~^~^~^~^~^~^~^~^~^~^~^~^~^~^~^~^~^~^~^~^~^~^~ @@ -566,6 +567,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)) @@ -619,10 +621,9 @@ 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) + read (twoint_unit, 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' @@ -655,16 +656,16 @@ 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 + read (twoint_unit, 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 @@ -687,17 +688,16 @@ 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) + read (twoint_unit, 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 @@ -720,11 +720,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_ty.f90 b/src/solvall_D_ord_ty.f90 index 207ad241..fdfc870f 100644 --- a/src/solvall_D_ord_ty.f90 +++ b/src/solvall_D_ord_ty.f90 @@ -70,7 +70,7 @@ SUBROUTINE solvD_ord_ty(e0, e2d) end if datetmp1 = date0; datetmp0 = date0 Call timing(date0, tsec0, datetmp0, tsectmp0) - tsectmp1 = tsectmp0; + tsectmp1 = tsectmp0 thresd = 1.0D-08 thres = 1.0D-08 @@ -506,6 +506,7 @@ SUBROUTINE vDmat_ord_ty(nai, iai, v) ! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= use four_caspt2_module + use module_file_manager Implicit NONE #ifdef HAVE_MPI @@ -516,7 +517,7 @@ 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 @@ -527,6 +528,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)} @@ -565,9 +567,10 @@ 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) + read (twoint_unit, 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' @@ -601,7 +604,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)} @@ -614,9 +618,10 @@ 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) + read (twoint_unit, 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' @@ -642,16 +647,19 @@ 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 + + call open_unformatted_file(unit=twoint_unit, file=d3int, status='old', optional_action='read') ! (ai|jk) is stored do - read (1, iostat=iostat) i, j, k, l, cint2 ! (ij|kl) + read (twoint_unit, iostat=iostat) i, j, k, l, cint2 ! (ij|kl) ! Exit the loop if the end of the file is reached if (iostat < 0) then @@ -672,10 +680,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_ty.f90 b/src/solvall_E_ord_ty.f90 index 7e1fc2de..69a15758 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,7 +502,7 @@ 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 @@ -510,12 +511,13 @@ SUBROUTINE vEmat_ord_ty(naij, iaij, v) 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 + read (twoint_unit, 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' @@ -570,8 +572,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_ty.f90 b/src/solvall_F_ord_ty.f90 index 581fb19d..70fe3ad2 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,8 +525,8 @@ 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 @@ -534,12 +535,13 @@ SUBROUTINE vFmat_ord(nab, iab, v) 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 + read (twoint_unit, 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' @@ -551,8 +553,6 @@ SUBROUTINE vFmat_ord(nab, iab, v) 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 +571,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_ty.f90 b/src/solvall_G_ord_ty.f90 index 0e4b44d2..c8785882 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,7 +501,7 @@ 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 @@ -508,12 +509,13 @@ SUBROUTINE vGmat_ord_ty(nabi, iabi, v) 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 + read (twoint_unit, 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' @@ -529,7 +531,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 +539,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_ty.f90 b/src/solvall_H_ord_ty.f90 index 8dee13d8..b3721b3b 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 @@ -15,7 +16,7 @@ SUBROUTINE solvH_ord_ty(e0, e2h) 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 :: i0, j0, tab, nab, tij, nij, iostat, twoint_unit Integer, allocatable :: ia0(:), ib0(:), ii0(:), ij0(:), iab(:, :), iij(:, :) Complex*16 :: cint2 Complex*16, allocatable :: v(:, :) @@ -44,6 +45,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,9 +99,9 @@ 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 + read (twoint_unit, 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 Hint' @@ -128,8 +130,8 @@ 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 diff --git a/src/trac.f90 b/src/trac.f90 index 57a69368..a281481b 100644 --- a/src/trac.f90 +++ b/src/trac.f90 @@ -203,6 +203,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 +212,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(:) @@ -358,13 +359,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/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/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..349306c0 100644 --- a/test/unit_test/ras3_bitcheck/CMakeLists.txt +++ b/test/unit_test/ras3_bitcheck/CMakeLists.txt @@ -9,6 +9,7 @@ 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_file_manager.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 diff --git a/test/unit_test/ras3_bitcheck/test_ras3_bitcheck.f90 b/test/unit_test/ras3_bitcheck/test_ras3_bitcheck.f90 index 7ba9733a..e4be115c 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..f5f8c39a 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,12 @@ 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 From 479f36ecb180f33d96e026cdbfe49bf0d3716d15 Mon Sep 17 00:00:00 2001 From: Kohei Noda <103017367+kohei-noda-qcrg@users.noreply.github.com> Date: Sat, 13 Aug 2022 15:05:47 +0900 Subject: [PATCH 4/4] Add iostat check (#37) MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit * Change function name from test_h2o to test_h2 * fix: exit was required when the end of file is reached. * Remove builtin open in files except ivo * Refactored to avoid warnings other than ‘is_in_range_real’ defined but not used ( gfortan) * Remove unused label (line number) * Add check_iostat --- src/casci_ty.f90 | 2 +- src/create_binmdcint.f90 | 13 +- src/diag.f90 | 1 - src/e0after_tra_ty.f90 | 12 +- src/intra.f90 | 116 +++---------- src/module_file_manager.f90 | 60 ++++--- src/read1mo_co.f90 | 22 +-- src/read_input_module.f90 | 155 ++++++++++-------- src/readint2_casci_co.f90 | 27 +-- src/readint2_ord_co.f90 | 23 +-- src/readorb_enesym_co.f90 | 35 ++-- src/solvall_A_ord_ty.f90 | 17 +- src/solvall_B_ord_ty.f90 | 12 +- src/solvall_C_ord_ty.f90 | 30 +--- src/solvall_D_ord_ty.f90 | 26 +-- src/solvall_E_ord_ty.f90 | 23 ++- src/solvall_F_ord_ty.f90 | 9 +- src/solvall_G_ord_ty.f90 | 9 +- src/solvall_H_ord_ty.f90 | 17 +- src/trac.f90 | 18 +- test/h2/test_h2.py | 2 +- .../ras3_bitcheck/test_ras3_bitcheck.f90 | 2 +- .../sort_test/test_sort_int_reverse.f90 | 1 - 23 files changed, 250 insertions(+), 382 deletions(-) diff --git a/src/casci_ty.f90 b/src/casci_ty.f90 index dbe231e0..f8cd95a4 100644 --- a/src/casci_ty.f90 +++ b/src/casci_ty.f90 @@ -160,4 +160,4 @@ FUNCTION comb(n, m) RESULT(res) End do res = j -1000 end function comb +end function comb diff --git a/src/create_binmdcint.f90 b/src/create_binmdcint.f90 index c178e2dc..227b44db 100644 --- a/src/create_binmdcint.f90 +++ b/src/create_binmdcint.f90 @@ -23,7 +23,7 @@ Subroutine create_newmdcint ! 2 Electorn Integrals In Mdcint integer :: nnkr, iiit, jjjt, kkkt, lllt integer :: nkr, nz, file_idx, iostat integer :: mdcint_unit, mdcintnew_unit - logical :: is_file_exist + logical :: is_file_exist, is_end_of_file mdcint_unit = default_unit; mdcintnew_unit = default_unit Call timing(date1, tsec1, date0, tsec0) @@ -121,16 +121,9 @@ Subroutine create_newmdcint ! 2 Electorn Integrals In Mdcint (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 !------------------------------! 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_ty.f90 b/src/e0after_tra_ty.f90 index 4b663cce..cde52775 100644 --- a/src/e0after_tra_ty.f90 +++ b/src/e0after_tra_ty.f90 @@ -162,7 +162,7 @@ SUBROUTINE e0aftertra_ty oneeff = oneeff - cmplxint -300 end do ! k + end do ! k Call tramo1_ty(i, j, cmplxint) @@ -277,7 +277,7 @@ SUBROUTINE e0aftertra_ty end if -100 end do ! l + end do ! l end do ! k end do ! j end do ! i @@ -323,7 +323,6 @@ SUBROUTINE e0aftertra_ty if (rank == 0) then ! Only master ranks are allowed to create files used by CASPT2 except for MDCINTNEW. close (e0after_unit) end if -1000 continue deallocate (energy) print *, 'e0aftertra end' End subroutine e0aftertra_ty @@ -522,7 +521,7 @@ SUBROUTINE e0aftertrac_ty oneeff = oneeff - cmplxint -300 end do ! k + end do ! k Call tramo1_ty(i, j, cmplxint) @@ -637,7 +636,7 @@ SUBROUTINE e0aftertrac_ty end if -100 end do ! l + end do ! l end do ! k end do ! j end do ! i @@ -694,9 +693,6 @@ SUBROUTINE e0aftertrac_ty if (rank == 0) then ! Only master ranks are allowed to create files used by CASPT2 except for MDCINTNEW. 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/intra.f90 b/src/intra.f90 index 33c1a7a6..9ad8720b 100644 --- a/src/intra.f90 +++ b/src/intra.f90 @@ -15,6 +15,7 @@ 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 :: unit integer, allocatable :: indsym(:, :, :), nsym(:, :) @@ -78,14 +79,9 @@ SUBROUTINE intra_1(spi, spj, spk, spl, fname) call open_unformatted_file(unit=unit, file=trim(fname), status='old', optional_action='read') do read (unit, 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 the first index integral transformation '//trim(fname) + 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) @@ -129,14 +125,9 @@ SUBROUTINE intra_1(spi, spj, spk, spl, fname) call open_unformatted_file(unit=unit, file=trim(fname), status='old', optional_action='read') do read (unit, 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 the second index integral transformation '//trim(fname) + 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) @@ -170,14 +161,9 @@ SUBROUTINE intra_1(spi, spj, spk, spl, fname) call open_unformatted_file(unit=unit, file=trim(fname), status='old', optional_action='read') do read (unit, 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 the third index integral transformation '//trim(fname) + 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) @@ -211,14 +197,9 @@ SUBROUTINE intra_1(spi, spj, spk, spl, fname) call open_unformatted_file(unit=unit, file=trim(fname), status='old', optional_action='read') do read (unit, 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 the fourth index integral transformation '//trim(fname) + 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) @@ -266,6 +247,7 @@ 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 :: unit = 20 integer, allocatable :: indsym(:, :, :), nsym(:, :) @@ -333,14 +315,9 @@ SUBROUTINE intra_2(spi, spj, spk, spl, fname) call open_unformatted_file(unit=unit, file=trim(fname), status='old', optional_action='read') do read (unit, 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 the first index integral transformation '//trim(fname) + 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) @@ -423,14 +400,9 @@ SUBROUTINE intra_2(spi, spj, spk, spl, fname) do read (unit, 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 the second index integral transformation '//trim(fname) + 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) @@ -465,14 +437,9 @@ SUBROUTINE intra_2(spi, spj, spk, spl, fname) call open_unformatted_file(unit=unit, file=trim(fname), status='old', optional_action='read') do read (unit, 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 the third index integral transformation '//trim(fname) + 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) @@ -507,15 +474,9 @@ SUBROUTINE intra_2(spi, spj, spk, spl, fname) call open_unformatted_file(unit=unit, file=trim(fname), status='old', optional_action='read') do read (unit, 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 the fourth index integral transformation '//trim(fname) + 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) @@ -563,6 +524,7 @@ 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(:, :) @@ -633,15 +595,9 @@ SUBROUTINE intra_3(spi, spj, spk, spl, fname) call open_unformatted_file(unit=unit, file=trim(fname), status='old', optional_action='read') do read (unit, 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 the first index integral transformation '//trim(fname) + 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. @@ -716,15 +672,9 @@ SUBROUTINE intra_3(spi, spj, spk, spl, fname) call open_unformatted_file(unit=unit, file=trim(fname), status='old', optional_action='read') do read (unit, 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 the second index integral transformation '//trim(fname) + 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) @@ -759,15 +709,9 @@ SUBROUTINE intra_3(spi, spj, spk, spl, fname) call open_unformatted_file(unit=unit, file=trim(fname), status='old', optional_action='read') do read (unit, 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 third index integral transformation '//trim(fname) + 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) @@ -802,15 +746,9 @@ SUBROUTINE intra_3(spi, spj, spk, spl, fname) call open_unformatted_file(unit=unit, file=trim(fname), status='old', optional_action='read') do read (unit, 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 the fourth index integral transformation '//trim(fname) + 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) diff --git a/src/module_file_manager.f90 b/src/module_file_manager.f90 index fd96974d..9843ad4b 100644 --- a/src/module_file_manager.f90 +++ b/src/module_file_manager.f90 @@ -10,6 +10,24 @@ module module_file_manager 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 @@ -42,7 +60,7 @@ subroutine open_file(unit, form, file, status, action) character(:), allocatable :: file_status integer :: iostat call search_unused_file_unit(unit) - file_status = trim(status) + 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 @@ -52,6 +70,16 @@ subroutine open_file(unit, form, file, status, action) 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 @@ -61,19 +89,14 @@ subroutine open_unformatted_file(unit, file, status, optional_action) character(:), allocatable :: actual_action, trimmed_action, form if (present(optional_action)) then - trimmed_action = trim(optional_action) + allocate (trimmed_action, source=trim(optional_action)) call lowercase(trimmed_action) - if (trimmed_action /= 'read' .and. trimmed_action /= 'write' .and. trimmed_action /= 'readwrite') then - print *, 'ERROR: trimmed_action must be read, write or readwrite. trimmed_action = ', trimmed_action - print *, 'FILE NAME: ', file - print *, 'Exiting...' - stop - end if - actual_action = trimmed_action + call check_action_type(action=trimmed_action, file=file) + allocate (actual_action, source=trimmed_action) else - actual_action = 'readwrite' + allocate (actual_action, source='readwrite') end if - form = 'unformatted' + allocate (form, source='unformatted') call open_file(unit=unit, form=form, file=file, status=status, action=actual_action) end subroutine open_unformatted_file @@ -85,19 +108,14 @@ subroutine open_formatted_file(unit, file, status, optional_action) character(:), allocatable :: form, actual_action, trimmed_action if (present(optional_action)) then - trimmed_action = trim(optional_action) + allocate (trimmed_action, source=trim(optional_action)) call lowercase(trimmed_action) - if (trimmed_action /= 'read' .and. trimmed_action /= 'write' .and. trimmed_action /= 'readwrite') then - print *, 'ERROR: trimmed_action must be read, write or readwrite. trimmed_action = ', trimmed_action - print *, 'FILE NAME: ', file - print *, 'Exiting...' - stop - end if - actual_action = trimmed_action + call check_action_type(action=trimmed_action, file=file) + allocate (actual_action, source=trimmed_action) else - actual_action = 'readwrite' + allocate (actual_action, source='readwrite') end if - form = 'formatted' + 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/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 365431c5..28d07cd5 100644 --- a/src/read_input_module.f90 +++ b/src/read_input_module.f90 @@ -11,6 +11,7 @@ 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 @@ -23,14 +24,14 @@ subroutine read_input(unit_num) 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. do while (.not. is_end) read (unit_num, "(a)", iostat=iostat) string @@ -69,46 +70,46 @@ subroutine check_input_type(unit_num, string, is_filled) 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(unit_num, 0, 10**9, ninact) + call read_an_integer(unit_num, 0, intmax, ninact) is_filled(1) = .true. case ("nact") - call read_an_integer(unit_num, 0, 10**9, nact) + call read_an_integer(unit_num, 0, intmax, nact) is_filled(2) = .true. case ("nsec") - call read_an_integer(unit_num, 0, 10**9, nsec) + call read_an_integer(unit_num, 0, intmax, nsec) is_filled(3) = .true. case ("nelec") - call read_an_integer(unit_num, 0, 10**9, nelec) + call read_an_integer(unit_num, 0, intmax, nelec) is_filled(4) = .true. case ("nroot") - call read_an_integer(unit_num, 0, 10**9, nroot) + call read_an_integer(unit_num, 0, intmax, nroot) is_filled(5) = .true. case ("selectroot") - call read_an_integer(unit_num, 0, 10**9, selectroot) + call read_an_integer(unit_num, 0, intmax, selectroot) is_filled(6) = .true. case ("totsym") - call read_an_integer(unit_num, 0, 10**9, totsym) + call read_an_integer(unit_num, 0, intmax, totsym) is_filled(7) = .true. case ("ncore") - call read_an_integer(unit_num, 0, 10**9, ncore) + call read_an_integer(unit_num, 0, intmax, ncore) is_filled(8) = .true. case ("nbas") - call read_an_integer(unit_num, 0, 10**9, nbas) + call read_an_integer(unit_num, 0, intmax, nbas) is_filled(9) = .true. case ("eshift") @@ -126,7 +127,7 @@ subroutine check_input_type(unit_num, string, is_filled) is_filled(10) = .true. case ("diracver") - call read_an_integer(unit_num, 0, 10**9, dirac_version) + call read_an_integer(unit_num, 0, intmax, dirac_version) is_filled(11) = .true. case ("ras1") @@ -155,7 +156,7 @@ subroutine check_input_type(unit_num, string, is_filled) end if case ("minholeras1") - call read_an_integer(unit_num, 0, 10**9, min_hole_ras1) + call read_an_integer(unit_num, 0, intmax, min_hole_ras1) case ("end") is_end = .true. @@ -177,15 +178,15 @@ subroutine ras_read(unit_num, ras_list, ras_num) implicit none integer, allocatable, intent(inout) :: ras_list(:) integer, intent(in) :: unit_num, ras_num - character(100) :: tmp_ras_chr + 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 (unit_num, '(a)', iostat=iostat) string ! Read a line of active.inp if (iostat /= 0) then @@ -199,19 +200,17 @@ subroutine ras_read(unit_num, 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(unit_num, 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(unit_num, 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 return ! END SUBROUTINE NORMALLY -10 if (rank == 0) print *, "ERROR: Error in input, can't read ras"//ras_chr//" value!!. Stop the program." - stop + 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,9 +537,12 @@ subroutine parse_range_input_int(string, list, filled_num, allow_int_min, allow_ first_dot_index = index(string, '..') end do - return ! Read the numbers properly -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) + 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) @@ -630,7 +639,7 @@ subroutine read_an_integer(unit_num, allowed_min_int, allowed_max_int, result_in 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 (unit_num, '(a)') input @@ -639,19 +648,22 @@ subroutine read_an_integer(unit_num, allowed_min_int, allowed_max_int, result_in ! 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(unit_num, result_string) @@ -667,7 +679,6 @@ subroutine read_a_string(unit_num, result_string) 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_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_ord_co.f90 b/src/readint2_ord_co.f90 index db6d03c4..5424468a 100644 --- a/src/readint2_ord_co.f90 +++ b/src/readint2_ord_co.f90 @@ -9,6 +9,7 @@ SUBROUTINE readint2_ord_co(filename) ! 2 electorn integrals created by typart in Implicit NONE character*50, intent(in) :: filename + logical :: is_end_of_file character :: datex*10, timex*8 @@ -73,16 +74,9 @@ SUBROUTINE readint2_ord_co(filename) ! 2 electorn integrals created by typart in 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 @@ -93,14 +87,9 @@ 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_unit, 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) + 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 diff --git a/src/readorb_enesym_co.f90 b/src/readorb_enesym_co.f90 index 99b90588..06789927 100644 --- a/src/readorb_enesym_co.f90 +++ b/src/readorb_enesym_co.f90 @@ -14,7 +14,7 @@ SUBROUTINE readorb_enesym_co(filename) ! orbital energies in r4dmoin1 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 @@ -29,12 +29,13 @@ SUBROUTINE readorb_enesym_co(filename) ! orbital energies in r4dmoin1 call open_unformatted_file(unit=mrconee_unit, file=trim(filename), status='old', optional_action='read') Read (mrconee_unit, iostat=iostat) NMO, BREIT, ECORE ! NMO is nbas - ncore - - if (iostat /= 0) then - print *, 'Error in reading NMO, BREIT, ECORE' + 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 - endif + end if + if (rank == 0) then print *, 'NMO, BREIT, ECORE, 1 ! NMO is nbas - ncore' @@ -53,11 +54,13 @@ SUBROUTINE readorb_enesym_co(filename) ! orbital energies in r4dmoin1 Call memplus(size(UTCHEMIMO2), kind(UTCHEMIMO2), 1) Read (mrconee_unit, iostat=iostat) NSYMRP, (REPN(IRP), IRP=1, NSYMRP) ! IRs chars - if (iostat /= 0) then - print *, 'Error in reading NSYMRP, REPN' + 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 - endif + end if + if (rank == 0) then print *, ' NSYMRP, (REPN(IRP),IRP=1,NSYMRP) ! IRs chars' @@ -65,11 +68,13 @@ SUBROUTINE readorb_enesym_co(filename) ! orbital energies in r4dmoin1 end if !Iwamuro modify Read (mrconee_unit, iostat=iostat) nsymrpa, (repna(i0), i0=1, nsymrpa*2) - if (iostat /= 0) then - print *, 'Error in reading nsymrpa, repna' + 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 - endif + end if + if (rank == 0) then print *, nsymrpa, (repna(i0), i0=1, nsymrpa*2) end if @@ -99,11 +104,13 @@ SUBROUTINE readorb_enesym_co(filename) ! orbital energies in r4dmoin1 ! IMO=1,NMO),isp=1,scfru) ! orbital energies <= used here Read (mrconee_unit, iostat=iostat) ((multb(i0, j0), i0=1, 2*nsymrpa), j0=1, 2*nsymrpa) - if (iostat /= 0) then - print *, 'Error in reading multb' + 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 - endif + end if + ! Read(mrconee_unit) (IRPMO(IMO),ORBMO(IMO),IMO=1,NMO) ! orbital energies <= used here !Iwamuro modify diff --git a/src/solvall_A_ord_ty.f90 b/src/solvall_A_ord_ty.f90 index de4db187..dc41b3ec 100644 --- a/src/solvall_A_ord_ty.f90 +++ b/src/solvall_A_ord_ty.f90 @@ -554,6 +554,7 @@ 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 @@ -679,13 +680,9 @@ SUBROUTINE vAmat_ord_ty(v) if (rank == 0) print *, 'open A1int' do read (twoint_unit, 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' + 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 !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -739,13 +736,9 @@ SUBROUTINE vAmat_ord_ty(v) call open_unformatted_file(unit=twoint_unit, file=a2int, status='old', optional_action='read') ! TYPE 2 integrals do read (twoint_unit, 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' + 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)} diff --git a/src/solvall_B_ord_ty.f90 b/src/solvall_B_ord_ty.f90 index 5c54474e..66592d3c 100644 --- a/src/solvall_B_ord_ty.f90 +++ b/src/solvall_B_ord_ty.f90 @@ -584,6 +584,7 @@ SUBROUTINE vBmat_ord_ty(nij, iij, v) complex*16 :: cint2, dens integer :: i, j, k, l, tij integer :: it, iu, iostat, twoint_unit + logical :: is_end_of_file v = 0.0d+00 twoint_unit = default_unit @@ -591,16 +592,9 @@ SUBROUTINE vBmat_ord_ty(nij, iij, v) call open_unformatted_file(unit=twoint_unit, file=bint, status='old', optional_action='read') ! (21|21) stored (ti|uj) i > j do read (twoint_unit, 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 + 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 diff --git a/src/solvall_C_ord_ty.f90 b/src/solvall_C_ord_ty.f90 index 5b7ea7c6..792f8487 100644 --- a/src/solvall_C_ord_ty.f90 +++ b/src/solvall_C_ord_ty.f90 @@ -534,6 +534,7 @@ SUBROUTINE vCmat_ord_ty(v) 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) ! @@ -586,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)) @@ -624,13 +624,9 @@ SUBROUTINE vCmat_ord_ty(v) call open_unformatted_file(unit=twoint_unit, file=c1int, status='old', optional_action='read') do ! Read TYPE 1 integrals C1int until EOF read (twoint_unit, 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' + 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) @@ -666,15 +662,9 @@ SUBROUTINE vCmat_ord_ty(v) call open_unformatted_file(unit=twoint_unit, file=c2int, status='old', optional_action='read') do ! Read TYPE 2 integrals C2int until EOF read (twoint_unit, 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 + 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 ! !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -698,15 +688,9 @@ SUBROUTINE vCmat_ord_ty(v) 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 (twoint_unit, 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 + 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 ! !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ diff --git a/src/solvall_D_ord_ty.f90 b/src/solvall_D_ord_ty.f90 index fdfc870f..f08c41bc 100644 --- a/src/solvall_D_ord_ty.f90 +++ b/src/solvall_D_ord_ty.f90 @@ -521,6 +521,7 @@ SUBROUTINE vDmat_ord_ty(nai, iai, v) 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 @@ -571,13 +572,9 @@ SUBROUTINE vDmat_ord_ty(nai, iai, v) call open_unformatted_file(unit=twoint_unit, file=d1int, status='old', optional_action='read') do read (twoint_unit, 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' + 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 !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -622,13 +619,9 @@ SUBROUTINE vDmat_ord_ty(nai, iai, v) call open_unformatted_file(unit=twoint_unit, file=d2int, status='old', optional_action='read') do read (twoint_unit, 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' + 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 @@ -660,14 +653,9 @@ SUBROUTINE vDmat_ord_ty(nai, iai, v) 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) - - ! Exit the loop if the end of the file is reached - if (iostat < 0) then - if (rank == 0) print *, 'End of D3int' + 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) diff --git a/src/solvall_E_ord_ty.f90 b/src/solvall_E_ord_ty.f90 index 69a15758..8aae43fe 100644 --- a/src/solvall_E_ord_ty.f90 +++ b/src/solvall_E_ord_ty.f90 @@ -505,6 +505,7 @@ SUBROUTINE vEmat_ord_ty(naij, iaij, v) 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 @@ -518,13 +519,9 @@ SUBROUTINE vEmat_ord_ty(naij, iaij, v) call open_unformatted_file(unit=twoint_unit, file=eint, status='old', optional_action='read') ! (31|21) stored do read (twoint_unit, 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' + 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 @@ -538,13 +535,13 @@ SUBROUTINE vEmat_ord_ty(naij, iaij, v) v(taij, k) = v(taij, k) - cint2 - !$OMP parallel do schedule(dynamic,1) private(it,dr,di,dens) - Do it = 1, nact - Call dim1_density(it, k, dr, di) ! k corresponds to p in above formula - dens = DCMPLX(dr, di) - v(taij, it) = v(taij, it) + cint2*dens - End do ! it - !$OMP end parallel do + !$OMP parallel do schedule(dynamic,1) private(it,dr,di,dens) + Do it = 1, nact + Call dim1_density(it, k, dr, di) ! k corresponds to p in above formula + dens = DCMPLX(dr, di) + v(taij, it) = v(taij, it) + cint2*dens + End do ! it + !$OMP end parallel do if (j < l) then cint2 = -1.0d+00*cint2 ! data cint2 becomes initial values! diff --git a/src/solvall_F_ord_ty.f90 b/src/solvall_F_ord_ty.f90 index 70fe3ad2..47c31c66 100644 --- a/src/solvall_F_ord_ty.f90 +++ b/src/solvall_F_ord_ty.f90 @@ -529,6 +529,7 @@ SUBROUTINE vFmat_ord(nab, iab, v) 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 @@ -542,13 +543,9 @@ SUBROUTINE vFmat_ord(nab, iab, v) call open_unformatted_file(unit=twoint_unit, file=fint, status='old', optional_action='read') ! (32|32) stored a > b do read (twoint_unit, 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' + 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 diff --git a/src/solvall_G_ord_ty.f90 b/src/solvall_G_ord_ty.f90 index c8785882..2323f96c 100644 --- a/src/solvall_G_ord_ty.f90 +++ b/src/solvall_G_ord_ty.f90 @@ -504,6 +504,7 @@ SUBROUTINE vGmat_ord_ty(nabi, iabi, v) 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 @@ -516,13 +517,9 @@ SUBROUTINE vGmat_ord_ty(nabi, iabi, v) call open_unformatted_file(unit=twoint_unit, file=gint, status='old', optional_action='read') ! (31|32) stored do read (twoint_unit, 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' + 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 diff --git a/src/solvall_H_ord_ty.f90 b/src/solvall_H_ord_ty.f90 index b3721b3b..e4214e1e 100644 --- a/src/solvall_H_ord_ty.f90 +++ b/src/solvall_H_ord_ty.f90 @@ -15,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, twoint_unit + 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 ! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= ! +=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+= @@ -102,13 +103,9 @@ SUBROUTINE solvH_ord_ty(e0, e2h) call open_unformatted_file(unit=twoint_unit, file=hint, status='old', optional_action='read') do read (twoint_unit, 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 Hint' + 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 Hint' end if if (i <= k .or. j == l) cycle ! Read the next line if i <= k or j == l diff --git a/src/trac.f90 b/src/trac.f90 index a281481b..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 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/unit_test/ras3_bitcheck/test_ras3_bitcheck.f90 b/test/unit_test/ras3_bitcheck/test_ras3_bitcheck.f90 index e4be115c..28d9561d 100644 --- a/test/unit_test/ras3_bitcheck/test_ras3_bitcheck.f90 +++ b/test/unit_test/ras3_bitcheck/test_ras3_bitcheck.f90 @@ -17,7 +17,7 @@ program ras3_bitcheck is_allow = ras3_det_check(i, ras3_max_elec) if (is_allow) then print '(i4,b20)', i, i - write (new_unit, '(i4,b20)'), i, i + write (new_unit, '(i4,b20)') i, i end if end do close (new_unit) 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 f5f8c39a..5f7d26b4 100644 --- a/test/unit_test/sort_test/test_sort_int_reverse.f90 +++ b/test/unit_test/sort_test/test_sort_int_reverse.f90 @@ -5,7 +5,6 @@ program main 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') 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)