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      SUBROUTINE TP1IND
20C
21C CALCULATE A POINTER TO THE NUMBER OF DIFFERENT ONE-INDEX
22C LINEAR RESPONSE EQUATIONS THAT ARE USED IN A
23C A CALCULATION OF TWO-PHOTON EXCITATION
24C
25#include "implicit.h"
26C
27#include "rspprp.h"
28#include "infsmo.h"
29#include "indcr.h"
30#include "inforb.h"
31#include "infrsp.h"
32#include "infpri.h"
33#include "infspi.h"
34#include "inftpa.h"
35#include "infcr.h"
36C
37C If excited state alpha (TPALP) is specified we only compute certain
38C components.
39C
40      IF (TPALP) THEN
41C
42      DO 600 ICSYM = 1,NSYM
43      DO 620 IBSYM = 1,NSYM
44         IDSYM = ICSYM
45         IASYM = IBSYM
46         IF ( (NTPCN2(IDSYM).GT.0) .AND. (NTPCN1(ICSYM).GT.0) .AND.
47     *    (NBTPOP(IBSYM).GT.0) .AND. (NATPOP(IASYM).GT.0) ) THEN
48            DO ICFR = 1,NTPCN1(ICSYM)
49               INUM = INCRLR('EXCITLAB',EXCIT2(ICSYM,ICFR),ICSYM)
50            ENDDO
51            DO IBOP = 1,NBTPOP(IBSYM)
52            DO IBFR = 1,NBTPFR
53               INUM = INCRLR(BTPLB(IBSYM,IBOP),-BTPFR(IBFR),IBSYM)
54            ENDDO
55            ENDDO
56            DO ICFR = 1,NTPCN1(ICSYM)
57            DO IBFR = 1,NBTPFR
58               IDFR = ICFR
59               ATPFR = EXCIT2(IDSYM,IDFR)-EXCIT2(ICSYM,ICFR)-BTPFR(IBFR)
60               DO IAOP = 1,NATPOP(IASYM)
61                  INUM = INCRLR(ATPLB(IASYM,IAOP),ATPFR,IASYM)
62               ENDDO
63            ENDDO
64            ENDDO
65         END IF
66 620  CONTINUE
67 600  CONTINUE
68C
69      ELSE
70C
71      DO 200 IDSYM = 1,NSYM
72      DO 300 ICSYM = 1,NSYM
73      DO 400 IBSYM = 1,NSYM
74         IASYM = MULD2H(IDSYM,MULD2H(ICSYM,IBSYM))
75         IF ( (NTPCN2(IDSYM).GT.0) .AND. (NTPCN1(ICSYM).GT.0) .AND.
76     *       (NBTPOP(IBSYM).GT.0) .AND. (NATPOP(IASYM).GT.0) ) THEN
77            DO 450 IDFR = 1,NTPCN2(IDSYM)
78               INUM = INCRLR('EXCITLAB',EXCIT2(IDSYM,IDFR),IDSYM)
79 450        CONTINUE
80            DO 460 ICFR = 1,NTPCN1(ICSYM)
81               INUM = INCRLR('EXCITLAB',EXCIT2(ICSYM,ICFR),ICSYM)
82 460        CONTINUE
83            DO 700 IBOP = 1,NBTPOP(IBSYM)
84            DO 800 IBFR = 1,NBTPFR
85               INUM = INCRLR(BTPLB(IBSYM,IBOP),-BTPFR(IBFR),IBSYM)
86 800        CONTINUE
87 700        CONTINUE
88            DO 900  IDFR = 1,NTPCN2(IDSYM)
89            DO 1000 ICFR = 1,NTPCN1(ICSYM)
90            DO 1100 IBFR = 1,NBTPFR
91               ATPFR = EXCIT2(IDSYM,IDFR)-EXCIT2(ICSYM,ICFR)-BTPFR(IBFR)
92               DO 1200 IAOP = 1,NATPOP(IASYM)
93                  INUM = INCRLR(ATPLB(IASYM,IAOP),ATPFR,IASYM)
94 1200          CONTINUE
95 1100       CONTINUE
96 1000       CONTINUE
97 900        CONTINUE
98         END IF
99 400  CONTINUE
100 300  CONTINUE
101 200  CONTINUE
102C
103      END IF
104C
105      RETURN
106      END
107      SUBROUTINE TP2IND
108C
109C CALCULATE A POINTER TO THE NUMBER OF DIFFERENT
110C TWO-INDEX LINEAR RESPONSE EQUATIONS THAT NEED TO BE SOLVED
111C IN A CUBIC RESPONSE TWO-PHOTON CALCULATION
112C
113#include "implicit.h"
114C
115#include "rspprp.h"
116#include "infcr.h"
117#include "inforb.h"
118#include "infrsp.h"
119#include "infpri.h"
120#include "infspi.h"
121#include "inftpa.h"
122#include "indcr.h"
123C
124      CHARACTER*8 CTPLB, DTPLB
125C
126C Put label EXCITLAB in list for two-index vectors
127C for vectors of the type N^XX, N^BX and N^CX
128C
129      DATA CTPLB/'EXCITLAB'/
130      DATA DTPLB/'EXCITLAB'/
131C
132C If excited state alpha (TPALP) is specified we only compute certain
133C components.
134C
135      IF (TPALP) THEN
136C
137      DO 600 ICSYM = 1,NSYM
138      DO 620 IBSYM = 1,NSYM
139         IDSYM = ICSYM
140         IASYM = IBSYM
141         IF ( (NTPCN2(IDSYM).GT.0) .AND. (NTPCN1(ICSYM).GT.0) .AND.
142     *    (NBTPOP(IBSYM).GT.0) .AND. (NATPOP(IASYM).GT.0) ) THEN
143            DO IBOP = 1,NBTPOP(IBSYM)
144               DO ICFR = 1,NTPCN1(ICSYM)
145               DO IBFR = 1,NBTPFR
146                  IDFR = ICFR
147                  CTPFR = -EXCIT2(ICSYM,ICFR)
148                  DTPFR = EXCIT2(IDSYM,IDFR)
149                  INUM = INCR2(BTPLB(IBSYM,IBOP),CTPLB,
150     *                          -BTPFR(IBFR),CTPFR,IBSYM,ICSYM)
151                  INUM = INCR2(BTPLB(IBSYM,IBOP),DTPLB,
152     *                          -BTPFR(IBFR),DTPFR,IBSYM,IDSYM)
153                  INUM = INCR2(CTPLB,DTPLB,
154     *                          CTPFR,DTPFR,ICSYM,IDSYM)
155               ENDDO
156               ENDDO
157            ENDDO
158         END IF
159620   CONTINUE
160600   CONTINUE
161C
162      ELSE
163C
164      DO 300 IDSYM = 1,NSYM
165      DO 200 ICSYM = 1,NSYM
166      DO 100 IBSYM = 1,NSYM
167         IASYM = MULD2H(IDSYM,MULD2H(ICSYM,IBSYM))
168         IF ( (NTPCN2(IDSYM).GT.0) .AND. (NTPCN1(ICSYM).GT.0)
169     *     .AND. (NBTPOP(IBSYM).GT.0) .AND. (NATPOP(IASYM).GT.0)) THEN
170            DO 110 IBOP = 1,NBTPOP(IBSYM)
171               DO 320 IDFR = 1,NTPCN2(IDSYM)
172               DO 220 ICFR = 1,NTPCN1(ICSYM)
173               DO 120 IBFR = 1,NBTPFR
174                  CTPFR = -EXCIT2(ICSYM,ICFR)
175                  DTPFR = EXCIT2(IDSYM,IDFR)
176                  INUM = INCR2(BTPLB(IBSYM,IBOP),CTPLB,
177     *                          -BTPFR(IBFR),CTPFR,IBSYM,ICSYM)
178                  INUM = INCR2(BTPLB(IBSYM,IBOP),DTPLB,
179     *                          -BTPFR(IBFR),DTPFR,IBSYM,IDSYM)
180                  INUM = INCR2(CTPLB,DTPLB,
181     *                          CTPFR,DTPFR,ICSYM,IDSYM)
182120            CONTINUE
183220            CONTINUE
184320            CONTINUE
185110         CONTINUE
186         END IF
187100   CONTINUE
188200   CONTINUE
189300   CONTINUE
190C
191      END IF
192C
193      RETURN
194      END
195
196