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