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_setfa */
20*=====================================================================*
21      SUBROUTINE CC_SETFA(IFTRAN,IFDOTS,MXTRAN,MXVEC,IZETAV,
22     &                    IOPER,IKAPPA,ITAMPA,ITAMPB,ITRAN,IVEC)
23*---------------------------------------------------------------------*
24*
25*    Purpose: set up list of F matrix transformations
26*
27*             IFTRAN - list of F matrix transformations
28*             IFDOTS - list of vectors it should be dottet on
29*
30*             MXTRAN - maximum list dimension
31*             MXVEC  - maximum second dimension for IFDOTS
32*
33*             IZETAV - index of lagrangian multiplier vector
34*             IOPER  - index of property operator
35*             IKAPPA - index of the relaxation vector
36*             ITAMPA - index of amplitude vector A
37*             ITAMPB - index of amplitude vector B
38*
39*             ITRAN - index in IFTRAN list
40*             IVEC  - second index in IFDOTS list
41*
42*    Written by Christof Haettig, november 1996.
43*    IKAPPA entry added in june 1999
44*
45*=====================================================================*
46      IMPLICIT NONE
47#include "priunit.h"
48
49      INTEGER MXVEC, MXTRAN
50      INTEGER IFTRAN(5,MXTRAN)
51      INTEGER IFDOTS(MXVEC,MXTRAN)
52
53      LOGICAL LFNDA, LFNDB
54      INTEGER IZETAV, IOPER, IKAPPA, ITAMPA, ITAMPB
55      INTEGER ITRAN, IVEC
56      INTEGER ITAMP, I, IDX
57
58* statement  functions:
59      LOGICAL LFATST, LFAEND
60      INTEGER IL, IA, IO, IK
61      LFATST(ITRAN,IL,IO,IK,IA) =
62     &        IFTRAN(1,ITRAN).EQ.IL .AND. IFTRAN(2,ITRAN).EQ.IO
63     &  .AND. IFTRAN(3,ITRAN).EQ.IA .AND. IFTRAN(5,ITRAN).EQ.IK
64      LFAEND(ITRAN) = ITRAN.GT.MXTRAN .OR.
65     &      (IFTRAN(1,ITRAN)+IFTRAN(2,ITRAN)+IFTRAN(3,ITRAN)).LE.0
66
67
68*---------------------------------------------------------------------*
69* set up list of F{A} matrix transformations
70*---------------------------------------------------------------------*
71      ITRAN = 1
72      LFNDA  = LFATST(ITRAN,IZETAV,IOPER,IKAPPA,ITAMPB)
73      LFNDB  = LFATST(ITRAN,IZETAV,IOPER,IKAPPA,ITAMPA)
74
75      DO WHILE ( .NOT. (LFNDA.OR.LFNDB.OR.LFAEND(ITRAN)))
76       ITRAN = ITRAN + 1
77       LFNDA  = LFATST(ITRAN,IZETAV,IOPER,IKAPPA,ITAMPB)
78       LFNDB  = LFATST(ITRAN,IZETAV,IOPER,IKAPPA,ITAMPA)
79      END DO
80
81      IF (.NOT.(LFNDA.OR.LFNDB)) THEN
82        IFTRAN(1,ITRAN) = IZETAV
83        IFTRAN(2,ITRAN) = IOPER
84        IFTRAN(3,ITRAN) = ITAMPA
85        IFTRAN(4,ITRAN) = 0
86        IFTRAN(5,ITRAN) = IKAPPA
87        ITAMP = ITAMPB
88      ELSE
89        IF (LFNDA) ITAMP = ITAMPA
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
101*---------------------------------------------------------------------*
102      IF (IVEC.GT.MXVEC .OR. ITRAN.GT.MXTRAN) THEN
103        WRITE (LUPRI,*) 'Overflow error in CC_SETFA:'
104        WRITE (LUPRI,*) 'IVEC, MXVEC  :',IVEC, MXVEC
105        WRITE (LUPRI,*) 'ITRAN, MXTRAN:',ITRAN, MXTRAN
106        WRITE (LUPRI,*) 'IOPER,IKAPPA :',IOPER,IKAPPA
107        WRITE (LUPRI,*) 'IZETAV,ITAMPA,ITAMPB:',IZETAV,ITAMPA,ITAMPB
108        IDX = 1
109        DO WHILE ( .NOT. LFAEND(IDX) )
110          WRITE(LUPRI,'(A,5I5,5X,(12I5,20X))') 'CC_SETFA>',
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_SETFA')
116      END IF
117
118      RETURN
119      END
120
121*---------------------------------------------------------------------*
122*                END OF SUBROUTINE CC_SETFA                           *
123*---------------------------------------------------------------------*
124