← Back to branch summary

~ubuntu-branches/ubuntu/trusty/nwchem/trusty-proposed

« back to all changes in this revision

Viewing changes to src/property/get_alfaorbeta_reim.F

  • Committer: Package Import Robot
  • Author(s): Michael Banck, Daniel Leidert, Andreas Tille, Michael Banck
  • Date: 2013-07-04 12:14:55 UTC
  • mfrom: (1.1.2)
  • Revision ID: package-import@ubuntu.com-20130704121455-5tvsx2qabor3nrui
Tags: 6.3-1
http://bugs.debian.org/696361
* New upstream release.
* Fixes anisotropic properties (Closes: #696361).
* New features include:
  + Multi-reference coupled cluster (MRCC) approaches
  + Hybrid DFT calculations with short-range HF 
  + New density-functionals including Minnesota (M08, M11) and HSE hybrid
    functionals
  + X-ray absorption spectroscopy (XAS) with TDDFT
  + Analytical gradients for the COSMO solvation model
  + Transition densities from TDDFT 
  + DFT+U and Electron-Transfer (ET) methods for plane wave calculations
  + Exploitation of space group symmetry in plane wave geometry optimizations
  + Local density of states (LDOS) collective variable added to Metadynamics
  + Various new XC functionals added for plane wave calculations, including
    hybrid and range-corrected ones
  + Electric field gradients with relativistic corrections 
  + Nudged Elastic Band optimization method
  + Updated basis sets and ECPs 

[ Daniel Leidert ]
* debian/watch: Fixed.

[ Andreas Tille ]
* debian/upstream: References

[ Michael Banck ]
* debian/upstream (Name): New field.
* debian/patches/02_makefile_flags.patch: Refreshed.
* debian/patches/06_statfs_kfreebsd.patch: Likewise.
* debian/patches/07_ga_target_force_linux.patch: Likewise.
* debian/patches/05_avoid_inline_assembler.patch: Removed, no longer needed.
* debian/patches/09_backported_6.1.1_fixes.patch: Likewise.
* debian/control (Build-Depends): Added gfortran-4.7 and gcc-4.7.
* debian/patches/10_force_gcc-4.7.patch: New patch, explicitly sets
  gfortran-4.7 and gcc-4.7, fixes test suite hang with gcc-4.8 (Closes:
  #701328, #713262).
* debian/testsuite: Added tests for COSMO analytical gradients and MRCC.
* debian/rules (MRCC_METHODS): New variable, required to enable MRCC methods.

Show diffs side-by-side

added added

removed removed

Lines of Context:
src/property/get_alfaorbeta_reim.F
 
1
      subroutine get_alfaorbeta_reim(
 
2
     &                AorBre,      ! in/out: alpha or beta real part
 
3
     &                AorBim,      ! in/out: alpha or beta im   part
 
4
     &                g_vecE1,     ! in : 1st-order pert vec RE
 
5
     &                g_vecE1_im,  ! in : 1st-order pert vec IM
 
6
     &                g_dipEM,     ! in : dipole electric or magnetic
 
7
     &                g_vectors,   ! in : MO vectors
 
8
     &                idir,        ! in : = 1,2,3=x,y,z directions
 
9
     &                iresp,       ! in : = 1,2,3
 
10
     &                coeffre,     ! in : coeff for real part
 
11
     &                coeffim,     ! in : coeff for imag part
 
12
     &                caseAO,      ! in : indices in (alo,ahi)(3) (blo,bhi)(3)
 
13
     &                nbf,         ! in : nr. basis functions
 
14
     &                nocc,        ! in : nr. occupied alpha or beta
 
15
     &                lifetime,    ! in : logical var for damping
 
16
     &                debug,       ! in : logical var for debugging
 
17
     &                g_temp)      ! in : scratch GA array
 
18
c
 
19
c Author : Fredy W. Aquino
 
20
c Date   : 03-15-12
 
21
c Note.- Modified from original aoresponse source code
 
22
c        for extension to spin-unrestricted case
 
23
c        original aoresponse source code was written by 
 
24
c        J. Autschbach and appears on nwchem-devtrunk (date:03-02-12)
 
25
c                
 
26
c --> Experimental (not published yet)
 
27
 
 
28
      implicit none
 
29
#include "errquit.fh"
 
30
#include "global.fh"
 
31
#include "mafdecls.fh"
 
32
#include "msgids.fh"
 
33
#include "geom.fh"
 
34
#include "rtdb.fh"
 
35
#include "bas.fh"
 
36
#include "stdio.fh"
 
37
#include "apiP.fh"
 
38
#include "prop.fh"
 
39
#include "bgj.fh"
 
40
      double precision AorBre, ! OUTPUT
 
41
     &                 AorBim  ! OUTPUT 
 
42
      integer idir,iresp,ndir,
 
43
     &        nbf,nocc,
 
44
     &        caseAO,ind1,ind2
 
45
      integer alo(3),ahi(3), 
 
46
     &        blo(3),bhi(3), 
 
47
     &        clo(3),chi(3)
 
48
      integer g_temp,     ! scratch ga arrays (input)
 
49
     &        g_vecE1,    ! IN
 
50
     &        g_vecE1_im, ! IN
 
51
     &        g_vectors,  ! IN
 
52
     &        g_dipEM     ! IN : = g_dipel or g_dipmag
 
53
      logical lifetime,debug
 
54
      double precision sum,sumre,sumim,
 
55
     &                 coeffre,coeffim,trace
 
56
      external trace,get_C1MCtrace
 
57
      double precision ga_trace_diag
 
58
      external ga_trace_diag 
 
59
      if (debug) then
 
60
        if (ga_nodeid().eq.0) then
 
61
           write(*,2) idir,iresp,caseAO,nbf,
 
62
     &                nocc
 
63
 2         format('(idir,iresp,caseAO,nbf,nocc)=(',
 
64
     &            i3,',',i3,',',i3,',',i3,',',i3,')')
 
65
          endif
 
66
         if (ga_nodeid().eq.0) then
 
67
          write(*,10) idir,iresp
 
68
 10       format('---- g_vecE1(',i3,',',i3,')-------- START')
 
69
         endif
 
70
          call ga_print(g_vecE1)
 
71
         if (ga_nodeid().eq.0) then
 
72
          write(*,11) idir,iresp
 
73
 11       format('---- g_vecE1(',i3,',',i3,')-------- END')
 
74
         endif
 
75
         if (ga_nodeid().eq.0) then
 
76
          write(*,12) idir,iresp
 
77
 12       format('---- g_dipEM(',i3,',',i3,')-------- START')
 
78
         endif
 
79
          call ga_print(g_dipEM)
 
80
         if (ga_nodeid().eq.0) then
 
81
          write(*,21) idir,iresp
 
82
 21       format('---- g_dipEM(',i3,',',i3,')-------- END')
 
83
         endif
 
84
         if (ga_nodeid().eq.0) then
 
85
          write(*,13) idir,iresp
 
86
 13       format('---- g_vectors(',i3,',',i3,')-------- START')
 
87
         endif
 
88
          call ga_print(g_vectors)
 
89
         if (ga_nodeid().eq.0) then
 
90
          write(*,14) idir,iresp
 
91
 14       format('---- g_vectors(',i3,',',i3,')-------- END')
 
92
         endif
 
93
      endif ! end-if-debug
 
94
 
 
95
       call get_C1MCtrace(
 
96
     &               sumre,       ! out: trace(transp(vecE1  )*g_temp)
 
97
     &               sumim,       ! out: trace(transp(vecE1im)*g_temp)
 
98
     &               lifetime,    ! in : =T => returns sumim
 
99
     &               g_vecE1,     ! in : 1st-order pert vec RE
 
100
     &               g_vecE1_im,  ! in : 1st-order pert vec IM
 
101
     &               g_dipEM,     ! in : dipole electric or magnetic
 
102
     &               g_vectors,   ! in : MO vectors
 
103
     &               idir,        ! in : = 1,2,3=x,y,z directions
 
104
     &               iresp,       ! in : = 1,2,3
 
105
     &               caseAO,      ! in : indices in (alo,ahi)(3) (blo,bhi)(3)
 
106
     &               nbf,         ! in : nr. basis functions
 
107
     &               nocc,        ! in : nr. occupied alpha or beta
 
108
     &               debug,       ! in : logical var for debugging
 
109
     &               g_temp)      ! in : scratch GA array -> out
 
110
 
 
111
c           the factor of two is for the orbital occupations,
 
112
c           assuming that ispin is never equal to two     
 
113
       AorBre=AorBre+coeffre*sumre
 
114
       if (lifetime) 
 
115
     & AorBim=AorBim+coeffim*sumim
 
116
      return
 
117
      end
 
118
 
 
119
      subroutine get_C1MC(
 
120
     &                g_work,      ! out: C(E) M C
 
121
     &                g_vecE1,     ! in : 1st-order pert vec RE
 
122
     &                g_dipEM,     ! in : dipole electric or magnetic
 
123
     &                g_vectors,   ! in : MO vectors
 
124
     &                idir,        ! in : = 1,2,3=x,y,z directions
 
125
     &                iresp,       ! in : = 1,2,3
 
126
     &                caseAO,      ! in : indices in (alo,ahi)(3) (blo,bhi)(3)
 
127
     &                nbf,         ! in : nr. basis functions
 
128
     &                nocc,        ! in : nr. occupied alpha or beta
 
129
     &                debug,       ! in : logical var for debugging
 
130
     &                g_temp)      ! in : scratch GA array
 
131
c
 
132
c Author : Fredy W. Aquino
 
133
c Date   : 03-15-12
 
134
c Note.- Modified from original aoresponse source code
 
135
c        for extension to spin-unrestricted case
 
136
c        original aoresponse source code was written by 
 
137
c        J. Autschbach and appears on nwchem-devtrunk (date:03-02-12)
 
138
c                
 
139
c --> Experimental (not published yet)
 
140
 
 
141
      implicit none
 
142
#include "errquit.fh"
 
143
#include "global.fh"
 
144
#include "mafdecls.fh"
 
145
#include "msgids.fh"
 
146
#include "rtdb.fh"
 
147
#include "stdio.fh"
 
148
      integer g_work  ! = C(E) M C
 
149
      integer idir,iresp,
 
150
     &        nbf,nocc,
 
151
     &        caseAO,ind1,ind2
 
152
      integer alo(3),ahi(3), 
 
153
     &        blo(3),bhi(3), 
 
154
     &        clo(3),chi(3)
 
155
      integer g_temp,     ! IN: scratch ga arrays (input)
 
156
     &        g_vecE1,    ! IN
 
157
     &        g_vectors,  ! IN
 
158
     &        g_dipEM     ! IN : = g_dipel or g_dipmag
 
159
      logical debug
 
160
c Note.- (ind1,ind2)=(iresp,1    ) for caseAO=1 (g_dipEM ne g_smat0)
 
161
c        (ind1,ind2)=(1    ,iresp) for caseAO=2 (g_dipEM eq g_smat0)
 
162
c        (ind1,ind2)=(1    ,idir ) for caseAO=3 (g_dipEM eq g_smat0) in aor_r1_beta_anl
 
163
c        (ind1,ind2)=(idir ,1    ) for caseAO=4 (g_dipEM eq g_sket1) in aor_r1_beta_anl
 
164
            if      (caseAO .eq. 1) then
 
165
             ind1=iresp
 
166
             ind2=1
 
167
            else if (caseAO .eq. 2) then
 
168
             ind1=1
 
169
             ind2=iresp
 
170
            else if (caseAO .eq. 3) then
 
171
             ind1=1
 
172
             ind2=idir
 
173
            else if (caseAO .eq. 4) then
 
174
             ind1=idir
 
175
             ind2=1
 
176
            else
 
177
             call errquit
 
178
     &       ('get_C1MC: caseAO ne 1,2,3 or 4',
 
179
     &       0,GA_ERR)
 
180
            endif
 
181
            alo(1) = 1
 
182
            ahi(1) = nbf
 
183
            alo(2) = 1
 
184
            ahi(2) = nbf
 
185
            alo(3) = ind1 ! pick direction iresp for g_dipEM
 
186
            ahi(3) = ind1
 
187
            blo(1) = 1
 
188
            bhi(1) = nbf
 
189
            blo(2) = 1
 
190
            bhi(2) = nocc
 
191
            blo(3) = ind2 
 
192
            bhi(3) = ind2     
 
193
            clo(1) = 1
 
194
            chi(1) = nbf
 
195
            clo(2) = 1
 
196
            chi(2) = nocc
 
197
            if (debug) then
 
198
             if (ga_nodeid().eq.0) then
 
199
              write(*,18) alo(1),ahi(1),alo(2),ahi(2),
 
200
     &               alo(3),ahi(3),
 
201
     &               blo(1),bhi(1),blo(2),bhi(2),
 
202
     &               blo(3),bhi(3),
 
203
     &               clo(1),chi(1),clo(2),chi(2),
 
204
     &               clo(3),chi(3)
 
205
 18           format('FA-1::alo-ahi=(',i3,',',i3,',',
 
206
     &          i3,',',i3,',',i3,',',i3,') ',
 
207
     &          'blo-bhi=(',i3,',',i3,',',
 
208
     &          i3,',',i3,',',i3,',',i3,') ',
 
209
     &          'clo-chi=(',i3,',',i3,',',
 
210
     &          i3,',',i3,',',i3,',',i3,')')
 
211
             endif
 
212
            endif ! end-if-debug
 
213
 
 
214
            call ga_zero(g_temp)
 
215
            call nga_matmul_patch('n','n',1d0,0d0,
 
216
     &         g_dipEM  ,alo,ahi,
 
217
     &         g_vectors,blo,bhi,
 
218
     &         g_temp   ,clo,chi)
 
219
            if (debug) write (luout,*)
 
220
     &         'alfa: h(E) C(0) intermediate complete'
 
221
            alo(1) = 1
 
222
            ahi(1) = nocc
 
223
            alo(2) = 1
 
224
            ahi(2) = nbf
 
225
            alo(3) = idir
 
226
            ahi(3) = idir
 
227
            blo(1) = 1
 
228
            bhi(1) = nbf
 
229
            blo(2) = 1
 
230
            bhi(2) = nocc
 
231
            clo(1) = 1
 
232
            chi(1) = nocc
 
233
            clo(2) = 1
 
234
            chi(2) = nocc
 
235
            if (debug) then
 
236
             if (ga_nodeid().eq.0) then
 
237
              write(*,19) alo(1),ahi(1),alo(2),ahi(2),
 
238
     &               alo(3),ahi(3),
 
239
     &               blo(1),bhi(1),blo(2),bhi(2),
 
240
     &               blo(3),bhi(3),
 
241
     &               clo(1),chi(1),clo(2),chi(2),
 
242
     &               clo(3),chi(3)
 
243
 19           format('FA-2::alo-ahi=(',i3,',',i3,',',
 
244
     &          i3,',',i3,',',i3,',',i3,') ',
 
245
     &          'blo-bhi=(',i3,',',i3,',',
 
246
     &          i3,',',i3,',',i3,',',i3,') ',
 
247
     &          'clo-chi=(',i3,',',i3,',',
 
248
     &          i3,',',i3,',',i3,',',i3,')')
 
249
             endif
 
250
            endif ! end-if-debug
 
251
            call ga_zero(g_work)
 
252
            if (debug) then
 
253
             if (ga_nodeid().eq.0)
 
254
     &        write(*,*) '----g_vecE1 --------- START'
 
255
              call ga_print(g_vecE1)
 
256
             if (ga_nodeid().eq.0)
 
257
     &        write(*,*) '----g_vecE1 --------- END'
 
258
             if (ga_nodeid().eq.0)
 
259
     &        write(*,*) '----g_temp --------- START'
 
260
              call ga_print(g_temp)
 
261
             if (ga_nodeid().eq.0)
 
262
     &        write(*,*) '----g_temp --------- END'
 
263
            endif ! end-if-debug
 
264
            call nga_matmul_patch('t','n',1d0,0d0,
 
265
     &                  g_vecE1,alo,ahi,
 
266
     &                  g_temp ,blo,bhi,
 
267
     &                  g_work ,clo,chi)
 
268
            if (debug) then
 
269
             if (ga_nodeid().eq.0)
 
270
     &        write(*,*) '----g_work-inside----- START'
 
271
              call ga_print(g_work)
 
272
             if (ga_nodeid().eq.0)
 
273
     &        write(*,*) '----g_work-inside------- END'
 
274
            endif ! end-if-debug
 
275
      return
 
276
      end
 
277
 
 
278
      subroutine get_C1MCtrace(
 
279
     &                sumre,       ! out: trace(transp(vecE1  )*g_temp)
 
280
     &                sumim,       ! out: trace(transp(vecE1im)*g_temp)
 
281
     &                lifetime,    ! in : =T => returns sumim
 
282
     &                g_vecE1,     ! in : 1st-order pert vec RE
 
283
     &                g_vecE1_im,  ! in : 1st-order pert vec IM
 
284
     &                g_dipEM,     ! in : dipole electric or magnetic
 
285
     &                g_vectors,   ! in : MO vectors
 
286
     &                idir,        ! in : = 1,2,3=x,y,z directions
 
287
     &                iresp,       ! in : = 1,2,3
 
288
     &                caseAO,      ! in : indices in (alo,ahi)(3) (blo,bhi)(3)
 
289
     &                nbf,         ! in : nr. basis functions
 
290
     &                nocc,        ! in : nr. occupied alpha or beta
 
291
     &                debug,       ! in : logical var for debugging
 
292
     &                g_temp)      ! in : scratch GA array
 
293
c Note.- g_temp= g_dipEM * g_vectors
 
294
c
 
295
c Author : Fredy W. Aquino
 
296
c Date   : 03-15-12
 
297
c Note.- Modified from original aoresponse source code
 
298
c        for extension to spin-unrestricted case
 
299
c        original aoresponse source code was written by 
 
300
c        J. Autschbach and appears on nwchem-devtrunk (date:03-02-12)
 
301
c                
 
302
c --> Experimental (not published yet)
 
303
 
 
304
      implicit none
 
305
#include "errquit.fh"
 
306
#include "global.fh"
 
307
#include "mafdecls.fh"
 
308
#include "msgids.fh"
 
309
#include "rtdb.fh"
 
310
#include "stdio.fh"
 
311
      integer idir,iresp,
 
312
     &        nbf,nocc,
 
313
     &        caseAO,ind1,ind2
 
314
      integer alo(3),ahi(3), 
 
315
     &        blo(3),bhi(3), 
 
316
     &        clo(3),chi(3)
 
317
      integer g_temp,     ! IN: scratch ga arrays (input)
 
318
     &        g_vecE1,    ! IN
 
319
     &        g_vecE1_im, ! IN
 
320
     &        g_vectors,  ! IN
 
321
     &        g_dipEM     ! IN : = g_dipel or g_dipmag
 
322
      double precision trace,sumre,sumim
 
323
      external trace
 
324
      logical lifetime,debug
 
325
c Note.- (ind1,ind2)=(iresp,1    ) for caseAO=1 (g_dipEM ne g_smat0)
 
326
c        (ind1,ind2)=(1    ,iresp) for caseAO=2 (g_dipEM eq g_smat0)
 
327
c        (ind1,ind2)=(1    ,idir ) for caseAO=3 (g_dipEM eq g_smat0) in aor_r1_beta_anl
 
328
c        (ind1,ind2)=(idir ,1    ) for caseAO=4 (g_dipEM eq g_sket1) in aor_r1_beta_anl
 
329
            if      (caseAO .eq. 1) then
 
330
             ind1=iresp
 
331
             ind2=1
 
332
            else if (caseAO .eq. 2) then
 
333
             ind1=1
 
334
             ind2=iresp
 
335
            else if (caseAO .eq. 3) then
 
336
             ind1=1
 
337
             ind2=idir
 
338
            else if (caseAO .eq. 4) then
 
339
             ind1=idir
 
340
             ind2=1
 
341
            else
 
342
             call errquit
 
343
     &       ('get_C1MC: caseAO ne 1,2,3 or 4',
 
344
     &       0,GA_ERR)
 
345
            endif
 
346
            alo(1) = 1
 
347
            ahi(1) = nbf
 
348
            alo(2) = 1
 
349
            ahi(2) = nbf
 
350
            alo(3) = ind1 ! pick direction iresp for g_dipEM
 
351
            ahi(3) = ind1
 
352
            blo(1) = 1
 
353
            bhi(1) = nbf
 
354
            blo(2) = 1
 
355
            bhi(2) = nocc
 
356
            blo(3) = ind2 
 
357
            bhi(3) = ind2     
 
358
            clo(1) = 1
 
359
            chi(1) = nbf
 
360
            clo(2) = 1
 
361
            chi(2) = nocc
 
362
            if (debug) then
 
363
             if (ga_nodeid().eq.0) then
 
364
              write(*,18) alo(1),ahi(1),alo(2),ahi(2),
 
365
     &               alo(3),ahi(3),
 
366
     &               blo(1),bhi(1),blo(2),bhi(2),
 
367
     &               blo(3),bhi(3),
 
368
     &               clo(1),chi(1),clo(2),chi(2),
 
369
     &               clo(3),chi(3)
 
370
 18           format('FA-1::alo-ahi=(',i3,',',i3,',',
 
371
     &          i3,',',i3,',',i3,',',i3,') ',
 
372
     &          'blo-bhi=(',i3,',',i3,',',
 
373
     &          i3,',',i3,',',i3,',',i3,') ',
 
374
     &          'clo-chi=(',i3,',',i3,',',
 
375
     &          i3,',',i3,',',i3,',',i3,')')
 
376
             endif
 
377
            endif
 
378
 
 
379
            call ga_zero(g_temp)
 
380
            call nga_matmul_patch('n','n',1d0,0d0,
 
381
     &         g_dipEM  ,alo,ahi,
 
382
     &         g_vectors,blo,bhi,
 
383
     &         g_temp   ,clo,chi)
 
384
            if (debug) write (luout,*)
 
385
     &         'alfa: h(E) C(0) intermediate complete'
 
386
            alo(1) = 1
 
387
            ahi(1) = nocc
 
388
            alo(2) = 1
 
389
            ahi(2) = nbf
 
390
            alo(3) = idir
 
391
            ahi(3) = idir
 
392
            blo(1) = 1
 
393
            bhi(1) = nbf
 
394
            blo(2) = 1
 
395
            bhi(2) = nocc
 
396
            clo(1) = 1
 
397
            chi(1) = nocc
 
398
            clo(2) = 1
 
399
            chi(2) = nocc
 
400
            if (debug) then
 
401
             if (ga_nodeid().eq.0) then
 
402
             write(*,19) alo(1),ahi(1),alo(2),ahi(2),
 
403
     &               alo(3),ahi(3),
 
404
     &               blo(1),bhi(1),blo(2),bhi(2),
 
405
     &               blo(3),bhi(3),
 
406
     &               clo(1),chi(1),clo(2),chi(2),
 
407
     &               clo(3),chi(3)
 
408
 19          format('FA-2::alo-ahi=(',i3,',',i3,',',
 
409
     &          i3,',',i3,',',i3,',',i3,') ',
 
410
     &          'blo-bhi=(',i3,',',i3,',',
 
411
     &          i3,',',i3,',',i3,',',i3,') ',
 
412
     &          'clo-chi=(',i3,',',i3,',',
 
413
     &          i3,',',i3,',',i3,',',i3,')')
 
414
             endif
 
415
            endif ! end-if-debug
 
416
            if (debug) then
 
417
             if (ga_nodeid().eq.0)
 
418
     &        write(*,*) '----g_vecE1 --------- START'
 
419
              call ga_print(g_vecE1)
 
420
             if (ga_nodeid().eq.0)
 
421
     &        write(*,*) '----g_vecE1 --------- END'
 
422
             if (ga_nodeid().eq.0)
 
423
     &        write(*,*) '----g_temp --------- START'
 
424
              call ga_print(g_temp)
 
425
             if (ga_nodeid().eq.0)
 
426
     &        write(*,*) '----g_temp --------- END'
 
427
            endif ! end-if-debug
 
428
            sumre=trace(      ! out: trace of transp(A)* B
 
429
     &               g_vecE1, ! in : 
 
430
     &               g_temp,  ! in : 
 
431
     &               nocc,    ! in :  
 
432
     &               nbf,idir)! in : 
 
433
            sumim=0.0d0
 
434
            if (lifetime) then
 
435
            sumim=trace(        ! out: trace of transp(A)* B
 
436
     &               g_vecE1_im,! in : 
 
437
     &               g_temp,    ! in : 
 
438
     &               nocc,      ! in :  
 
439
     &               nbf,idir)  ! in : 
 
440
            endif ! end-if-lifetime
 
441
      return
 
442
      end
 
443
 
 
444
      double precision function 
 
445
     &                     trace( ! out: trace of transp(A)* B
 
446
     &                     g_A,   ! in : GA matrix A
 
447
     &                     g_B,   ! in : GA matrix B
 
448
     &                     nocc,  ! 
 
449
     &                     nbf,   !
 
450
     &                     idir)  !
 
451
c      Purpose: Calculate trace(transpose(A)*B) without the need
 
452
c               of doing a matrix multiplication A*B
 
453
c      Note1.- If we want  trace(A*B) swap: (1,2) for (2,1) in (aho,ahi)
 
454
c        alo(2) = 1
 
455
c        ahi(2) = nbf
 
456
c        alo(1) = i
 
457
c        ahi(1) = i
 
458
c      Note2.- In nga_ddot_patch() the op1,op2='n','t' do not work
 
459
c              or maybe it works if the resulting patch is not a vector
 
460
c              if the resulting patch was a matrix then it could work
 
461
c              transposing the resulting patch.
 
462
c
 
463
c Author : Fredy W. Aquino
 
464
c Date   : 03-15-12
 
465
c Note.- Modified from original aoresponse source code
 
466
c        for extension to spin-unrestricted case
 
467
c        original aoresponse source code was written by 
 
468
c        J. Autschbach and appears on nwchem-devtrunk (date:03-02-12)
 
469
c                
 
470
c --> Experimental (not published yet)
 
471
 
 
472
      implicit none
 
473
#include "errquit.fh"
 
474
#include "global.fh"
 
475
#include "mafdecls.fh"
 
476
#include "msgids.fh"
 
477
#include "geom.fh"
 
478
#include "stdio.fh"
 
479
       integer g_A,g_B
 
480
       double precision ac_trace
 
481
       integer idir,nbf,nocc,i
 
482
       integer alo(3),ahi(3),
 
483
     &         blo(3),bhi(3)
 
484
        trace=0.0d0
 
485
        alo(1) = 1
 
486
        ahi(1) = nbf
 
487
        alo(3) = idir
 
488
        ahi(3) = idir
 
489
        blo(1) = 1
 
490
        bhi(1) = nbf
 
491
        blo(3) = 1
 
492
        bhi(3) = 1
 
493
       do i=1,nocc
 
494
        alo(2) = i
 
495
        ahi(2) = i
 
496
        blo(2) = i
 
497
        bhi(2) = i
 
498
        ac_trace=nga_ddot_patch(g_A,'n',alo,ahi,
 
499
     &                          g_B,'n',blo,bhi) 
 
500
        trace=trace+ac_trace
 
501
       enddo ! end-loop-i
 
502
      return
 
503
      end