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 ccrhsn3 */
20      SUBROUTINE CCRHSN3(WORK,LWORK)
21!
22!     Written by Kasper Hald late march 1999
23!
24!     Based on CCRHSN
25!     Written by Henrik Koch 25-Sep-1993
26!
27!     Purpose:
28!
29!     Calculation of the triplet Coupled Cluster global int. using
30!     AO-integrals directly from disk. No intermediate files are
31!     used in this calculation. The intermediates are written to disk
32!     even if RSPIM is false.
33!
34!
35!     N.B. The routine is only tested for OMEGOR
36!
37!----------------------------------------------------------------------
38!
39      IMPLICIT NONE
40!
41#include "priunit.h"
42#include "dummy.h"
43#include "maxorb.h"
44#include "mxcent.h"
45#include "aovec.h"
46#include "iratdef.h"
47#include "ccorb.h"
48#include "ccisao.h"
49#include "blocks.h"
50#include "ccfield.h"
51#include "ccsdinp.h"
52#include "ccsdsym.h"
53#include "ccsdio.h"
54#include "distcl.h"
55#include "cbieri.h"
56#include "eritap.h"
57#include "second.h"
58#include "r12int.h"
59!
60      INTEGER LWORK, ISYMTR, LUCSIM, LUDTIM, IERRCS, IERRDT
61      INTEGER KOMG1, KOMG2, KLAMDP, KLAMIP, KLAMDH, KDENSI
62      INTEGER KFOCK, KEMAT1, KEMAT2, KEND1, LWRK1, JSYM, ISYMH, IC
63      INTEGER IF, KENDS2, LWRKS2, NTOSYM, KCCFB1, KINDXB, KT2AMT
64      INTEGER KODCL1, KODCL2, KODBC1, KODBC2, KRDBC1, KRDBC2
65      INTEGER KODPP1, KODPP2, KRDPP1, KRDPP2, KFREE, LFREE, KENDSV
66      INTEGER LWRKSV, ICDEL1, ISYMD1, NTOT, ILLL, NUMDIS, KRECNR
67      INTEGER IDEL, IDEL2, ISYMD, ISYDIS, KXINT, KEND2, LWRK2
68      INTEGER ISYDEN, ICON, ISYMLH, IOPT, ISYM0
69      INTEGER KDSRHF, KEND4, LWRK4, ISYMLP, IV, ISYM, LUBF
70      INTEGER KGAMMA, ISYMBF, LUGAM, LUFCK, ISYMEI, LUE1, LUE2
71      INTEGER KOFF, KT1AM, KT2AM
72!
73      INTEGER INDEXA(MXCORB_CC)
74!
75      INTEGER IDUM
76!
77#if defined (SYS_CRAY)
78      REAL WORK(LWORK)
79      REAL DTIME, DDOT, FACTC, FACTD, FAKE, FF, HALF, ONE
80      REAL PHONEY, RHO1N, RHO2N, FACTE1, FACTE2
81      REAL TIMALL, TIMBF, TIMC, TIMDM
82      REAL TIMEI, TIMF, TIMFCK, TIMGAM, TIMHER1
83      REAL TIMHER2, TIMLAM, TIMRDAO, TIMT2AO, TIMT2BT, TIMT2TR, TIMTRBT
84      REAL TWO, XMHALF, XMONE, ZERO, XNORM
85#else
86      DOUBLE PRECISION WORK(LWORK)
87      DOUBLE PRECISION DTIME, DDOT, FACTC, FACTD
88      DOUBLE PRECISION FAKE, FF, HALF, ONE, PHONEY
89      DOUBLE PRECISION RHO1N, RHO2N, FACTE1, FACTE2
90      DOUBLE PRECISION TIMALL, TIMBF, TIMC, TIMDM
91      DOUBLE PRECISION TIMEI, TIMFCK
92      DOUBLE PRECISION TIMGAM, TIMHER1, TIMHER2, TIMLAM
93      DOUBLE PRECISION TIMRDAO, TIMT2AO, TIMT2BT, TIMT2TR, TIMTRBT
94      DOUBLE PRECISION TWO, XMHALF, XMONE, ZERO, XNORM
95#endif
96!
97      PARAMETER (ZERO= 0.0D00, HALF= 0.5D00, ONE= 1.0D00, TWO= 2.0D00)
98      PARAMETER (XMHALF = -0.5D00, XMONE= -1.0D00 )
99!
100      LOGICAL FCKCON, ETRAN, ANTISYM
101!
102      CHARACTER  CSFIL*6, DTFIL*7
103      CHARACTER*10 MODEL
104!
105!-----------------------------------------------------------
106!     For energy calculation trial vector is totalsymmetric.
107!-----------------------------------------------------------
108!
109      ISYMTR = 1
110!
111!----------------
112!     Open files.
113!----------------
114!
115      LUDTIM  = -1
116      LUCSIM  = -1
117      CSFIL   = 'PMAT_C'
118      DTFIL   = 'PMAT_DT'
119!
120      IF (DUMPCD) THEN
121         CALL WOPEN2(LUDTIM,DTFIL,64,0)
122         CALL WOPEN2(LUCSIM,CSFIL,64,0)
123!
124      END IF
125!
126!----------------------------------
127!     Initialize timing parameters.
128!----------------------------------
129!
130      TIMALL  = SECOND()
131      TIMBF   = 0.0D00
132      TIMDM   = 0.0D00
133      TIMEI   = 0.0D00
134      TIMFCK  = 0.0D00
135      TIMHER1 = 0.0D00
136      TIMHER2 = 0.0D00
137      TIMLAM  = 0.0D00
138      TIMRDAO = 0.0D00
139      TIMT2AO = 0.0D00
140      TIMT2BT = 0.0D00
141      TIMT2TR = 0.0D00
142      TIMTRBT = 0.0D00
143!
144!---------------------------
145!     Check inconsistencies.
146!---------------------------
147!
148      IF (NEWGAM) THEN
149         IF ((.NOT. DUMPCD) .OR. (.NOT. OMEGOR)) THEN
150            WRITE(LUPRI,*) 'NEWGAM requires both DUMPCD and OMEGOR'
151            CALL QUIT('ERROR: NEWGAM inconsistency')
152         END IF
153      END IF
154!
155!---------------------------------
156!     Work space allocation no. 1.
157!---------------------------------
158!
159      KT1AM  = 1
160      KT2AM  = KT1AM  + NT1AMX
161      KLAMDP = KT2AM  + NT2SQ(1)
162      KLAMDH = KLAMDP + NLAMDT
163      KEND1  = KLAMDH + NLAMDT
164      LWRK1  = LWORK  - KEND1
165!
166      IF (LWRK1 .LT. NT2AMX) THEN
167         WRITE(LUPRI,*) 'Need : ',KEND1+NT2AMX,'Available : ',LWORK
168         CALL QUIT('Insufficient space in CCRHSN3')
169      ENDIF
170!
171!-------------------------------
172!     Prepare the t2-amplitudes.
173!-------------------------------
174!
175      IOPT = 3
176      CALL CC_RDRSP('R0',0,1,IOPT,MODEL,WORK(KT1AM),WORK(KEND1))
177!
178      CALL CC_T2SQ(WORK(KEND1),WORK(KT2AM),ISYMTR)
179!
180!----------------------------------
181!     Calculate the lamda matrices.
182!----------------------------------
183!
184      TIMLAM  = SECOND()
185      CALL LAMMAT(WORK(KLAMDP),WORK(KLAMDH),WORK(KT1AM),
186     &            WORK(KEND1),LWRK1)
187      TIMLAM  = SECOND() - TIMLAM
188!
189!====================================================
190!     Start the loop over distributions of integrals.
191!====================================================
192!
193      KENDS2 = KEND1
194      LWRKS2 = LWRK1
195!
196      IF (DIRECT) THEN
197         DTIME  = SECOND()
198
199         IF (HERDIR) THEN
200           CALL HERDI1(WORK(KEND1),LWRK1,IPRERI)
201         ELSE
202           KCCFB1 = KEND1
203           KINDXB = KCCFB1 + MXPRIM*MXCONT
204           KEND1  = KINDXB + (8*MXSHEL*MXCONT + 1)/IRAT
205           LWRK1  = LWORK  - KEND1
206           CALL ERIDI1(KODCL1,KODCL2,KODBC1,KODBC2,KRDBC1,KRDBC2,
207     &                 KODPP1,KODPP2,KRDPP1,KRDPP2,
208     &                 KFREE,LFREE,KEND1,WORK(KCCFB1),WORK(KINDXB),
209     &                 WORK(KEND1),LWRK1,IPRERI)
210           KEND1 = KFREE
211           LWRK1 = LFREE
212         END IF
213
214         DTIME  = SECOND() - DTIME
215         TIMHER1 = TIMHER1 + DTIME
216         NTOSYM = 1
217      ELSE
218         NTOSYM = NSYM
219      ENDIF
220!
221      KENDSV = KEND1
222      LWRKSV = LWRK1
223!
224      ICDEL1 = 0
225      DO 100 ISYMD1 = 1,NTOSYM
226!
227         IF (DIRECT) THEN
228            IF (HERDIR) THEN
229               NTOT = MAXSHL
230            ELSE
231               NTOT = MXCALL
232            END IF
233         ELSE
234            NTOT = NBAS(ISYMD1)
235         ENDIF
236!
237         DO 110 ILLL = 1,NTOT
238!
239!-----------------------------------------------------------------
240!           If direct calculate the integrals and transposed t2am.
241!-----------------------------------------------------------------
242!
243            IF (DIRECT) THEN
244!
245               KEND1 = KENDSV
246               LWRK1 = LWRKSV
247!
248               DTIME  = SECOND()
249               IF (HERDIR) THEN
250                 CALL HERDI2(WORK(KEND1),LWRK1,INDEXA,ILLL,NUMDIS,
251     &                       IPRERI)
252               ELSE
253                 CALL ERIDI2(ILLL,INDEXA,NUMDIS,0,0,
254     &                       WORK(KODCL1),WORK(KODCL2),
255     &                       WORK(KODBC1),WORK(KODBC2),
256     &                       WORK(KRDBC1),WORK(KRDBC2),
257     &                       WORK(KODPP1),WORK(KODPP2),
258     &                       WORK(KRDPP1),WORK(KRDPP2),
259     &                       WORK(KCCFB1),WORK(KINDXB),
260     &                       WORK(KEND1), LWRK1,IPRERI)
261               END IF
262               DTIME   = SECOND() - DTIME
263               TIMHER2 = TIMHER2 + DTIME
264!
265               KRECNR = KEND1
266               KEND1  = KRECNR + (NBUFX(0) - 1)/IRAT + 1
267               LWRK1  = LWORK  - KEND1
268               IF (LWRK1 .LT. 0) THEN
269                  CALL QUIT('Insufficient core in CCRHSN3')
270               END IF
271!
272            ELSE
273               NUMDIS = 1
274            ENDIF
275!
276!-----------------------------------------------------
277!           Loop over number of distributions in disk.
278!-----------------------------------------------------
279!
280            DO 120 IDEL2 = 1,NUMDIS
281!
282               IF (DIRECT) THEN
283                  IDEL  = INDEXA(IDEL2)
284                  IF (NOAUXB) THEN
285                     IDUM = 1
286                     CALL IJKAUX(IDEL,IDUM,IDUM,IDUM)
287                  END IF
288                  ISYMD = ISAO(IDEL)
289               ELSE
290                  IDEL  = IBAS(ISYMD1) + ILLL
291                  ISYMD = ISYMD1
292               ENDIF
293!
294               ISYDIS = MULD2H(ISYMD,ISYMOP)
295!
296!------------------------------------------
297!              Adresses for C/D
298!------------------------------------------
299!
300               IT2DEL(IDEL) = ICDEL1
301               ICDEL1 = ICDEL1 + NT2BCD(ISYDIS)
302!
303!------------------------------------------
304!              Work space allocation no. 2.
305!------------------------------------------
306!
307               KXINT  = KEND1
308               KEND2  = KXINT + NDISAO(ISYDIS)
309               LWRK2  = LWORK - KEND2
310!
311               IF (LWRK2 .LT. 0) THEN
312                  WRITE(LUPRI,*) 'Need : ',KEND2,'Available : ',LWORK
313                  CALL QUIT('Insufficient space in CCRHSN3')
314               ENDIF
315!
316!
317!-----------------------------------------
318!              Read in batch of integrals.
319!-----------------------------------------
320!
321               DTIME   = SECOND()
322               CALL CCRDAO(WORK(KXINT),IDEL,IDEL2,WORK(KEND2),LWRK2,
323     *                     WORK(KRECNR),DIRECT)
324!
325               DTIME   = SECOND() - DTIME
326               TIMRDAO = TIMRDAO  + DTIME
327!
328!------------------------------------------
329!              Work space allocation no. 4.
330!------------------------------------------
331!
332               KDSRHF = KEND2
333               KEND4  = KDSRHF + NDSRHF(ISYMD)
334               LWRK4  = LWORK  - KEND4
335!
336               IF (LWRK4 .LT. 0) THEN
337                  WRITE(LUPRI,*) 'Need : ',KEND4,'Available : ',LWORK
338                  CALL QUIT('Insufficient space in CCRHSN')
339               ENDIF
340!
341!--------------------------------------------------------
342!              Transform one index in the integral batch.
343!--------------------------------------------------------
344!
345               DTIME   = SECOND()
346               ISYMLP  = 1
347               CALL CCTRBT(WORK(KXINT),WORK(KDSRHF),WORK(KLAMDP),
348     *                     ISYMLP,WORK(KEND4),LWRK4,ISYDIS)
349               DTIME   = SECOND() - DTIME
350               TIMTRBT = TIMTRBT + DTIME
351!
352!-----------------------------------------------------
353!              Calculate (3)D
354!-----------------------------------------------------
355!
356               IF (.NOT. CC2) THEN
357!
358               DTIME   = SECOND()
359!
360               FACTD = ONE
361               ICON   = 5
362               IV = 1
363!
364                  CALL CCRHS_D3(WORK(KXINT),WORK(KDSRHF),DUMMY,
365     *                          WORK(KT2AM),ISYMTR,WORK(KLAMDP),DUMMY,
366     *                          WORK(KLAMDH),WORK(KLAMDP),ISYMTR,
367     *                          WORK(KLAMDH),ISYMTR,
368     *                          DUMMY,WORK(KEND4),LWRK4,IDEL,
369     *                          ISYMD,FACTD,ICON,LUDTIM,DTFIL,IV)
370!
371               DTIME   = SECOND() - DTIME
372               TIMDM   = TIMDM  + DTIME
373!
374               ENDIF
375!
376  120       CONTINUE
377  110    CONTINUE
378  100 CONTINUE
379!
380!--------------------
381!     Times
382!--------------------
383!
384      TIMALL  = SECOND() - TIMALL
385      IF ( IPRINT .GT. 2) THEN
386         WRITE(LUPRI,9999) 'RHSN3 - TOT.', TIMALL
387      ENDIF
388      IF (IPRINT .GT. 9) THEN
389         WRITE(LUPRI,9999) 'CCRHS_D3   ', TIMDM
390         WRITE(LUPRI,9999) 'HERDIS1    ', TIMHER1
391         WRITE(LUPRI,9999) 'HERDIS2    ', TIMHER2
392         WRITE(LUPRI,9999) 'CCRHS_LAM  ', TIMLAM
393         WRITE(LUPRI,9999) 'CCRHS_RDAO ', TIMRDAO
394      ENDIF
3959999  FORMAT(7x,'Time used in',2x,A12,2x,': ',f10.2,' seconds')
396!
397!-----------------
398!     Close files.
399!-----------------
400!
401         CALL WCLOSE2(LUDTIM,DTFIL,'KEEP')
402         CALL WCLOSE2(LUCSIM,CSFIL,'KEEP')
403!
404      RETURN
405      END
406