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*---------------------------------------------------------------------*
20c/* Deck CC_BATST */
21*=====================================================================*
22       SUBROUTINE CC_BATST(WORK,LWORK)
23#if defined (IMPLICIT_NONE)
24      IMPLICIT NONE
25#else
26#  include "implicit.h"
27#endif
28#include "priunit.h"
29#include "ccsdinp.h"
30#include "ccsdsym.h"
31#include "ccorb.h"
32
33* local parameters:
34      CHARACTER MSGDBG*(18)
35      PARAMETER (MSGDBG='[debug] CC_BATST> ')
36
37      LOGICAL LOCDBG
38      PARAMETER (LOCDBG = .FALSE.)
39      LOGICAL NEW_CODE
40      PARAMETER (NEW_CODE = .TRUE.)
41      INTEGER MXCTRAN
42      PARAMETER (MXCTRAN = 2)
43
44      INTEGER LWORK
45#if defined (SYS_CRAY)
46      REAL WORK(LWORK)
47      REAL DDOT, RDUM
48#else
49      DOUBLE PRECISION WORK(LWORK)
50      DOUBLE PRECISION DDOT, RDUM
51#endif
52
53      LOGICAL LORXA, LORXB, LORXC
54      CHARACTER*(3) LISTA, LISTB, LISTC
55      CHARACTER*(8) FILCMA, LABELA, LABELB, LABELC
56      CHARACTER*(10) MODEL
57      INTEGER IOPTRES, IDUM
58      INTEGER ICTRAN(4,MXCTRAN), NCTRAN
59      INTEGER IDLSTA, IDLSTB, IDLSTC, ISYMA, ISYMB, ISYMC, ISYMABC
60      INTEGER KTHETA1, KTHETA2, KT1AMPC, KT2AMPC, KRESLT1, KRESLT2
61      INTEGER KEND1, LEND1, IOPT, IRELAXA
62
63* external function:
64      INTEGER IROPER
65      INTEGER IR1TAMP
66C     INTEGER IL1ZETA
67      INTEGER ILSTSYM
68
69
70
71*---------------------------------------------------------------------*
72* call B{O} matrix transformation:
73*---------------------------------------------------------------------*
74      LISTA   = 'o1'
75      LISTB   = 'R1'
76      LISTC   = 'R1'
77      LABELA  = 'ZDIPLEN '
78      LABELB  = 'ZDIPLEN '
79      LABELC  = 'ZDIPLEN '
80      LORXA   = .FALSE.
81      LORXB   = .FALSE.
82      LORXC   = .FALSE.
83      IDLSTA  = IROPER(LABELA,ISYMA)
84      IDLSTB  = IR1TAMP(LABELB,LORXB,0.0D0,ISYMB)
85      IDLSTC  = IR1TAMP(LABELC,LORXC,0.0D0,ISYMC)
86      IRELAXA = 0
87      IF (LORXA) IRELAXA = IR1TAMP(LABELA,LORXA,0.0D0,ISYMA)
88
89      ICTRAN(1,1) = IDLSTA
90      ICTRAN(2,1) = IDLSTB
91      ICTRAN(3,1) = IDLSTC
92      NCTRAN = 1
93
94      IOPTRES = 1
95      FILCMA  = 'CCCMAT'
96
97      CALL CC_BAMAT(ICTRAN,  NCTRAN,  LISTA,  LISTB, LISTC,
98     &              IOPTRES, FILCMA, IDUM, RDUM, 0, WORK, LWORK )
99
100
101      ISYMA  = ILSTSYM(LISTA,IDLSTA)
102      ISYMB  = ILSTSYM(LISTB,IDLSTB)
103      ISYMC  = ILSTSYM(LISTC,IDLSTC)
104      ISYMABC = MULD2H(MULD2H(ISYMA,ISYMB),ISYMC)
105
106      KTHETA1 = ICTRAN(4,1)
107      KTHETA2 = KTHETA1 + NT1AM(ISYMABC)
108
109      IF (NSYM.EQ.1 .AND. LOCDBG) THEN
110        KT1AMPC = KTHETA2 + NT2AM(ISYMABC)
111        KT2AMPC = KT1AMPC + NT1AM(ISYMC)
112        KRESLT1 = KT2AMPC + NT2AM(ISYMC)
113        KRESLT2 = KRESLT1 + NT1AM(ISYMABC)
114        KEND1   = KRESLT2 + NT2AM(ISYMABC)
115        LEND1   = LWORK - KEND1
116
117        IF (LEND1 .LT. 0) THEN
118          CALL QUIT('Insufficient work space in CC_BATST.')
119        END IF
120
121        IOPT = 3
122        Call CC_RDRSP(LISTC,IDLSTC,ISYMC,IOPT,MODEL,
123     &                WORK(KT1AMPC),WORK(KT2AMPC))
124
125        WRITE (LUPRI,*) 'CC_BATST: C vector:'
126        Call CC_PRP(WORK(KT1AMPC),WORK(KT2AMPC),ISYMC,1,1)
127
128        ! zero singles or doubles C vector:
129C       CALL DZERO(WORK(KT1AMPC),NT1AM(ISYMC))
130C       CALL DZERO(WORK(KT2AMPC),NT2AM(ISYMC))
131        CALL DZERO(WORK(KRESLT1),NT1AM(ISYMABC)+NT2AM(ISYMABC))
132
133        IF (NEW_CODE) THEN
134           CALL CC_FDBAMAT(WORK(KRESLT1),WORK(KRESLT2),
135     >                     LISTB,IDLSTB,LISTC,IDLSTC,
136     >                     LABELA,IRELAXA,WORK(KEND1),LEND1)
137        ELSE
138           IPRINT  = 6
139           CALL CC_FDBA(NT1AM(ISYMABC),NT2AM(ISYMABC),
140     >                  LISTA,IDLSTA,LISTB,IDLSTB,
141     >                  WORK(KT1AMPC), WORK(KRESLT1),
142     >                  WORK(KEND1), LEND1)
143        ENDIF
144
145        IPRINT  = 0
146
147        IF (.TRUE.) THEN
148          WRITE (LUPRI,*)
149          WRITE (LUPRI,*)
150          WRITE (LUPRI,*) 'FINITE DIFFERENCE TEST FOR B{O} MATRIX:'
151          WRITE (LUPRI,*) '---------------------------------------'
152          WRITE (LUPRI,*)
153     &          'LISTA, IDLSTA, ISYMA:',LISTA(1:2),IDLSTA,ISYMA
154          WRITE (LUPRI,*)
155     &          'LISTB, IDLSTB, ISYMB:',LISTB(1:2),IDLSTB,ISYMB
156          WRITE (LUPRI,*)
157     &          'LISTC, IDLSTC, ISYMC:',LISTC(1:2),IDLSTC,ISYMC
158          WRITE (LUPRI,*) 'ISYMABC:',ISYMABC
159          WRITE (LUPRI,*)
160          WRITE (LUPRI,*) 'finite difference Theta vector:'
161          Call CC_PRP(WORK(KRESLT1),WORK(KRESLT2),ISYMABC,1,1)
162          WRITE (LUPRI,*) 'analytical Theta vector:'
163          Call CC_PRP(WORK(KTHETA1),WORK(KTHETA2),ISYMABC,1,1)
164        END IF
165
166        Call DAXPY(NT1AM(ISYMABC),-1.0d0,WORK(KTHETA1),1,
167     &                                  WORK(KRESLT1),1)
168        IF (.NOT.CCS) THEN
169          Call DAXPY(NT2AM(ISYMABC),-1.0d0,WORK(KTHETA2),1,
170     &                                    WORK(KRESLT2),1)
171        ELSE
172          Call DZERO(WORK(KRESLT2),NT2AM(ISYMABC))
173        END IF
174
175        WRITE (LUPRI,*)
176        WRITE (LUPRI,*) 'FINITE DIFFERENCE TEST FOR B{O} MATRIX:'
177        WRITE (LUPRI,*) '---------------------------------------'
178        WRITE (LUPRI,*) 'Norm of difference between analytical THETA '
179     >           // 'vector and the numerical result:'
180        WRITE (LUPRI,*) 'singles excitation part:',
181     >   DSQRT(DDOT(NT1AM(ISYMA),WORK(KRESLT1),1,WORK(KRESLT1),1))
182        WRITE (LUPRI,*) 'double excitation part: ',
183     >   DSQRT(DDOT(NT2AM(ISYMA),WORK(KRESLT2),1,WORK(KRESLT2),1))
184
185        WRITE (LUPRI,*) 'difference vector:'
186        Call CC_PRP(WORK(KRESLT1),WORK(KRESLT2),ISYMABC,1,1)
187
188        CALL FLSHFO(LUPRI)
189
190
191      ELSE IF (NSYM.NE.1 .AND. LOCDBG) THEN
192       WRITE (LUPRI,*) 'CC_BATST> can not calculate finite diff. '//
193     &                 'B{O} matrix'
194       WRITE (LUPRI,*) 'CC_BATST> with symmetry.'
195      END IF
196
197      RETURN
198      END
199*=====================================================================*
200