1C> \ingroup selci
2C> @{
3      subroutine selci_slect(q,h,g,int12,int34,w1,w2,ioconf,indxci,
4     $     roots,ci,nconmx,ncold,thresh,ept,enew,irange, ptnorm,
5     &     ptnorm_mp,ept_mp,roots_mp,min2c)
6*
7* $Id$
8*
9#include "implicit.fh"
10#include "ciinfo.fh"
11#include "mptr.fh"
12#include "global.fh"
13#include "stdio.fh"
14      dimension q(*)
15      dimension h(nnorbs),g(numint),int12(nnorbs),int34(nnorbs),
16     $     w1(nfmax,nfmax,nsmax),w2(nfmax2,nfmax,nsmax-1),
17     $     ioconf(nintpo,nconmx),indxci(nconmx),roots(nroot),
18     $     ci(nci,nroot),ept(nroot),enew(nroot),irange(21),
19     $     ptnorm(nroot),
20     &     ptnorm_mp(nroot), ept_mp(nroot), roots_mp(nroot)
21c
22      dimension iocc(255), itemp(32)
23#include "bitops.fh"
24c
25c     loop thru single and double replacements from the current set
26c     of orbital configurations. If this replacement interacts with
27c     a previous configuration then we have already done this one.
28c     Compute <*|H|I> where <*| label the spin functions in the new
29c     configuration and I is the Ith root wavefunction. Then compute
30c     the predicted energy lowering for each root. Add this to the
31c     total PT corrected CI energy. If the energy lowering for any
32c     root is greater than the input threshold then add this to the
33c     list and add the incremental lowering to the prediction for the
34c     new ci energy.
35c
36      ivc = selci_mptr(nfmax*nroot)
37      call dfill(nroot,0.0d0,ept,1)
38      call dfill(nroot,0.0d0,ept_mp,1)
39      call dfill(nroot,0.0d0,enew,1)
40      call dfill(nroot,0.0d0,ptnorm,1)
41      call dfill(nroot,0.0d0,ptnorm_mp,1)
42      call ifill(21,0,irange,1)
43c
44c     loop through orbital configurations already in ci
45c
46      iconfm = 0
47      nproc  = ga_nnodes()
48      me     = ga_nodeid()
49      master = 0
50      icount = -1
51c
52c     If first pass through selci then kill all restart files
53c
54      if (ncold.eq.1.and.me.eq.0) call restk
55      i10str = 1
56      call selci_restin(i10str,ept,ept_mp,enew,ptnorm,ptnorm_mp,
57     &     nroot,irange,21,iwpt,
58     &     noconf,ioconf,nintpo,nconmx,ncold)
59c
60c     Checkpoint after each 5% of configurations
61c
62      iconfm = max(100,ncold/20)
63c
64      do 10 iconf = i10str,ncold
65c
66         if(min2c .gt. 0) then
67            if(mod(iconf,iconfm).eq.0) then
68               call selci_stool(iconf,ept,ept_mp,enew,ptnorm,ptnorm_mp,
69     &              nroot,irange,21,iwpt,
70     &              noconf,ioconf,nintpo,nconmx,ncold)
71            endif
72         endif
73         if(ga_nodeid().eq.0) call util_flush(luout)
74c
75         call selci_upkcon(norbs, iocc, ioconf(1,iconf), nintpo, nbitpi)
76c
77c     single replacements i -> j
78c
79         do 20 i = 1,norbs
80            if (iocc(i).eq.0) goto 20
81c
82            icount = icount + 1
83            if (mod(icount,nproc).ne.me) goto 20
84c
85            iold = iocc(i)
86            iocc(i) = iocc(i) - 1
87            if (iocc(i).eq.2) iocc(i) = 1
88            do 30 j = 1,norbs
89               if (isym(i).ne.isym(j) .or.
90     $              j.eq.i .or. iocc(j).eq.3) goto 30
91               jold = iocc(j)
92               iocc(j) = iocc(j) + 1
93               if (iocc(j).eq.2) iocc(j) = 3
94               call selci_pkcon(norbs, iocc, itemp, nintpo, nbitpi)
95c
96               call selci_tester(q, h, g, int12, int34, w1, w2, ioconf,
97     $              indxci, roots, ci, nconmx, thresh, ept, enew,
98     $              iconf, ncold, q(ivc), iocc, itemp, irange, ptnorm,
99     &              ptnorm_mp,ept_mp,roots_mp)
100c
101               iocc(j) = jold
102 30         continue
103            iocc(i) = iold
104 20      continue
105c
106c     double replacements (i,j) -> (k,l) ... what makes you think
107c     that this is going to be slooooow.
108c
109         do 40 i = 1,norbs
110            if (iocc(i).eq.0) goto 40
111            iold = iocc(i)
112            iocc(i) = iocc(i) - 1
113            if (iocc(i).eq.2) iocc(i) = 1
114            do 50 j = i,norbs
115               if (iocc(j).eq.0) goto 50
116               jold = iocc(j)
117               iocc(j) = iocc(j) - 1
118               if (iocc(j).eq.2) iocc(j) = 1
119               do 60 k = 1,norbs
120                  if (k.eq.i .or. k.eq.j .or. iocc(k).eq.3) goto 60
121                  kold = iocc(k)
122                  iocc(k) = iocc(k) + 1
123                  if (iocc(k).eq.2) iocc(k) = 3
124                  ijksym = ieor(ieor(isym(i),isym(j)),isym(k))
125                  do 70 l = k,norbs
126                     if (isym(l).ne.ijksym .or. l.eq.i .or.
127     $                    l.eq.j .or. iocc(l).eq.3) goto 70
128c
129                          icount = icount + 1
130                          if (mod(icount,nproc).ne.me) goto 70
131c
132                          lold = iocc(l)
133                          iocc(l) = iocc(l) + 1
134                          if (iocc(l).eq.2) iocc(l) = 3
135                          call selci_pkcon(norbs,iocc,itemp,
136     $                         nintpo,nbitpi)
137c
138                          call selci_tester(q, h, g, int12, int34,
139     $                         w1, w2,
140     $                         ioconf, indxci, roots, ci, nconmx,
141     $                         thresh, ept, enew, iconf, ncold,
142     $                         q(ivc), iocc, itemp, irange, ptnorm,
143     $                         ptnorm_mp,ept_mp,roots_mp)
144c
145                          iocc(l) = lold
146 70                    continue
147                       iocc(k) = kold
148 60                 continue
149                    iocc(j) = jold
150 50              continue
151                 iocc(i) = iold
152 40           continue
153c
154 10        continue
155c
156           junk = selci_mfree(ivc)
157c
158           end
159C> @}
160