1! 2! Dalton, a molecular electronic structure program 3! Copyright (C) by the authors of Dalton. 4! 5! This program is free software; you can redistribute it and/or 6! modify it under the terms of the GNU Lesser General Public 7! License version 2.1 as published by the Free Software Foundation. 8! 9! This program is distributed in the hope that it will be useful, 10! but WITHOUT ANY WARRANTY; without even the implied warranty of 11! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 12! Lesser General Public License for more details. 13! 14! If a copy of the GNU LGPL v2.1 was not distributed with this 15! code, you can obtain one at https://www.gnu.org/licenses/old-licenses/lgpl-2.1.en.html. 16! 17! 18 SUBROUTINE CHANNEL_VAR() 19 IMPLICIT NONE 20#include "infvar.h" 21#include "channel.h" 22#include "wrkrsp.h" 23 INTEGER IOP, CIOP, J, CORBJ 24 INTEGER, allocatable :: CHANNEL_JWOP(:,:) 25C 26C Core RPA: redefine the excitation manifold, 27C restrict to excitations involving the few chosen 28C orbitals in CHANNEL_ORB 29C 30 allocate( CHANNEL_JWOP(2,MAXWOP) ) 31 CIOP = 0 32 DO J = 1, CHANNEL_NORB 33 CORBJ = CHANNEL_ORB(J) 34 DO IOP = 1,KZWOPT 35 IF (JWOP(1,IOP).EQ.CORBJ) THEN 36 CIOP = CIOP + 1 37 CHANNEL_JWOP(1,CIOP) = JWOP(1,IOP) 38 CHANNEL_JWOP(2,CIOP) = JWOP(2,IOP) 39 END IF 40 END DO 41 END DO 42 CALL ICOPY(2*CIOP,CHANNEL_JWOP,1,JWOP,1) 43 KZWOPT = CIOP 44 KZYWOP = 2*CIOP 45 NWOPT = CIOP 46C 47 deallocate( CHANNEL_JWOP ) 48 RETURN 49 END 50 SUBROUTINE CHANNEL_VIR() 51 IMPLICIT NONE 52#include "priunit.h" 53#include "infvar.h" 54#include "channel.h" 55#include "wrkrsp.h" 56#include "inforb.h" 57 INTEGER IOP, CIOP, J, CORBJ,ISYM,IMAX 58 INTEGER MAXVIRT(8) 59 INTEGER, allocatable :: CHANNEL_JWOP(:,:) 60C 61C Core RPA: redefine the excitaiton manifold 62C to delete high virtual orbitals 63C 64 allocate( CHANNEL_JWOP(2,MAXWOP) ) 65 DO ISYM=1,NSYM 66 IF (NASH(ISYM).NE.0) THEN 67 WRITE (LUPRI,'(/A)') 68 & 'WARNING: virtual channel restriction not tested' 69 & //' for open shells.' 70 ENDIF 71 IF (CHANNEL_VIRT(ISYM).EQ.-1) THEN 72 MAXVIRT(ISYM) = IORB(ISYM) + NISH(ISYM) + NASH(ISYM) + 73 & NSSH(ISYM) 74 ELSE 75 MAXVIRT(ISYM) = IORB(ISYM) + NISH(ISYM) + NASH(ISYM) + 76 & CHANNEL_VIRT(ISYM) 77 ENDIF 78 WRITE (LUPRI,*) 'MAXVIRT(',ISYM,')=',MAXVIRT(ISYM) 79 ENDDO 80 CIOP = 0 81 DO IOP = 1,KZWOPT 82 DO ISYM=1,NSYM 83 IMAX= IORB(ISYM) + NISH(ISYM) + NASH(ISYM) 84 IF (JWOP(2,IOP).GE.IMAX.AND. 85 & JWOP(2,IOP).LE.MAXVIRT(ISYM)) THEN 86 CIOP = CIOP + 1 87 CHANNEL_JWOP(1,CIOP) = JWOP(1,IOP) 88 CHANNEL_JWOP(2,CIOP) = JWOP(2,IOP) 89c WRITE(LUPRI,*) 'Keeping',JWOP(1,IOP),JWOP(2,IOP) 90 GOTO 10 91 ELSE 92c WRITE(LUPRI,*) 'Skipping',JWOP(1,IOP),JWOP(2,IOP) 93 END IF 94 ENDDO 95 10 CONTINUE 96 END DO 97 CALL ICOPY(2*CIOP,CHANNEL_JWOP,1,JWOP,1) 98 KZWOPT = CIOP 99 KZYWOP = 2*CIOP 100 NWOPT = CIOP 101C 102 deallocate( CHANNEL_JWOP ) 103 RETURN 104 END 105