******************************************************************************** * * * 2DHF version 1-2003 * * Copyright (C) 1996 Jacek Kobus, Leif Laaksonen, Dage Sundholm * * * * This software may be used and distributed according to the terms * * of the GNU General Public License, see README and COPYING. * * * ******************************************************************************** c ### homo_check ### c c Determines Ci symmetry of a given orbital and uses it to replace c the values in the [pi/2,pi] region by these from the [0,pi/2] one. c subroutine homo_check(psi) implicit integer*4 (i-n) implicit real*8 (a-h,o-z) character*8 sigma,pi,delta,phi include 'commons8.inc' dimension psi(*) data sigma/'sigma'/,pi/'pi'/,delta/'delta'/,phi/'phi'/ write(*,1000) do iorb=1,norb ibeg = i1b(iorb) nmut = i1mu(iorb) call homo_check1(nmut,psi(ibeg),ihsym) if (ihsym.eq.1) then if (bond(iorb).eq.sigma.or.bond(iorb).eq.delta) then write(*,1005) iorn(iorb),bond(iorb),gut(iorb) else write(*,1010) iorn(iorb),bond(iorb),gut(iorb) endif endif if (ihsym.eq.-1) then if(bond(iorb).eq.sigma.or.bond(iorb).eq.delta) then write(*,1010) iorn(iorb),bond(iorb),gut(iorb) else write(*,1005) iorn(iorb),bond(iorb),gut(iorb) endif endif enddo 01000 format(/,' checking symmetry of orbitals:'/, & ' required actual ') 01005 format(1x,i3,1x,a8,1x,a1,10x,'g') 01010 format(1x,i3,1x,a8,1x,a1,10x,'u') return end c ### homo_check1 ### c subroutine homo_check1 (nmut,psii,ihsym) implicit integer*4 (i-n) implicit real*8 (a-h,o-z) include 'commons8.inc' dimension psii(nni,nmut) n2=(nni-1)/2+1 if (psii(2,10)*psii(nni-1,10).gt.0.d0) then ihsym= 1 else ihsym=-1 endif return end