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