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