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