1      subroutine tce_jacobi_t1(d_r1,d_t1,k_t1_offset,shift)
2c
3c $Id$
4c
5      implicit none
6#include "global.fh"
7#include "mafdecls.fh"
8#include "sym.fh"
9#include "util.fh"
10#include "stdio.fh"
11#include "errquit.fh"
12#include "tce.fh"
13#include "tce_main.fh"
14      integer d_r1
15      integer d_t1
16      integer p1b
17      integer h2b
18      integer p1
19      integer h2
20      integer k_t1_offset
21      integer size
22      integer l_r1,k_r1
23      integer i
24      integer nprocs
25      integer count
26      integer next
27      integer iter
28      INTEGER NXTASK
29      EXTERNAL NXTASK
30      logical nodezero
31      logical noloadbalance
32      double precision shift
33c
34c      if(iter.le.100) then
35c       shift=-zlshift
36c      else
37c       shift=0.0d0
38c      end if
39c
40c     ================
41c     Loop over blocks
42c     ================
43c
44      nodezero = (ga_nodeid().eq.0)
45      noloadbalance = ((ioalg.eq.4).or.
46     1                ((ioalg.eq.6).and.(.not.fileisga(d_r1))))
47      nprocs = ga_nnodes()
48      count = 0
49cc      next = nxtask(nprocs,1)
50      next = NXTASK(nprocs, 1)
51      do p1b = noab+1,noab+nvab
52        do h2b = 1,noab
53          if (noloadbalance.or.(next.eq.count)) then
54            if (int_mb(k_spin+p1b-1) .eq. int_mb(k_spin+h2b-1)) then
55            if ((.not.restricted).or.(int_mb(k_spin+p1b-1)
56     1        +int_mb(k_spin+h2b-1).ne.4)) then
57            if (ieor(int_mb(k_sym+p1b-1),int_mb(k_sym+h2b-1)).eq.0) then
58              size = int_mb(k_range+p1b-1) * int_mb(k_range+h2b-1)
59              if (.not.ma_push_get(mt_dbl,size,'r1',l_r1,k_r1))
60     1          call errquit('tce_jacobi_t1: MA problem',0,MA_ERR)
61              call get_hash_block(d_r1,dbl_mb(k_r1),size,
62     1          int_mb(k_t1_offset),((p1b-noab-1)*noab+h2b-1))
63              i = 0
64              do p1 = 1,int_mb(k_range+p1b-1)
65                do h2 = 1,int_mb(k_range+h2b-1)
66                  i = i + 1
67                  dbl_mb(k_r1+i-1) = dbl_mb(k_r1+i-1)
68     1           / (-dbl_mb(k_evl_sorted+int_mb(k_offset+p1b-1)+p1-1)
69     2              +dbl_mb(k_evl_sorted+int_mb(k_offset+h2b-1)+h2-1)
70     3             +shift)
71                enddo
72              enddo
73              call add_hash_block(d_t1,dbl_mb(k_r1),size,
74     1          int_mb(k_t1_offset),((p1b-noab-1)*noab+h2b-1))
75c update of the res.-single vector to the form of increment used in DIIS proc.
76ccx              call put_hash_block(d_r1,dbl_mb(k_r1),size,
77ccx     1          int_mb(k_t1_offset),((p1b-noab-1)*noab+h2b-1))
78cc
79              if (nodezero.and.util_print('t1',print_debug)) then
80                call get_hash_block(d_t1,dbl_mb(k_r1),size,
81     1          int_mb(k_t1_offset),((p1b-noab-1)*noab+h2b-1))
82                call ma_print_compact(dbl_mb(k_r1),size,1,'t1')
83              endif
84              if (.not.ma_pop_stack(l_r1))
85     1          call errquit('tce_jacobi_t1: MA problem',1,MA_ERR)
86            endif
87            endif
88            endif
89cc            next = nxtask(nprocs,1)
90      next = NXTASK(nprocs, 1)
91          endif
92          count = count + 1
93        enddo
94      enddo
95cc      next = nxtask(-nprocs,1)
96      next = NXTASK(-nprocs, 1)
97      call ga_sync()
98      return
99      end
100c
101c
102c
103      subroutine tce_r1_divide(d_r1,k_t1_offset)
104c
105c $Id$
106c
107      implicit none
108#include "global.fh"
109#include "mafdecls.fh"
110#include "sym.fh"
111#include "util.fh"
112#include "stdio.fh"
113#include "errquit.fh"
114#include "tce.fh"
115#include "tce_main.fh"
116      integer d_r1
117      integer p1b
118      integer h2b
119      integer p1
120      integer h2
121      integer k_t1_offset
122      integer size
123      integer l_r1,k_r1
124      integer i
125      integer nprocs
126      integer count
127      integer next
128cc      integer nxtask
129cc      external nxtask
130      INTEGER NXTASK
131      EXTERNAL NXTASK
132      logical nodezero
133      logical noloadbalance
134c
135c     ================
136c     Loop over blocks
137c     ================
138c
139      nodezero = (ga_nodeid().eq.0)
140      noloadbalance = ((ioalg.eq.4).or.
141     1                ((ioalg.eq.6).and.(.not.fileisga(d_r1))))
142      nprocs = ga_nnodes()
143      count = 0
144cc      next = nxtask(nprocs,1)
145      next = NXTASK(nprocs, 1)
146      do p1b = noab+1,noab+nvab
147        do h2b = 1,noab
148          if (noloadbalance.or.(next.eq.count)) then
149            if (int_mb(k_spin+p1b-1) .eq. int_mb(k_spin+h2b-1)) then
150            if ((.not.restricted).or.(int_mb(k_spin+p1b-1)
151     1        +int_mb(k_spin+h2b-1).ne.4)) then
152            if (ieor(int_mb(k_sym+p1b-1),int_mb(k_sym+h2b-1)).eq.0) then
153              size = int_mb(k_range+p1b-1) * int_mb(k_range+h2b-1)
154              if (.not.ma_push_get(mt_dbl,size,'r1',l_r1,k_r1))
155     1          call errquit('tce_r1_divide: MA problem',0,MA_ERR)
156              call get_hash_block(d_r1,dbl_mb(k_r1),size,
157     1          int_mb(k_t1_offset),((p1b-noab-1)*noab+h2b-1))
158              i = 0
159              do p1 = 1,int_mb(k_range+p1b-1)
160                do h2 = 1,int_mb(k_range+h2b-1)
161                  i = i + 1
162                  dbl_mb(k_r1+i-1) = dbl_mb(k_r1+i-1)
163     1           / (-dbl_mb(k_evl_sorted+int_mb(k_offset+p1b-1)+p1-1)
164     2              +dbl_mb(k_evl_sorted+int_mb(k_offset+h2b-1)+h2-1))
165                enddo
166              enddo
167c update of the res.-single vector to the form of increment used in DIIS proc.
168              call put_hash_block(d_r1,dbl_mb(k_r1),size,
169     1          int_mb(k_t1_offset),((p1b-noab-1)*noab+h2b-1))
170cc
171              if (.not.ma_pop_stack(l_r1))
172     1          call errquit('tce_r1_divide: MA problem',1,MA_ERR)
173            endif
174            endif
175            endif
176cc            next = nxtask(nprocs,1)
177      next = NXTASK(nprocs, 1)
178          endif
179          count = count + 1
180        enddo
181      enddo
182cc      next = nxtask(-nprocs,1)
183      next = NXTASK(-nprocs, 1)
184      call ga_sync()
185      return
186      end
187
188