1C> \ingroup selci
2C> @{
3      subroutine selci_tester(q,h, g, int12, int34, w1, w2, ioconf,
4     $     indxci,
5     $     roots, ci, nconmx, thresh, ept, enew, iconf, ncold,
6     $     vc, iocc, itemp, irange, ptnorm,
7     $     ptnorm_mp,ept_mp,roots_mp)
8*
9* $Id$
10*
11#include "implicit.fh"
12#include "errquit.fh"
13#include "ciinfo.fh"
14#include "mptr.fh"
15#include "global.fh"
16#include "stdio.fh"
17c
18c     argument declarations
19c
20      dimension q(*)
21      dimension h(nnorbs),g(numint),int12(nnorbs),int34(nnorbs),
22     $     w1(nfmax,nfmax,nsmax),w2(nfmax2,nfmax,nsmax-1),
23     $     ioconf(nintpo,nconmx),indxci(nconmx),roots(nroot),
24     $     ci(nci,nroot),ept(nroot),enew(nroot),vc(nfmax,nroot),
25     $     iocc(255), itemp(nintpo), irange(21), ptnorm(nroot)
26      dimension ptnorm_mp(nroot),ept_mp(nroot),roots_mp(nroot)
27c
28      logical selci_ointer, selci_oeq
29c
30c     Do the actual PT selection of new configurations
31c
32c     new test configuration ... have we seen it before, or
33c     is it one of the reference set already ? Does it
34c     have the correct multiplicity?
35c
36      ns = 0
37      do 5 i = 1,norbs
38         if (iocc(i).eq.1) ns = ns + 1
39 5    continue
40      if (mod(ns,2).ne.mod(multi-1,2) .or. ns.lt.multi-1) return
41c
42      if(selci_ointer(iconf-1,ioconf,itemp,nintpo)) return
43c
44      if(selci_oeq(ncold-iconf+1,ioconf(1,iconf),itemp,nintpo)) return
45c
46c     got a brand new configuration ... make vc = <test|H|ci roots>
47c     and <test|H|test> (returned in work1). numf is returned.
48c     (note now only get the diag of <test|H|test>).
49c
50      iwork1 = selci_mptr(nfmax*nfmax)
51      ide = selci_mptr(nroot)
52      idnorm = selci_mptr(nroot)
53      iexv = selci_mptr(mitod(ncold))
54      call selci_mkvc(q, h,g,int12,int34,w1,w2,ioconf,indxci,q(iexv),
55     $     iconf,ncold,ci,vc,iocc,itemp,numf,q(iwork1))
56c
57c     Update energy and ptnorm ... the last correction computed
58c     is the one used for the selection process
59c
60      if(ga_nodeid().eq.0)call util_flush(luout)
61      if (iwpt.eq.0) then       ! EN only
62         call selci_mkdele(numf, nroot, q(ide), vc, roots, q(iwork1),
63     $        nfmax, q(idnorm))
64         call selci_vadd(nroot, q(ide), 1, ept, 1, ept, 1)
65         call selci_vadd(nroot, q(idnorm), 1, ptnorm, 1, ptnorm, 1)
66      else if (iwpt.eq.1) then  ! MP only
67         call selci_mpdele(numf, nroot, q(ide), vc, roots_mp,nfmax,
68     &      q(idnorm),iocc)
69         call selci_vadd(nroot, q(ide), 1, ept_mp, 1, ept_mp, 1)
70         call selci_vadd(nroot, q(idnorm), 1, ptnorm_mp, 1, ptnorm_mp,1)
71      else if (iwpt.eq.2) then  ! Print MP, select on EN
72         call selci_mpdele(numf, nroot, q(ide), vc, roots_mp,nfmax,
73     &      q(idnorm),iocc)
74         call selci_vadd(nroot, q(ide), 1, ept_mp, 1, ept_mp, 1)
75         call selci_vadd(nroot, q(idnorm), 1, ptnorm_mp, 1, ptnorm_mp,1)
76         call selci_mkdele(numf, nroot, q(ide), vc, roots, q(iwork1),
77     $        nfmax, q(idnorm))
78         call selci_vadd(nroot, q(ide), 1, ept, 1, ept, 1)
79         call selci_vadd(nroot, q(idnorm), 1, ptnorm, 1, ptnorm, 1)
80      else if (iwpt.eq.3) then   ! print EN, select on MP
81         call selci_mkdele(numf, nroot, q(ide), vc, roots, q(iwork1),
82     $        nfmax, q(idnorm))
83         call selci_vadd(nroot, q(ide), 1, ept, 1, ept, 1)
84         call selci_vadd(nroot, q(idnorm), 1, ptnorm, 1, ptnorm, 1)
85         call selci_mpdele(numf, nroot, q(ide), vc, roots_mp,nfmax,
86     &      q(idnorm),iocc)
87         call selci_vadd(nroot, q(ide), 1, ept_mp, 1, ept_mp, 1)
88         call selci_vadd(nroot, q(idnorm), 1, ptnorm_mp, 1, ptnorm_mp,1)
89      else
90         call errquit( ' tester: iwpt = ',iwpt, UNKNOWN_ERR)
91      endif
92c
93      test = abs(q(ide-1+idamax(nroot, q(ide), 1)))
94      if (test.gt.0.0d0) then
95         ihash = 1 - nint(2.0d0*log10(test))
96         ihash = min(ihash,21)
97         ihash = max(ihash,1)
98         irange(ihash) = irange(ihash) + numf
99      endif
100c
101      if (test.ge.thresh) then
102c
103c     A reference configuration with too many open shells makes
104c     a calculation with the current code too expensive due to
105c     memory and cpu consumption by coupling coefficients.
106c     Limit the max number of open shells in a reference to 8.
107c
108         if (ns .gt. 8) then
109            write(luout,101) ns, test
110 101        format(' rejecting new reference because 8 < ns =',i3,
111     $           ' : tester = ', 1pd9.2)
112         else
113c
114c     configuration interacts more than threshold ... add to
115c     list and update enew
116c
117            call selci_vadd(nroot, q(ide), 1, enew, 1, enew, 1)
118            noconf = noconf + 1
119            if (noconf.gt.nconmx)
120     $           call errquit(' select: nconf > nconmx',nconmx,
121     &       INPUT_ERR)
122            call selci_icopy(nintpo,itemp,1,ioconf(1,noconf),1)
123 21         format(4x,5f14.7/)
124         endif
125      endif
126c
127      junk = selci_mfree(iwork1)
128c
129      end
130C> @}
131