1      subroutine tce_jacobi_ir1(d_r1,d_t1,k_t1_offset,omega,
2     1                          shift,damping)
3c
4c $Id$
5c
6      implicit none
7#include "global.fh"
8#include "mafdecls.fh"
9#include "sym.fh"
10#include "util.fh"
11#include "stdio.fh"
12#include "errquit.fh"
13#include "tce.fh"
14#include "tce_main.fh"
15#include "tce_diis.fh"
16      integer d_r1
17      integer d_t1
18      integer p1b
19      integer h2b
20      integer p1
21      integer h2
22      integer k_t1_offset
23      integer size
24      integer l_r1,k_r1
25      integer i
26      integer nprocs
27      integer count
28      integer next
29      integer nxtask
30      external nxtask
31      logical noloadbalance
32      logical nodezero         ! True if node 0
33      double precision shift,omega,damping
34      double precision denom
35c
36c     ================
37c     Loop over blocks
38c     ================
39c
40      nodezero = (ga_nodeid().eq.0)
41      noloadbalance = ((ioalg.eq.4).or.
42     1                ((ioalg.eq.6).and.(.not.fileisga(d_r1))))
43      nprocs = ga_nnodes()
44      count = 0
45      next = nxtask(nprocs,1)
46      do p1b = noab+1,noab+nvab
47        do h2b = 1,noab
48          if (noloadbalance.or.(next.eq.count)) then
49            if (int_mb(k_spin+p1b-1) .eq. int_mb(k_spin+h2b-1)) then
50            if ((.not.restricted).or.(int_mb(k_spin+p1b-1)
51     1        +int_mb(k_spin+h2b-1).ne.4)) then
52            if (ieor(int_mb(k_sym+p1b-1),int_mb(k_sym+h2b-1)).eq.
53     &          irrep_x) then
54              size = int_mb(k_range+p1b-1) * int_mb(k_range+h2b-1)
55              if (.not.ma_push_get(mt_dbl,size,'rr1',l_r1,k_r1))
56     1          call errquit('tce_jacobi_ir1: MA problem',0,MA_ERR)
57              call get_hash_block(d_r1,dbl_mb(k_r1),size,
58     1          int_mb(k_t1_offset),((p1b-noab-1)*noab+h2b-1))
59              i = 0
60              do p1 = 1,int_mb(k_range+p1b-1)
61               do h2 = 1,int_mb(k_range+h2b-1)
62                i = i + 1
63                denom = (
64     1             -dbl_mb(k_evl_sorted+int_mb(k_offset+p1b-1)+p1-1)
65     2             +dbl_mb(k_evl_sorted+int_mb(k_offset+h2b-1)+h2-1)
66     3                   )
67                dbl_mb(k_r1+i-1) = damping*dbl_mb(k_r1+i-1)
68     1                           / ( shift + denom - omega )
69               enddo
70              enddo
71              call add_hash_block(d_t1,dbl_mb(k_r1),size,
72     1          int_mb(k_t1_offset),((p1b-noab-1)*noab+h2b-1))
73              if (nodezero.and.util_print('tr1',print_debug)) then
74                call get_hash_block(d_t1,dbl_mb(k_r1),size,
75     1          int_mb(k_t1_offset),((p1b-noab-1)*noab+h2b-1))
76                call ma_print_compact(dbl_mb(k_r1),size,1,'tr1')
77              endif
78              if (.not.ma_pop_stack(l_r1))
79     1          call errquit('tce_jacobi_ir1: MA problem',1,MA_ERR)
80            endif
81            endif
82            endif
83            next = nxtask(nprocs,1)
84          endif
85          count = count + 1
86        enddo
87      enddo
88      next = nxtask(-nprocs,1)
89      call ga_sync()
90      return
91      end
92