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 19*=====================================================================* 20 SUBROUTINE CCKAPPASQ(KAPPASQ,KAPPA,ISYKAP,TRANS) 21*---------------------------------------------------------------------* 22* 23* Purpose: resort kappa vector to full matrix scheme 24* 25* TRANS = 'N' : KAPPASQ <-- KAPPA 26* TRANS = 'T' : KAPPASQ <-- KAPPA^T 27* 28* Christof Haettig 8-2-1999 29* 30*---------------------------------------------------------------------* 31 IMPLICIT NONE 32#include "priunit.h" 33#include "ccorb.h" 34#include "ccsdsym.h" 35#include "ccfro.h" 36 37 LOGICAL LOCDBG 38 PARAMETER (LOCDBG = .FALSE.) 39 40 CHARACTER*(1) TRANS 41 INTEGER ISYKAP 42 43#if defined (SYS_CRAY) 44 REAL KAPPASQ(*), KAPPA(*) 45#else 46 DOUBLE PRECISION KAPPASQ(*), KAPPA(*) 47#endif 48 49 INTEGER ISYMA, ISYMI, IORBA, IORBI, KKIA, KKAI, KSAI, KSIA 50 51*---------------------------------------------------------------------* 52* resort kappa vector: 53*---------------------------------------------------------------------* 54 CALL DZERO(KAPPASQ,N2BST(ISYKAP)) 55 56 DO ISYMI = 1, NSYM 57 ISYMA = MULD2H(ISYMI,ISYKAP) 58 59 DO I = 1, NRHFS(ISYMI) 60 DO A = 1, NVIRS(ISYMA) 61 62 IORBI = I 63 IORBA = NRHFS(ISYMA) + A 64 65 KKAI = IALLAI(ISYMA,ISYMI) + (I-1)*NVIRS(ISYMA) + A 66 KSAI = IAODIS(ISYMA,ISYMI) + (IORBI-1)*NORBS(ISYMA) + IORBA 67 68 KKIA = NALLAI(ISYKAP) + KKAI 69 KSIA = IAODIS(ISYMI,ISYMA) + (IORBA-1)*NORBS(ISYMI) + IORBI 70 71 IF (TRANS.EQ.'N' .OR. TRANS.EQ.'n') THEN 72C KAPPASQ(KSAI) = -KAPPA(KKIA) 73 KAPPASQ(KSAI) = KAPPA(KKAI) 74 KAPPASQ(KSIA) = KAPPA(KKIA) 75C KAPPASQ(KSIA) = - KAPPA(KKAI) 76 ELSE IF (TRANS.EQ.'T' .OR. TRANS.EQ.'t') THEN 77C KAPPASQ(KSIA) = -KAPPA(KKIA) 78 KAPPASQ(KSIA) = KAPPA(KKAI) 79 KAPPASQ(KSAI) = KAPPA(KKIA) 80C KAPPASQ(KSAI) = - KAPPA(KKAI) 81 ELSE 82 CALL QUIT('Illegal value of TRANS in CCKAPPASQ.') 83 END IF 84 85 END DO 86 END DO 87 88 END DO 89 90*---------------------------------------------------------------------* 91* print to output & return: 92*---------------------------------------------------------------------* 93 IF (LOCDBG) THEN 94 WRITE (LUPRI,*) 'CCKAPPASQ> input kappa vector:' 95 WRITE (LUPRI,'(5X,I5,F12.8)') (I,KAPPA(I),I=1,2*NALLAI(ISYKAP)) 96 WRITE (LUPRI,*) 'CCKAPPASQ> resorted orbital '// 97 & 'relaxation matrix:' 98 CALL CC_PRONELAO(KAPPASQ,ISYKAP) 99 END IF 100 101 RETURN 102 END 103*======================================================================* 104