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