1 subroutine fock_j_fit(nmat, g_dens, g_j) 2c 3c $Id$ 4c 5c Wrapper routine for AO-basis J matrices with fitting 6c 7c BGJ - 2/99 8c 9 implicit none 10c 11 integer nmat ! [input] number of J matrices 12 integer g_dens(nmat) ! [input] array of handles to densities 13 integer g_j(nmat) ! [input] array of handles to J matrices 14c 15c Local declarations 16c 17 call fock_j_fit_gen(nmat, g_dens, g_j, 0d0, .false., .true.) 18c 19 return 20 end 21c 22c 23 subroutine fock_j_fit_gen(nmat, g_dens, g_j, Tvec, have_Tvec, 24 & do_init) 25c 26c $Id$ 27c 28c Wrapper routine for AO-basis J matrices with fitting 29c 30c BGJ - 2/99 31c 32 implicit none 33#include "errquit.fh" 34c 35#include "global.fh" 36#include "mafdecls.fh" 37#include "../nwdft/include/cdft.fh" 38c!!! BGJ 39#include "bgj.fh" 40#include "rtdb.fh" 41c!!! BGJ 42c 43 integer nmat ! [input] number of J matrices 44 integer g_dens(nmat) ! [input] array of handles to densities 45 integer g_j(nmat) ! [input] array of handles to J matrices 46 logical derfit ! [input] whether derivative density fit 47c ! *** from rtdb 48c ! ******* !!! document here !!! 49 double precision Tvec(*) ! [input] right side vectors for fits 50 logical have_Tvec ! [input] whether right side vectors are given 51 logical do_init ! [input] whether to zero J matrices 52c 53c Local declarations 54c 55 integer imat 56 integer rtdb 57 integer ntotel, n_batch, n3c_int, n3c_dbl, iwhat_max, 58 & n_semi_bufs, fd 59 integer l_cd_coef, k_cd_coef 60 integer idum 61 double precision Ecoul 62 double precision ddum 63 logical IOLGC, old_incore, old_direct 64c 65 if (bgj_print() .gt. 0) 66 & write(*,*)'--------Entered fock_j_fit-------------' 67 rtdb = bgj_get_rtdb_handle() 68c write(*,*)'nmat rtdb geom',nmat,rtdb,geom 69c 70c Get fock_j_fit variables 71c 72 if (.not. rtdb_get(rtdb, 'fock_j:derfit', mt_log, 1, 73 & derfit)) then 74 if (bgj_print() .gt. 0) 75 & write(*,*)'*** fock_j_fit: derfit not set: setting to false' 76 derfit = .false. !!! 77 endif 78 if (bgj_print() .gt. 0) 79 & write(*,*)'fock_j_fit: derfit =',derfit 80c 81c Initialize J matrices 82c 83c write(*,*)'*** do_init',do_init 84 if (do_init) then 85 do imat = 1, nmat 86c write(*,*)'Density matrix',imat 87c call ga_print(g_dens(imat)) 88c write(*,*)'*** zeroing g_j' 89 call ga_zero(g_j(imat)) 90 enddo 91 endif 92c 93c Set up scratch space for dft_fitcd and dft_fitvc 94c 95 if (.not.MA_Push_Get(MT_Dbl,nbf_cd*nmat,'cd_coef',l_cd_coef, 96 & k_cd_coef)) 97 & call errquit('fock_j_fit: cannot allocate cd_coef',0, MA_ERR) 98c 99c Prepare to call fitting routines 100c 101 idum = -1 102 ddum = -1d0 103c!!! Set up for cdinv to be allocated in dft_cdfit 104 IOLGC = .true. 105 if (noio.eq.1)IOLGC = .FALSE. 106 if (ipol.eq.1)then 107 nTotEl = 2*noc(1) 108 else 109 nTotEl = noc(1) + noc(2) 110 endif 111c!!! Set things up for direct to begin with - can refine to semi-direct 112c!!! after things are working 113 old_incore = incore 114 old_direct = direct 115 incore = .false. !!! 116 direct = .true. !!! 117 n_batch = 0 !!! 118 n3c_int = 0 !!! 119 n3c_dbl = 0 !!! 120 fd = 0 !!! 121 n_semi_bufs = 0 !!! 122 iwhat_max = -1 !!! 123c 124c Determine the fitting coefficients 125c 126 call dft_fitcd(nmat,dbl_mb(k_cd_coef), idum, Ecoul, 127 & g_dens, nTotEl, n_batch, n3c_int, 128 & idum, n3c_dbl, iwhat_max, n_semi_bufs, fd, IOLGC, 129 & idum, derfit, Tvec, 130 & have_Tvec) 131c 132c Compute the J matrices using the fitting coefficients 133c 134 call dft_fitvc(dbl_mb(k_cd_coef), idum, Ecoul, g_j, 135 & n_batch, n3c_int, idum, n3c_dbl, 136 & iwhat_max, n_semi_bufs, fd, IOLGC, 137 & derfit, nmat, do_init) 138c 139c Clean up 140c 141 if (.not.ma_pop_stack(l_cd_coef)) 142 & call errquit('fock_j_fit: cannot pop stack',0, MA_ERR) 143 direct = old_direct 144 incore = old_incore 145c 146 if (bgj_print() .gt. 0) then 147 do imat = 1, nmat 148 write(*,*)'Fitted J matrix',imat 149 call ga_print(g_j(imat)) 150 enddo 151 write(*,*)'--------Leaving fock_j_fit-------------' 152 endif 153c 154 return 155 end 156