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_tmcal */
21*=====================================================================*
22       SUBROUTINE CC_TMCAL(WRK,LWRK)
23*---------------------------------------------------------------------*
24*
25*    Purpose: Third moment calculations
26*
27*    Written by: P.Joergensen and C.Haettig 1997
28*    Clean up and new output style: S. Coriani 2001
29*=====================================================================*
30#if defined (IMPLICIT_NONE)
31      IMPLICIT NONE
32#else
33# include "implicit.h"
34#endif
35#include "priunit.h"
36#include "ccorb.h"
37#include "ccsdsym.h"
38#include "ccsdinp.h"
39#include "cctm.h"
40#include "cctminf.h"
41#include "ccrspprp.h"
42#include "ccexci.h"
43#include "ccroper.h"
44
45* local parameters:
46      LOGICAL LOCDBG
47      PARAMETER (LOCDBG = .FALSE.)
48
49* variables:
50      CHARACTER*8 LABELA, LABELB, LABELC,LABELD, LABELE, LABELF
51      CHARACTER MODFIL*10, MODPRI*5
52      INTEGER ISYMB, ISYMC, ISYMA, ISYMD, ISYME, ISYMF, ISYMABC
53      INTEGER IFREQ, INUM, IOPER, IDX, IOFFST, LWRK, IOPTRD
54      INTEGER K1VEC1, K1VEC2, K2VEC1, K2VEC2, IM11
55      INTEGER IX3AC0F, IX3DF0F, IO3AC0F, IO3ACF0, IO3DF0F, IO3DFF0
56      INTEGER NCCVAR1, NCCVAR2
57
58#if defined (SYS_CRAY)
59      REAL HALF, FREQEX, FREQB, FREQC, EIGV, WRK(LWRK)
60      REAL SMLM, SMCLM, SMRM, SMCRM
61      REAL ABCLM,DEFLM,ABCRM,DEFRM
62      REAL X1, X2, Y1, Y2
63      REAL DDOT, ZERO
64#else
65      DOUBLE PRECISION HALF, FREQEX, FREQB, FREQC, EIGV, WRK(LWRK)
66      DOUBLE PRECISION SMLM, SMCLM, SMRM, SMCRM
67      DOUBLE PRECISION ABCLM,DEFLM,ABCRM,DEFRM,THREEPH
68      DOUBLE PRECISION X1, X2, Y1, Y2
69      DOUBLE PRECISION DDOT, ZERO
70#endif
71
72      PARAMETER ( HALF = 0.5D00, ZERO = 0.0D00 )
73
74* external functions:
75      INTEGER IRHSR3
76      INTEGER ILRMAMP
77      INTEGER ICHI3
78* data:
79      LOGICAL FIRSTCALL
80      SAVE    FIRSTCALL
81      DATA    FIRSTCALL /.TRUE./
82*---------------------------------------------------------------------*
83* print header for third order moments section
84*---------------------------------------------------------------------*
85      WRITE (LUPRI,'(7(/1X,2A),/)')
86     & '************************************',
87     &                               '*******************************',
88     & '*                                   ',
89     &                               '                              *',
90     & '*-------- OUTPUT FROM COUPLED CLUSTER C',
91     &                                  'UBIC RESPONSE -------------*',
92     & '*                                   ',
93     &                               '                              *',
94     & '*-------- CALCULATION OF THREE PHOTON TRANS',
95     &                                      'ITION STRENGTHS -------*',
96     & '*                                   ',
97     &                               '                              *',
98     & '************************************',
99     &                               '*******************************'
100
101*---------------------------------------------------------------------*
102* print debug info
103*---------------------------------------------------------------------*
104      IF (LOCDBG) THEN
105        WRITE (LUPRI,*) 'DEBUG_CC_TMIND> NTMOP = ',NTMOPER
106      END IF
107*---------------------------------------------------------------------*
108* set MODFIL, MODPRI, IOPTRD for calls to CC_RDRSP and print out
109*---------------------------------------------------------------------*
110      IF (CCS) THEN
111         MODFIL = 'CCS       '
112         MODPRI  = 'CCS  '
113         IOPTRD = 1
114      ELSE IF (CC2) THEN
115         MODFIL = 'CC2       '
116         MODPRI  = 'CC2  '
117         IOPTRD = 3
118      ELSE IF (CCSD) THEN
119         MODFIL = 'CCSD      '
120         MODPRI  = 'CCSD '
121         IOPTRD = 3
122      ELSE
123         CALL QUIT('Unknown coupled cluster model in CC_TMCAL')
124      END IF
125*---------------------------------------------------------------------*
126* find list entries for the required response vectors
127* and excitation vectors:
128*---------------------------------------------------------------------*
129
130      DO IOPER = 1, NTMOPER
131        LABELA = LBLOPR(IATMOP(IOPER))
132        LABELB = LBLOPR(IBTMOP(IOPER))
133        LABELC = LBLOPR(ICTMOP(IOPER))
134        LABELD = LBLOPR(IDTMOP(IOPER))
135        LABELE = LBLOPR(IETMOP(IOPER))
136        LABELF = LBLOPR(IFTMOP(IOPER))
137
138        ISYMA  = ISYOPR(IATMOP(IOPER))
139        ISYMB  = ISYOPR(IBTMOP(IOPER))
140        ISYMC  = ISYOPR(ICTMOP(IOPER))
141        ISYMD  = ISYOPR(IDTMOP(IOPER))
142        ISYME  = ISYOPR(IETMOP(IOPER))
143        ISYMF  = ISYOPR(IFTMOP(IOPER))
144
145        IF (LOCDBG) THEN
146           WRITE (LUPRI,*) 'LABELA:',LABELA, ' ISYMA:', ISYMA
147           WRITE (LUPRI,*) 'LABELB:',LABELB, ' ISYMB:', ISYMB
148           WRITE (LUPRI,*) 'LABELC:',LABELC, ' ISYMC:', ISYMC
149           WRITE (LUPRI,*) 'LABELD:',LABELD, ' ISYMD:', ISYMD
150           WRITE (LUPRI,*) 'LABELE:',LABELE, ' ISYME:', ISYME
151           WRITE (LUPRI,*) 'LABELF:',LABELF, ' ISYMF:', ISYMF
152           CALL FLSHFO(LUPRI)
153        END IF
154
155        ISYMABC = MULD2H(MULD2H(ISYMA,ISYMB),ISYMC)
156        IF (ISYMABC .EQ. MULD2H(ISYMD,MULD2H(ISYME,ISYMF))) THEN
157
158          NCCVAR1 = NT1AM(ISYMABC)
159          NCCVAR2 = NT2AM(ISYMABC)
160          K1VEC1   = 1
161          K1VEC2   = K1VEC1 + NCCVAR1
162          K2VEC1   = K1VEC2 + NCCVAR2
163          K2VEC2   = K2VEC1 + NCCVAR1
164
165          DO I = 1, NTMSELX(ISYMABC)
166C bug fix
167c             IFREQ  = ITMSELX( MULD2H(ISYMA,ISYMB) ) + I
168              IFREQ  = ITMSELX(ISYMABC) + I
169              FREQEX  = EXTMFR(IFREQ)
170              FREQB  = BTMFR(IFREQ)
171              FREQC  = CTMFR(IFREQ)
172              IF (LOCDBG) THEN
173                WRITE (LUPRI,*) 'CC_TMCAL> put on the list:',
174     &            LABELA,'(',FREQEX,'),  ', LABELB,'(',FREQB ,'),  ',
175     &            LABELC,'(',FREQC, '),  ', LABELD,'(',FREQEX,'),  ',
176     &            LABELE,'(',FREQB, '),  ', LABELF,'(',FREQC ,'),  '
177              END IF
178
179*    request third order chi vectors:
180
181           IX3AC0F = ICHI3(LABELA,-FREQEX+FREQB+FREQC,ISYMA,
182     &                  LABELB,-FREQB,ISYMB,LABELC,-FREQC,ISYMC)
183           IX3DF0F = ICHI3(LABELD,-FREQEX+FREQB+FREQC,ISYMD,
184     &                  LABELE,-FREQB,ISYME,LABELF,-FREQC,ISYMF)
185
186*    request third order rhs vectors
187
188           IO3AC0F = IRHSR3(LABELA,-FREQEX+FREQB+FREQC,ISYMA,
189     &                  LABELB,-FREQB,ISYMB,LABELC,-FREQC,ISYMC)
190           IO3ACF0 = IRHSR3(LABELA,+FREQEX-FREQB-FREQC,ISYMA,
191     &                  LABELB,+FREQB,ISYMB,LABELC,+FREQC,ISYMC)
192           IO3DF0F = IRHSR3(LABELD,-FREQEX+FREQB+FREQC,ISYMD,
193     &                  LABELE,-FREQB,ISYME,LABELF,-FREQC,ISYMF)
194           IO3DFF0 = IRHSR3(LABELD,+FREQEX-FREQB-FREQC,ISYMD,
195     &                  LABELE,+FREQB,ISYME,LABELF,+FREQC,ISYMF)
196
197*    request M vectors for different excitation energies
198
199             IOFFST = ISYOFE(ISYMABC) +  ITMSEL(IFREQ,2)
200             EIGV   = EIGVAL(IOFFST)
201             IM11   = ILRMAMP(IOFFST,EIGV,ISYMABC)
202*--------------------------------------------------------------*
203*            calculate left  moment M_of^ABC(-w1,-w2) contrib.
204*            previously called SMCLM
205*--------------------------------------------------------------*
206
207             CALL CC_RDRSP('X3',IX3AC0F,ISYMABC,IOPTRD,MODFIL,
208     *                     WRK(K1VEC1),WRK(K1VEC2))
209             X1 = DDOT(NCCVAR1,WRK(K1VEC1),1,WRK(K1VEC1),1)
210             IF (.NOT.CCS) THEN
211               X2 = DDOT(NCCVAR2,WRK(K1VEC2),1,WRK(K1VEC2),1)
212             ELSE
213               X2 = ZERO
214             END IF
215             IF (LOCDBG)
216     &          WRITE (LUPRI,*) ' norm^2 of X3 vector:',X1,X2
217
218             CALL CC_RDRSP('RE',IOFFST,ISYMABC,IOPTRD,MODFIL,
219     *                     WRK(K2VEC1),WRK(K2VEC2))
220             Y1 = DDOT(NCCVAR1,WRK(K2VEC1),1,WRK(K2VEC1),1)
221             IF (.NOT.CCS) THEN
222               Y2 = DDOT(NCCVAR2,WRK(K2VEC2),1,WRK(K2VEC2),1)
223             ELSE
224               Y2 = ZERO
225             END IF
226             IF (LOCDBG)
227     &          WRITE (LUPRI,*) ' norm^2 of RE vector:',Y1,Y2
228
229             ABCLM = DDOT(NCCVAR1,WRK(K1VEC1),1,WRK(K2VEC1),1)
230             IF (.NOT.CCS) THEN
231               ABCLM=ABCLM + DDOT(NCCVAR2,WRK(K1VEC2),1,WRK(K2VEC2),1)
232             END IF
233
234             CALL CC_RDRSP('M1',IM11,ISYMABC,IOPTRD,MODFIL,
235     *                     WRK(K1VEC1),WRK(K1VEC2))
236             X1 = DDOT(NCCVAR1,WRK(K1VEC1),1,WRK(K1VEC1),1)
237             IF (.NOT.CCS) THEN
238               X2 = DDOT(NCCVAR2,WRK(K1VEC2),1,WRK(K1VEC2),1)
239             ELSE
240               X2 = ZERO
241             END IF
242             IF (LOCDBG)
243     &          WRITE (LUPRI,*) 'Norm^2 of M1:',X1,X2,X1+X2
244
245             CALL CC_RDRSP('O3',IO3AC0F,ISYMABC,IOPTRD,MODFIL,
246     *                     WRK(K2VEC1),WRK(K2VEC2))
247             Y1 = DDOT(NCCVAR1,WRK(K2VEC1),1,WRK(K2VEC1),1)
248             IF (.NOT.CCS) THEN
249               Y2 = DDOT(NCCVAR2,WRK(K2VEC2),1,WRK(K2VEC2),1)
250             ELSE
251               Y2 = ZERO
252             END IF
253             IF (LOCDBG)
254     &          WRITE (LUPRI,*) ' Norm^2 of O3 vector:',y1,y2,y1+y2
255
256             CALL CCLR_DIASCL(WRK(K2VEC2),HALF,ISYMABC)
257
258             ABCLM = ABCLM + DDOT(NCCVAR1,WRK(K1VEC1),1,WRK(K2VEC1),1)
259             IF (.NOT.CCS) THEN
260               ABCLM=ABCLM + DDOT(NCCVAR2,WRK(K1VEC2),1,WRK(K2VEC2),1)
261             END IF
262
263*--------------------------------------------------------------*
264*            calculate right moment M_fo^DEF(w1,w2) contribution
265*            previously called SMCRM
266*--------------------------------------------------------------*
267
268             CALL CC_RDRSP('LE',IOFFST,ISYMABC,IOPTRD,MODFIL,
269     *                     WRK(K1VEC1),WRK(K1VEC2))
270             CALL CC_RDRSP('O3',IO3DFF0,ISYMABC,IOPTRD,MODFIL,
271     *                     WRK(K2VEC1),WRK(K2VEC2))
272             CALL CCLR_DIASCL(WRK(K2VEC2),HALF,ISYMABC)
273
274             DEFRM = DDOT(NCCVAR1,WRK(K1VEC1),1,WRK(K2VEC1),1)
275             IF (.NOT.CCS) THEN
276               DEFRM=DEFRM + DDOT(NCCVAR2,WRK(K1VEC2),1,WRK(K2VEC2),1)
277             END IF
278
279*--------------------------------------------------------------*
280*            calculate left moment M_of^DEF(-w1,-w2) contrib.
281*            (previously SMLM)
282*--------------------------------------------------------------*
283
284             CALL CC_RDRSP('X3',IX3DF0F,ISYMABC,IOPTRD,MODFIL,
285     *                     WRK(K1VEC1),WRK(K1VEC2))
286
287             CALL CC_RDRSP('RE',IOFFST,ISYMABC,IOPTRD,MODFIL,
288     *                     WRK(K2VEC1),WRK(K2VEC2))
289             DEFLM = DDOT(NCCVAR1,WRK(K1VEC1),1,WRK(K2VEC1),1)
290             IF (.NOT.CCS) THEN
291               DEFLM = DEFLM + DDOT(NCCVAR2,WRK(K1VEC2),1,WRK(K2VEC2),1)
292             END IF
293
294             CALL CC_RDRSP('M1',IM11,ISYMABC,IOPTRD,MODFIL,
295     *                     WRK(K1VEC1),WRK(K1VEC2))
296
297             CALL CC_RDRSP('O3',IO3DF0F,ISYMABC,IOPTRD,MODFIL,
298     *                     WRK(K2VEC1),WRK(K2VEC2))
299             CALL CCLR_DIASCL(WRK(K2VEC2),HALF,ISYMABC)
300
301             DEFLM = DEFLM + DDOT(NCCVAR1,WRK(K1VEC1),1,WRK(K2VEC1),1)
302             IF (.NOT.CCS) THEN
303               DEFLM = DEFLM + DDOT(NCCVAR2,WRK(K1VEC2),1,WRK(K2VEC2),1)
304             END IF
305
306*--------------------------------------------------------------*
307*            calculate right moment M_fo^ABC(w1,w2) contribution
308*            (previously SMRM)
309*--------------------------------------------------------------*
310
311             CALL CC_RDRSP('LE',IOFFST,ISYMABC,IOPTRD,MODFIL,
312     *                     WRK(K1VEC1),WRK(K1VEC2))
313             CALL CC_RDRSP('O3',IO3ACF0,ISYMABC,IOPTRD,MODFIL,
314     *                     WRK(K2VEC1),WRK(K2VEC2))
315             CALL CCLR_DIASCL(WRK(K2VEC2),HALF,ISYMABC)
316
317             ABCRM = DDOT(NCCVAR1,WRK(K1VEC1),1,WRK(K2VEC1),1)
318             IF (.NOT.CCS) THEN
319               ABCRM = ABCRM+DDOT(NCCVAR2,WRK(K1VEC2),1,WRK(K2VEC2),1)
320             END IF
321*--------------------------------------------------------------*
322*            Final three-photon transition strength:
323*--------------------------------------------------------------*
324
325             THREEPH = HALF*(ABCLM*DEFRM+DEFLM*ABCRM)
326
327*--------------------------------------------------------------*
328* Write results on output
329*--------------------------------------------------------------*
330         WRITE(LUPRI,'(65("-"),/1x,a,f10.6,a,i1,a,i1)')
331     &  'For trans. to |f(',EIGV,')>, state nr. ',ITMSEL(IFREQ,2),
332     &                              ' of symm. ',ISYMABC
333         WRITE(LUPRI,'(/,3(1x,a5,a,a1,i1,a1))')
334     &     ' A:  ',LABELA,'(',ISYMA,')', '; B: ',LABELB,'(',ISYMB,')',
335     &     '; C: ',LABELC,'(',ISYMC,')'
336         WRITE(LUPRI,'(3(1x,a5,a,a1,i1,a1))')
337     &     ' D:  ',LABELD,'(',ISYMD,')', '; E: ',LABELE,'(',ISYME,')',
338     &     '; F: ',LABELF,'(',ISYMF,')'
339         WRITE(LUPRI,'(1x,a,f10.6,a,f10.6)')
340     &     ' Laser frequencies (au): w1 = ', FREQB, '; w2 = ', FREQC
341C         IF (LOCDBG) THEN
342         WRITE(LUPRI,'(2(/1x,a,f15.9,1x,a,f15.9))')
343     & ' M^ABC_of(-w1,-w2): ',ABCLM,' M^DEF_fo(w1,w2): ',DEFRM,
344     & ' M^DEF_of(-w1,-w2): ',DEFLM,' M^ABC_fo(w1,w2): ',ABCRM
345         WRITE(LUPRI,'(2(1x,a,f15.9,/))')
346     & ' M^ABC_of(-w1,-w2) x M^DEF_fo(w1,w2)   = ', abclm*defrm,
347     & '[M^DEF_of(-w1,-w2) x M^ABC_fo(w1,w2)]* = ', deflm*abcrm
348C         END IF
349        WRITE(LUPRI,'(1x,a5,a,/,1x,a5,a,f10.6,a1,f10.6,a,f15.9)')
350     &   MODPRI,'Transition strength for Third Order Moment: ',
351     &   MODPRI,'S^of_ABC,DEF(',FREQB,',',FREQC,') = ', THREEPH
352        WRITE(LUPRI,'(65("-"))')
353
354*--------------------------------------------------------------*
355
356          END DO
357        END IF
358
359      END DO
360
361      RETURN
362      END
363*=====================================================================*
364*---------------------------------------------------------------------*
365
366       SUBROUTINE CC_TMSORT
367*---------------------------------------------------------------------*
368*
369*    Purpose: sort the selected states for which third moment
370*             calculation is carried. if no selected states are
371*             chosen use all states specified in the excitation
372*             energy calculation is used
373*
374*    P. Joergensen, C. Haettig 1997
375*    Clean up, new output. Sonia 2001
376*=====================================================================*
377
378#if defined (IMPLICIT_NONE)
379      IMPLICIT NONE
380#else
381#include "implicit.h"
382#endif
383#include "priunit.h"
384#include "ccorb.h"
385#include "cctm.h"
386#include "cctminf.h"
387#include "ccexci.h"
388#include "cclr.h"
389
390
391* local parameters:
392
393      INTEGER ISYM, IST, ISEL, I, ISAVE, JSEL, J, IOFF
394      INTEGER ISYMSV, ISTSV, JSTSV, ISTATE
395      LOGICAL LOCDBG
396      PARAMETER (LOCDBG = .FALSE.)
397
398#if defined (SYS_CRAY)
399      REAL D3, BTMFRSV, CTMFRSV
400#else
401      DOUBLE PRECISION D3, BTMFRSV, CTMFRSV
402#endif
403      PARAMETER ( D3 = 3.0D00 )
404
405C
406C sort the selected states for which third order transition
407C matrix elements are calculated
408C
409      DO 50 ISYM = 1,NSYM
410         NTMSELX(ISYM) = 0
411 50   CONTINUE
412C
413      IF ( SELTMST ) THEN
414C
415C sort list according to symmetry
416C
417         ITMSELX(1) = 0
418         DO 100 ISYM = 1,NSYM
419            IST = ITMSELX(ISYM) + 1
420            DO 200 I = IST,NTMSEL
421               IF ( ITMSEL(I,1).EQ.ISYM) THEN
422                  NTMSELX(ISYM) = NTMSELX(ISYM) + 1
423               ELSE
424                  DO 300 J = I+1,NTMSEL
425                     IF ( ITMSEL(J,1).EQ.ISYM) THEN
426                        ISYMSV = ITMSEL(J,1)
427                        ISTSV  = ITMSEL(J,2)
428                        BTMFRSV = BTMFR(J)
429                        CTMFRSV = CTMFR(J)
430                        ITMSEL(J,1) = ITMSEL(I,1)
431                        ITMSEL(J,2) = ITMSEL(I,2)
432                        BTMFR(J)   = BTMFR(I)
433                        CTMFR(J)   = CTMFR(I)
434                        ITMSEL(I,1) = ISYMSV
435                        ITMSEL(I,2) = ISTSV
436                        BTMFR(I)   = BTMFRSV
437                        CTMFR(I)   = CTMFRSV
438                        NTMSELX(ISYM) = NTMSELX(ISYM) + 1
439                        GO TO 200
440                     END IF
441 300              CONTINUE
442               END IF
443 200        CONTINUE
444            IF ( ISYM .LT. NSYM ) THEN
445               ITMSELX(ISYM+1) = ITMSELX(ISYM) + NTMSELX(ISYM)
446            END IF
447            IF (LOCDBG)
448     &      WRITE (LUPRI,*) 'SORT:',ITMSELX(ISYM),NTMSELX(ISYM),IST
449 100     CONTINUE
450         IF (LOCDBG) THEN
451           WRITE (LUPRI,*) ' after sort of  symmetry '
452           WRITE (LUPRI,*) 'ntmsel',ntmsel
453           do 210 i = 1,ntmsel
454             WRITE (LUPRI,*) ' itmsel(i,1),itmsel(i,2),i'
455             WRITE (LUPRI,*)  itmsel(i,1),itmsel(i,2),i
456 210       continue
457           do 211 i = 1,nsym
458             WRITE (LUPRI,*) ' itmselx(i),ntmselx(i),i'
459             WRITE (LUPRI,*) itmselx(i),ntmselx(i),i
460 211       continue
461         END IF
462C
463C sort list according to state number
464C
465         DO 400 ISYM = 1,NSYM
466            IOFF = ITMSELX(ISYM)
467            DO 500 ISEL = 1,NTMSELX(ISYM)
468               I = IOFF + ISEL
469               ISTSV = ITMSEL(I,2)
470               ISAVE  = I
471               DO 600 JSEL = ISEL+1,NTMSELX(ISYM)
472                  J = IOFF + JSEL
473                  JSTSV = ITMSEL(J,2)
474                  IF ( JSTSV.LT. ISTSV ) THEN
475                     ISTSV  = JSTSV
476                     ISAVE  = J
477                  END IF
478 600           CONTINUE
479               IF ( I.NE.ISAVE ) THEN
480                  ISYMSV = ITMSEL(ISAVE,1)
481                  ISTSV  = ITMSEL(ISAVE,2)
482                  BTMFRSV = BTMFR(ISAVE)
483                  CTMFRSV = CTMFR(ISAVE)
484                  ITMSEL(ISAVE,1) = ITMSEL(I,1)
485                  ITMSEL(ISAVE,2) = ITMSEL(I,2)
486                  BTMFR(ISAVE)   = BTMFR(I)
487                  CTMFR(ISAVE)   = CTMFR(I)
488                  ITMSEL(I,1) = ISYMSV
489                  ITMSEL(I,2) = ISTSV
490                  BTMFR(I)   = BTMFRSV
491                  CTMFR(I)   = CTMFRSV
492               END IF
493 500        CONTINUE
494 400     CONTINUE
495         IF (LOCDBG) THEN
496           WRITE (LUPRI,*) ' after sort of both symmetry and state'
497           WRITE (LUPRI,*) 'ntmsel',ntmsel
498           do 212 i = 1,ntmsel
499             WRITE (LUPRI,*) ' itmsel(i,1),itmsel(i,2),i'
500             WRITE (LUPRI,*) itmsel(i,1),itmsel(i,2),i
501 212       continue
502           do 213 i = 1,nsym
503             WRITE (LUPRI,*) ' itmselx(i),ntmselx(i),i'
504             WRITE (LUPRI,*) itmselx(i),ntmselx(i),i
505 213       continue
506         END IF
507C
508C if .HALFFR not specified find frequencies for AOPERATOR
509C
510         DO 550 ISYM = 1,NSYM
511            IOFF = ITMSELX(ISYM)
512            WRITE (LUPRI,*) 'isym, ioff', isym, ioff
513            DO 560 I = 1,NTMSELX(ISYM)
514               ISTSV = ITMSEL(IOFF+I,2)
515               EXTMFR(IOFF+I) = EIGVAL(ISYOFE(ISYM)+ISTSV)
516
517               IF (LOCDBG) THEN
518                  WRITE (LUPRI,*) 'istsv,ioff,isym,i'
519                  WRITE (LUPRI,*) istsv,ioff,isym,i
520                  WRITE (LUPRI,*) ' isyofe(isym)'
521                  WRITE (LUPRI,*) isyofe(isym)
522                  WRITE (LUPRI,*) ' eigval(1)'
523                  call flshfo(LUPRI)
524                  WRITE (LUPRI,*) eigval(1)
525                  call flshfo(LUPRI)
526                  WRITE (LUPRI,*) ' eigval(isyofe(isym)+istsv)'
527                  call flshfo(LUPRI)
528                  WRITE (LUPRI,*) eigval(isyofe(isym)+istsv)
529                  call flshfo(LUPRI)
530                  WRITE (LUPRI,*) ' EXTMFR(IOFF+I) '
531                  call flshfo(LUPRI)
532                  WRITE (LUPRI,*) EXTMFR(IOFF+I)
533                  call flshfo(LUPRI)
534               END IF
535 560        CONTINUE
536         IF (LOCDBG) THEN
537            WRITE (LUPRI,*) ' isym loop slut',isym
538            call flshfo(LUPRI)
539         END IF
540 550     CONTINUE
541      END IF
542C
543C if selected states not specified for second moment calculations
544C then carry out calculations for all specified excited states
545C and use frequencies that are half the excitation energy
546C
547      IF ( .NOT. SELTMST ) THEN
548         ITMSELX(1) = 0
549         NTMSEL = 0
550         DO 700 ISYM = 1,NSYM
551            DO 750 I = 1,NCCEXCI(ISYM,1)
552               NTMSEL = NTMSEL + 1
553               ITMSEL(NTMSEL,1) = ISYM
554               ITMSEL(NTMSEL,2) = I
555               NTMSELX(ISYM)    = NTMSELX(ISYM) + 1
556 750        CONTINUE
557            ITMSELX(ISYM+1) = ITMSELX(ISYM) + NTMSELX(ISYM)
558 700     CONTINUE
559         THIRDFR = .TRUE.
560      END IF
561C
562C
563      IF (THIRDFR) THEN
564         DO 800  ISYM = 1,NSYM
565            IOFF = ITMSELX(ISYM)
566            DO 850 I = 1,NTMSELX(ISYM)
567               ISTATE = ITMSEL(IOFF+I,2)
568               BTMFR(IOFF+I) = EIGVAL(ISYOFE(ISYM)+ISTATE)/ D3
569               CTMFR(IOFF+I) = EIGVAL(ISYOFE(ISYM)+ISTATE)/ D3
570               EXTMFR(IOFF+I) = EIGVAL(ISYOFE(ISYM)+ISTATE)
571 850        CONTINUE
572 800     CONTINUE
573      END IF
574         IF (LOCDBG) THEN
575           WRITE(LUPRI,*) ' leaving sort'
576           do i = 1,ntmsel
577           WRITE(LUPRI,*) ' itmsel(i,1),itmsel(i,2),extmfr(i),i'
578           call flshfo(LUPRI)
579           WRITE(LUPRI,*) itmsel(i,1),itmsel(i,2),extmfr(i),i
580           end do
581           call flshfo(LUPRI)
582         END IF
583
584      RETURN
585      END
586*=====================================================================*
587