1 subroutine xc_sicinit(rtdb, test_sic, condfukui, exact_pot, 2 & l_degen, i_degen, noc, act_levels) 3 implicit none 4#include "errquit.fh" 5c 6c $Id$ 7c 8#include "rtdb.fh" 9#include "mafdecls.fh" 10#include "global.fh" 11#include "util.fh" 12 integer l_degen, i_degen(2), noc(2), tot_oc, act_levels 13 integer rtdb ! [in] 14 integer test_sic,condfukui,exact_pot ! [out] 15c 16c 17 if (.not. rtdb_get(rtdb, 'dft:test_sic', mt_int, 1, 18 & test_sic))test_sic = 0 19 if (.not. rtdb_get(rtdb, 'dft:condfukui', mt_int, 1, 20 & condfukui)) condfukui = 0 21 if (.not. rtdb_get(rtdb, 'dft:exact_pot', mt_int, 1, 22 & exact_pot)) exact_pot = 0 23 if (test_sic.ne.0) then 24 if (.not. rtdb_get(rtdb, 'dft:act_levels', mt_int, 1, 25 & act_levels)) act_levels = 10000 26 tot_oc = noc(1) + noc(2) 27 if (.not.MA_Push_Get(MT_Int, tot_oc, 'degen_homo', 28 & l_degen, i_degen(1))) 29 & call errquit('dft_scf: cannot allocate degen homo',0, MA_ERR) 30 end if 31 return 32 end 33 subroutine xc_sicdeg(i_degen, evals, n_levels, act_levels) 34 implicit none 35#include "mafdecls.fh" 36#include "cdft.fh" 37c 38 integer i_degen(2), evals(2), n_levels(2) 39c 40 integer isp, j, aux_levels, n_orbitals, act_levels 41 double precision start 42 do isp=1,ipol 43 if (isp.eq.2) i_degen(2) = i_degen(1) + noc(1) 44 if (noc(isp).ne.0) then 45 aux_levels = 1 46 n_orbitals = 1 47 Int_MB(i_degen(isp) + aux_levels - 1) = n_orbitals 48 do j = noc(isp),2,-1 49 start = (dbl_mb(evals(isp) + j - 1) - 50 & dbl_mb(evals(isp) + j - 2)) 51 if (start.le.1.0d-04) then 52 n_orbitals = n_orbitals + 1 53 else 54 n_orbitals = 1 55 aux_levels = aux_levels + 1 56 end if 57 Int_MB(i_degen(isp) + aux_levels - 1) = n_orbitals 58 end do 59 n_levels(isp) = aux_levels 60 else 61 n_levels(isp) = 0 62 end if 63 end do 64 do isp = 1, ipol 65 if (n_levels(isp).ne.0) then 66 if(n_levels(isp).gt.act_levels) n_levels(isp) = act_levels 67 end if 68 end do 69 return 70 end 71