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