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_SETFB12 */
20*=====================================================================*
21       SUBROUTINE CC_SETFB12(IFTRAN,IFDOTS,MXTRAN,MXVEC,
22     &                       IZETAV,IOPER,IKAPPA,ITAMPA,ITAMPB,
23     &                       ITRAN,IVEC)
24*---------------------------------------------------------------------*
25*
26*    Purpose: maintains a list of dot products of F{O} matrix
27*             transformations with right amplitude vectors:
28*                        (Z*F{O}*T^A) * T^B
29*             assumes that T^A and T^B belong to different lists
30*
31*             IFTRAN - list of F matrix transformations
32*             IFDOTS - list of vectors it should be dottet on
33*
34*             MXTRAN - maximum list dimension
35*             MXVEC  - maximum second dimension for IFDOTS
36*
37*             IZETAV - index of lagrangian multiplier vector
38*             IOPER  - index of property operator
39*             IKAPPA - index of the relaxation vector
40*             ITAMPA - index of amplitude vector A
41*             ITAMPB - index of amplitude vector B
42*
43*             ITRAN - index in IFTRAN list
44*             IVEC  - second index in IFDOTS list
45*
46*    Written by Sonia Coriani, Maj 2000. Based on CC_SETFA and CC_SETFA12
47*
48*=====================================================================*
49      IMPLICIT NONE
50#include "priunit.h"
51
52      INTEGER MXVEC, MXTRAN
53      INTEGER IFTRAN(5,MXTRAN)
54      INTEGER IFDOTS(MXVEC,MXTRAN)
55
56      LOGICAL LFNDB
57      INTEGER IZETAV, IOPER, IKAPPA, ITAMPA, ITAMPB
58      INTEGER ITRAN, IVEC
59      INTEGER ITAMP, I, IDX
60
61* statement  functions:
62      LOGICAL LFATST, LFAEND
63      INTEGER IL, IA, IO, IK
64      LFATST(ITRAN,IL,IO,IK,IA) = IFTRAN(1,ITRAN).EQ.IL
65     &       .AND. IFTRAN(2,ITRAN).EQ.IO .AND. IFTRAN(3,ITRAN).EQ.IA
66     &       .AND. IFTRAN(5,ITRAN).EQ.IK
67      LFAEND(ITRAN) = ITRAN.GT.MXTRAN .OR.
68     &      (IFTRAN(1,ITRAN)+IFTRAN(2,ITRAN)+IFTRAN(3,ITRAN)).LE.0
69
70
71*---------------------------------------------------------------------*
72* set up list of F{B} matrix transformations
73*---------------------------------------------------------------------*
74      ITRAN = 1
75      LFNDB  = LFATST(ITRAN,IZETAV,IOPER,IKAPPA,ITAMPA)
76
77      DO WHILE ( .NOT. (LFNDB.OR.LFAEND(ITRAN)))
78       ITRAN = ITRAN + 1
79       LFNDB  = LFATST(ITRAN,IZETAV,IOPER,IKAPPA,ITAMPA)
80      END DO
81
82      IF (.NOT.LFNDB) THEN
83        IFTRAN(1,ITRAN) = IZETAV
84        IFTRAN(2,ITRAN) = IOPER
85        IFTRAN(3,ITRAN) = ITAMPA
86        IFTRAN(4,ITRAN) = 0
87        IFTRAN(5,ITRAN) = IKAPPA
88        ITAMP = ITAMPB
89      ELSE
90        IF (LFNDB) ITAMP = ITAMPB
91      END IF
92
93      IVEC = 1
94      DO WHILE (IFDOTS(IVEC,ITRAN).NE.ITAMP .AND.
95     &            IFDOTS(IVEC,ITRAN).NE.0 .AND. IVEC.LE.MXVEC)
96        IVEC = IVEC + 1
97      END DO
98
99      IFDOTS(IVEC,ITRAN) = ITAMP
100
101C     WRITE (LUPRI,*) 'CC_SETFB12>',IZETAV,IOPER,ITAMPA,ITAMPB,ITRAN,IVEC
102*---------------------------------------------------------------------*
103      IF (IVEC.GT.MXVEC .OR. ITRAN.GT.MXTRAN) THEN
104        WRITE (LUPRI,*) 'IVEC :',IVEC
105        WRITE (LUPRI,*) 'ITRAN:',ITRAN
106        WRITE (LUPRI,*) 'IOPER,IKAPPA :',IOPER,IKAPPA
107        WRITE (LUPRI,*) 'ITAMPA,ITAMPB:',ITAMPA,ITAMPB
108        IDX = 1
109        DO WHILE ( .NOT. LFAEND(IDX) )
110          WRITE(LUPRI,'(A,5I5,5X,(12I5,20X))') 'CC_SETFA12>',
111     &       (IFTRAN(I,IDX),I=1,5),(IFDOTS(I,IDX),I=1,MXVEC)
112          IDX = IDX + 1
113        END DO
114        CALL FLSHFO(LUPRI)
115        CALL QUIT('Overflow error in CC_SETFA12.')
116      END IF
117
118      RETURN
119      END
120
121*---------------------------------------------------------------------*
122*              END OF SUBROUTINE CC_SETFB12                           *
123*---------------------------------------------------------------------*
124