1* $Id$ 2 subroutine destdul(ikbl,nbls,nblok1,ncs,inx,buf, 3 * buffer, icfx,jcfx,kcfx,lcfx, q4, use_q4, 4 * icfg,jcfg,kcfg,lcfg,ngcd,lnijkl,indxp,ipres,iqorder, 5 * map_txs_pnl) 6c---------------------------------------------------------------- 7c gradient derivatives 8c 9c This is called for PNL-requested set of contracted shell quartets. 10c Only non-zero Integrals return WITH labels and they do not have 11c to be in PNL-requested order. 12c 13c buf - in-comming integrals 14c 15c buffer - outgoing integrals 16c icfx()-lcfx() - corresponding labels (PNL) 17c---------------------------------------------------------------- 18 implicit real*8 (a-h,o-z) 19 integer map_txs_pnl(*) ! txs to pnl basis map = ncfunct 20 logical use_q4 21 common /contr/ ngci,ngcj,ngck,ngcl,lci,lcj,lck,lcl,lcij,lckl 22 common /lengt/ ilen,jlen,klen,llen, ilen1,jlen1,klen1,llen1 23 common /neglect/ eps,eps1,epsr 24 common /pnl002/ ncshell,ncfunct,nblock2,integ_n0 25 common /intgop/ ncache,maxprice,iprint,iblock 26c---------------------------------------------------------------------- 27 double precision savezerotol 28 common /csavezerotol/ savezerotol ! Used in detbul,set in texas_hf 29c---------------------------------------------------------------------- 30c 31 dimension icfx(*),jcfx(*),kcfx(*),lcfx(*) 32 dimension nblok1(2,*) 33 dimension buf(9,nbls,lnijkl,ngcd) 34 dimension inx(12,*) 35c 36cccc dimension buffer(9,*) 37 dimension buffer(12,*) 38c 39 dimension icfg(*),jcfg(*),kcfg(*),lcfg(*) 40 dimension ipres(*), iqorder(*) 41 dimension indxp(*) 42 dimension q4(*) 43 dimension lder(12) ! to re-order derivativs according to atoms 44 dimension iix(4) 45c 46 double precision xtmp(12) 47c 48 double precision threshold ! For screening output integrals 49c-------------------------------- 50c do not zero out integ_n0 here 51c---------------------------- 52c loop over quartets belonging to the block IKBL : 53c 54c 55 do 10 ijklp=1,nbls 56 ijkl=indxp(ijklp) 57 if(ijkl.eq.0) go to 10 58 iqreq=ipres(ijkl) 59 if(iqreq.eq.0) go to 10 60 iorder=iqorder(iqreq) 61c test 62c write(6,*)'destDul iorder=',iorder 63c test 64 call reorder_der1(iorder,lder) 65 if(use_q4) THEN 66 symfact=q4(iqreq) 67 else 68 symfact = 1.0d0 69 endif 70c 71 threshold = savezerotol/symfact 72c 73c--------------------------------------- 74c write(6 ,1230) ijkl,iqreq,iorder 75c 1230 format('quart=',i5,' req-quart=,i5,' iorder=',i4 ) 76c--------------------------------------- 77 ijcs=nblok1(1,ijkl) 78 klcs=nblok1(2,ijkl) 79 call get_ij_half(ijcs,ics,jcs) 80 call get_ij_half(klcs,kcs,lcs) 81 if(ngcd.eq.1) then 82 ngcq=1 83 icfg(1)=inx(11,ics) 84 jcfg(1)=inx(11,jcs) 85 kcfg(1)=inx(11,kcs) 86 lcfg(1)=inx(11,lcs) 87 else 88 call indexg(inx,ics,jcs,kcs,lcs,ijcs,klcs, 89 * ilen,jlen,klen,llen, icfg,jcfg,kcfg,lcfg,ngcq) 90 endif 91c 92 do iqu=1,ngcq 93 icff=icfg(iqu) 94 jcff=jcfg(iqu) 95 kcff=kcfg(iqu) 96 lcff=lcfg(iqu) 97 icff=map_txs_pnl(icff+1)-1 ! Relies on txs order = pnl order 98 jcff=map_txs_pnl(jcff+1)-1 99 kcff=map_txs_pnl(kcff+1)-1 100 lcff=map_txs_pnl(lcff+1)-1 101cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc 102 integ=0 103 do icf=icff+1,icff+ilen 104 do jcf=jcff+1,jcff+jlen 105 do kcf=kcff+1,kcff+klen 106 do lcf=lcff+1,lcff+llen 107 integ=integ+1 108c------> xint0=buf(integ) 109 xtmp( 1)=buf(1,ijklp,integ,iqu) ! xinta 110 xtmp( 2)=buf(4,ijklp,integ,iqu) ! yinta 111 xtmp( 3)=buf(7,ijklp,integ,iqu) ! zinta 112 xtmp( 4)=buf(2,ijklp,integ,iqu) ! xintb 113 xtmp( 5)=buf(5,ijklp,integ,iqu) ! yintb 114 xtmp( 6)=buf(8,ijklp,integ,iqu) ! zintb 115 xtmp( 7)=buf(3,ijklp,integ,iqu) ! xintc 116 xtmp( 8)=buf(6,ijklp,integ,iqu) ! yintc 117 xtmp( 9)=buf(9,ijklp,integ,iqu) ! zintc 118 xnorm = 0.0d0 119 do i = 1, 9 120 xnorm = xnorm + xtmp(i)*xtmp(i) 121 enddo 122 if (xnorm .gt. threshold*threshold) then 123 xtmp(10)=-(xtmp(1)+xtmp(4)+xtmp(7)) 124 xtmp(11)=-(xtmp(2)+xtmp(5)+xtmp(8)) 125 xtmp(12)=-(xtmp(3)+xtmp(6)+xtmp(9)) 126 integ_n0=integ_n0+1 127 do i = 1, 12 128 buffer(lder(i),integ_n0) = xtmp(i)*symfact 129 enddo 130 call lab_req(iorder,icf,jcf,kcf,lcf,iix) 131c 132c---------------------------> icfx(integ_n0)=icf 133c jcfx(integ_n0)=jcf 134c kcfx(integ_n0)=kcf 135c---------------------------> lcfx(integ_n0)=lcf 136 icfx(integ_n0)=iix(1) 137 jcfx(integ_n0)=iix(2) 138 kcfx(integ_n0)=iix(3) 139 lcfx(integ_n0)=iix(4) 140c 141 if(iprint.ge.2) then 142 call print_der1(ics,jcs,kcs,lcs,inx, 143 * buf(1,ijklp,integ,iqu), 144 * icf,jcf,kcf,lcf) 145 endif 146 endif ! threshold 147 enddo 148 enddo 149 enddo 150 enddo 151 enddo 152c 153 10 continue 154c-------------------------------------------------------- 155 end 156 157