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! 18C 19c /* deck CC_SETXE */ 20*=====================================================================* 21 SUBROUTINE CC_SETXE(TYPE,IXETRAN,IDOTS,MXTRAN,MXVEC, 22 & IZETA,IOPER,IRLX1,IRLX2,IRLX3,IRLX4, 23 & IDOTVEC,ITRAN,IVEC) 24*---------------------------------------------------------------------* 25* 26* Purpose: set up list of Xi and Eta vectors 27* 28* IXETRAN - list for CC_XIETA routine 29* IDOTS - list of vectors Xi/Eta should be dotted on 30* 31* MXTRAN - maximum IXETRAN list dimension 32* MXVEC - second maximum dimension maximum for IDOTS 33* 34* IZETA - index of left vector for ETA (ignored for Xi) 35* IOPER - index of operator 36* IRLX1 - index for 1. kappa vector (0 for unrelaxed) 37* IRLX3 - index for 2. kappa vector (0 for unrelaxed) 38* IRLX3 - index for 3. kappa vector (0 for unrelaxed) 39* IRLX4 - index for 4. kappa vector (0 for unrelaxed) 40* IDOTVEC - index of vector Xi/Eta should be dotted on 41* 42* ITRAN - index in IXETRAN list 43* IVEC - second index in IDOTS list 44* 45* Written by Christof Haettig, june 1999. 46* 47*=====================================================================* 48 IMPLICIT NONE 49#include "priunit.h" 50#include "cclists.h" 51 INTEGER MXVEC, MXTRAN 52 INTEGER IXETRAN(MXDIM_XEVEC,MXTRAN) 53 INTEGER IDOTS(MXVEC,MXTRAN) 54 55 LOGICAL LFND 56 CHARACTER*3 TYPE 57 INTEGER IOPER, IZETA, IRLX1, IRLX2, IRLX3, IRLX4, IDOTVEC 58 INTEGER ITRAN, IVEC 59 INTEGER I, IDX 60 61* statement functions: 62 LOGICAL LXITST, LETATST, LXEEND 63 INTEGER IL, IO, IR1, IR2, IR3, IR4 64 65 LXITST(ITRAN,IO,IR1,IR2,IR3,IR4) = IXETRAN(1,ITRAN).EQ.IO 66 & .AND. ( 67 & ( ( (IXETRAN(5,ITRAN).EQ.IR1 .AND. IXETRAN(6,ITRAN).EQ.IR2) 68 & .OR.(IXETRAN(5,ITRAN).EQ.IR2 .AND. IXETRAN(6,ITRAN).EQ.IR1)) 69 & .AND. ( (IXETRAN(7,ITRAN).EQ.IR3 .AND. IXETRAN(8,ITRAN).EQ.IR4) 70 & .OR.(IXETRAN(7,ITRAN).EQ.IR4 .AND. IXETRAN(8,ITRAN).EQ.IR3)) 71 & ) .OR. 72 & ( ( (IXETRAN(5,ITRAN).EQ.IR1 .AND. IXETRAN(6,ITRAN).EQ.IR3) 73 & .OR.(IXETRAN(5,ITRAN).EQ.IR3 .AND. IXETRAN(6,ITRAN).EQ.IR1)) 74 & .AND. ( (IXETRAN(7,ITRAN).EQ.IR2 .AND. IXETRAN(8,ITRAN).EQ.IR4) 75 & .OR.(IXETRAN(7,ITRAN).EQ.IR4 .AND. IXETRAN(8,ITRAN).EQ.IR2)) 76 & ) .OR. 77 & ( ( (IXETRAN(5,ITRAN).EQ.IR1 .AND. IXETRAN(6,ITRAN).EQ.IR4) 78 & .OR.(IXETRAN(5,ITRAN).EQ.IR4 .AND. IXETRAN(6,ITRAN).EQ.IR1)) 79 & .AND. ( (IXETRAN(7,ITRAN).EQ.IR3 .AND. IXETRAN(8,ITRAN).EQ.IR2) 80 & .OR.(IXETRAN(7,ITRAN).EQ.IR2 .AND. IXETRAN(8,ITRAN).EQ.IR3)) 81 & ) ) 82 83 LETATST(ITRAN,IL,IO,IR1,IR2,IR3,IR4) = 84 & IXETRAN(2,ITRAN).EQ.IL .AND. LXITST(ITRAN,IO,IR1,IR2,IR3,IR4) 85 86 LXEEND(ITRAN) = ITRAN.GT.MXTRAN .OR. IXETRAN(1,ITRAN).LE.0 87 88*---------------------------------------------------------------------* 89* maintain list of Xi{A} and ETA{A} vectors: 90*---------------------------------------------------------------------* 91 IF (TYPE(1:3).EQ.'Xi ') THEN 92 93 ITRAN = 1 94 LFND = LXITST(ITRAN,IOPER,IRLX1,IRLX2,IRLX3,IRLX4) 95 96 DO WHILE ( .NOT.(LFND.OR.LXEEND(ITRAN))) 97 ITRAN = ITRAN + 1 98 LFND = LXITST(ITRAN,IOPER,IRLX1,IRLX2,IRLX3,IRLX4) 99 END DO 100 101 IF (.NOT.LFND) THEN 102 IXETRAN(1,ITRAN) = IOPER 103 IXETRAN(3,ITRAN) = 0 104 IXETRAN(5,ITRAN) = IRLX1 105 IXETRAN(6,ITRAN) = IRLX2 106 IXETRAN(7,ITRAN) = IRLX3 107 IXETRAN(8,ITRAN) = IRLX4 108 END IF 109 110 ELSE IF (TYPE(1:3).EQ.'Eta') THEN 111 ITRAN = 1 112 LFND = LETATST(ITRAN,IZETA,IOPER,IRLX1,IRLX2,IRLX3,IRLX4) 113 114 DO WHILE ( .NOT.(LFND.OR.LXEEND(ITRAN))) 115 ITRAN = ITRAN + 1 116 LFND = LETATST(ITRAN,IZETA,IOPER,IRLX1,IRLX2,IRLX3,IRLX4) 117 END DO 118 119 IF (.NOT.LFND) THEN 120 IXETRAN(1,ITRAN) = IOPER 121 IXETRAN(2,ITRAN) = IZETA 122 IXETRAN(5,ITRAN) = IRLX1 123 IXETRAN(6,ITRAN) = IRLX2 124 IXETRAN(7,ITRAN) = IRLX3 125 IXETRAN(8,ITRAN) = IRLX4 126 END IF 127 128 END IF 129 130 131 IVEC = 1 132 DO WHILE (IDOTS(IVEC,ITRAN).NE.IDOTVEC .AND. 133 & IDOTS(IVEC,ITRAN).NE.0 .AND. IVEC.LE.MXVEC) 134 IVEC = IVEC + 1 135 END DO 136 137 IDOTS(IVEC,ITRAN) = IDOTVEC 138 IF (TYPE(1:3).EQ.'Eta') IXETRAN(4,ITRAN) = 0 139 IF (TYPE(1:3).EQ.'Xi ') IXETRAN(3,ITRAN) = 0 140 141*---------------------------------------------------------------------* 142 IF (IVEC.GT.MXVEC .OR. ITRAN.GT.MXTRAN) THEN 143 WRITE (LUPRI,*) 'TYPE :',TYPE 144 WRITE (LUPRI,*) 'IZETA :',IZETA 145 WRITE (LUPRI,*) 'IOPER :',IOPER 146 WRITE (LUPRI,*) 'IRLX1-4:',IRLX1,IRLX2,IRLX3,IRLX4 147 WRITE (LUPRI,*) 'IDOTVEC:',IDOTVEC 148 WRITE (LUPRI,*) 'IVEC :',IVEC 149 WRITE (LUPRI,*) 'ITRAN :',ITRAN 150 IDX = 1 151 DO WHILE( .NOT. LXEEND(IDX) ) 152 WRITE(LUPRI,'(A,8I5,5X,(12I5,20X))') 'CC_SETXE>', 153 & (IXETRAN(I,IDX),I=1,8),(IDOTS(I,IDX),I=1,MXVEC) 154 IDX = IDX + 1 155 END DO 156 CALL FLSHFO(LUPRI) 157 CALL QUIT('Overflow error in CC_SETXE.') 158 END IF 159 160 RETURN 161 END 162 163*---------------------------------------------------------------------* 164* END OF SUBROUTINE CC_SETXE * 165*---------------------------------------------------------------------* 166