1      subroutine tce_uss_offdiagonal_1(d_r1m,d_r2m,k_r1_offsetm,
2     1 k_r2_offsetm,iref,jref,d_c1,d_c2)
3! Routine for off diagonal correction
4      implicit none
5#include "tce.fh"
6#include "mafdecls.fh"
7#include "stdio.fh"
8#include "rtdb.fh"
9#include "errquit.fh"
10#include "sym.fh"
11#include "tce_mrcc.fh"
12#include "global.fh"
13#include "tce_main.fh"
14
15      integer rtdb
16      logical nodezero
17      integer k_r2_offsetm(maxref),k_r2a_offsetm(maxref)
18      integer k_r1_offsetm(maxref)
19      integer d_r2m(maxref),d_r2a(maxref),d_r1m(maxref)
20      integer d_r3u(maxref),k_r3u_offsetm(maxref)
21      integer iref,jref,iexclevel
22      integer i,j,p1,h2,k,p2,h3,h4,i1,k2
23      integer size,l,m,n,o
24      integer l_r2,k_r2,l_r2a,k_r2a,l_r1a,k_r1a
25      integer p1b,h1b
26      integer orbindex(8),aorbindex(8),orbindexnew(8)
27      integer t, p1new,p2new, h1new, h2new,p3new,h3new
28      integer p1new1,p2new1, h1new1, h2new1,p3new1,h3new1
29      integer orbspin(8),aorbspin(8)
30      integer ioccnew(maxorb,2),iocc0(maxorb,2)
31      integer ioffset(6),ihash,oldhash
32      integer p1off,p2off,h1off,h2off,p3off,h3off
33      integer p1off1,p2off1,h1off1,h2off1,p3off1,h3off1
34      integer ispinfrom,ispinto
35      integer iu,is,ifrom,ito,is1
36      integer totaloff,hs,ilength
37      integer l_tmp,k_tmp,size1,k_tmp1,l_tmp1,l_d_c2,k_d_c2
38      integer sizenew,ihashold,ioff,sizenew1,ioff1,ioff2
39      integer noabn,nvabn,counter,iactive,counter1
40      integer d_c,d_c1,d_c2
41!
42      integer iexfrom,iexto,iexspin,wtp,wth
43      integer noper,erank,optyp,eoper,k1,signfact,noper2,eoper2,espin
44      double precision dsmult,fact
45      dimension eoper(4*maxexcit),optyp(4*maxexcit),eoper2(4*maxexcit),
46     1 espin(4*maxexcit)
47      dimension iexfrom(8),iexto(8),iexspin(8)
48!
49      logical ap1,ah2,ap2,ah1
50      EXTERNAL NXTASKsub
51      EXTERNAL NXTASK
52      INTEGER NXTASKsub
53      INTEGER NXTASK
54      INTEGER nxt
55      INTEGER nprocs
56      INTEGER count,next
57
58      if(lusesub) then
59
60      call ga_pgroup_sync(mypgid)
61      nprocs = GA_pgroup_NNODES(mypgid)
62      count = 0
63      next = NXTASKsub(nprocs, 1,mypgid)
64
65      else
66
67      call ga_sync()
68      nprocs = GA_NNODES()
69      count = 0
70      next = NXTASK(nprocs, 1)
71
72      endif
73
74
75      nodezero = (ga_nodeid().eq.0)
76!
77         noa = nblcks(1,iref)
78         nob = nblcks(2,iref)
79         nva = nblcks(3,iref)
80         nvb = nblcks(4,iref)
81
82         noab = noa+nob
83         nvab = nva+nvb
84
85         noabn = nblcks(1,jref)+nblcks(2,jref)
86         nvabn = nblcks(3,jref)+nblcks(4,jref)
87
88c-------
89! Generating R1(j,b) from diagonal r1(i,a)
90!
91      DO p1b = noab+1,noab+nvab
92      DO h1b = 1,noab
93
94!
95      if(count.eq.next) then
96!
97      IF (int_mb(k_spinm(iref)+p1b-1) .eq. int_mb(k_spinm(iref)+
98     1h1b-1)) THEN
99      IF (ieor(int_mb(k_symm(iref)+p1b-1),int_mb(k_symm(iref)+
100     1h1b-1)) .eq. irrep_t) THEN
101      IF ((.not.restricted).or.(int_mb(k_spinm(iref)+p1b-1)+
102     1int_mb(k_spinm(iref)+h1b-1).ne.4)) THEN
103
104      size = int_mb(k_rangem(iref)+p1b-1) *
105     1 int_mb(k_rangem(iref)+h1b-1)
106!
107        oldhash = h1b-1+noab*(p1b-noab-1)
108!
109        if (.not.ma_push_get(mt_dbl,size,'c2',l_r1a,k_r1a))
110     1   call errquit('tce_uss: MA problem',10,MA_ERR)
111!
112        CALL DFILL(size,0.0d0,dbl_mb(k_r1a),1)
113
114        call get_hash_block(d_r1m(iref),dbl_mb(k_r1a),size,
115     1   int_mb(k_r1_offsetm(iref)),oldhash)
116
117!--------------------
118!
119       counter = 0
120        ihash =-1
121        ihashold = -1
122       do i=1,int_mb(k_rangem(iref)+p1b-1)
123       do m=1,int_mb(k_rangem(iref)+h1b-1)
124
125         counter = counter + 1
126
127
128      orbspin(1) = int_mb(k_spinm(iref)+p1b-1) -1
129      orbspin(2) = int_mb(k_spinm(iref)+h1b-1) -1
130
131      orbindex(1) = (1 - orbspin(1)+
132     1 int_mb(k_mo_indexm(iref)+int_mb(k_offsetm(iref)+p1b-1)+i-1))/2
133
134      orbindex(2) = (1 - orbspin(2)+
135     1 int_mb(k_mo_indexm(iref)+int_mb(k_offsetm(iref)+h1b-1)+m-1))/2
136!
137      iexto(1) = moindexes(orbindex(1),orbspin(1)+1,iref)
138      iexfrom(1) = moindexes(orbindex(2),orbspin(2)+1,iref)
139      iexspin(1) = orbspin(1)+1
140!
141       signfact=0
142       dsmult=1.0d0
143       call perfexcit(erank,eoper,iref,jref,
144     &   1,iexfrom,iexto,iexspin,
145     &   signfact,espin,wtp,wth)
146
147      if(erank.eq.0) goto 111
148      if(erank.eq.2) then
149
150       signfact=mod(signfact,2)
151       if(signfact.ne.0) then
152        dsmult = -1.0d0
153       endif
154
155      orbindex(1)=moindexes(eoper(1),espin(1),jref)
156      orbindex(2)=moindexes(eoper(2),espin(2),jref)
157      p1new = orbinblck(orbindex(1),espin(1),jref)
158      h1new = orbinblck(orbindex(2),espin(2),jref)
159
160      p1off = offsetinblck(orbindex(1),espin(1),jref)
161      h1off = offsetinblck(orbindex(2),espin(2),jref)
162
163      ihash = h1new-1+noabn*(p1new-noabn-1)
164
165        ilength = int_mb(k_r1_offsetm(jref))
166        totaloff = -1
167
168        do k = 1, ilength
169          if(int_mb(k_r1_offsetm(jref)+k).eq.ihash) then
170             totaloff = 1
171            goto 112
172          endif
173        enddo
174 112     continue
175
176
177        if((p1new.le.noabn).or.
178     2     (h1new.gt.noabn))then
179           totaloff=-1
180        endif
181
182      if(totaloff.ne.-1)then
183
184      ioff = p1off*int_mb(k_rangem(jref)+h1new-1)+h1off
185
186      sizenew = int_mb(k_rangem(jref)+h1new-1)*
187     1           int_mb(k_rangem(jref)+p1new-1)
188
189      if (.not.ma_push_get(mt_dbl,sizenew,'tmp',l_tmp1,k_tmp1))
190     1       call errquit('tce_uss: MA problem',3,MA_ERR)
191
192        CALL DFILL(sizenew,0.0d0,dbl_mb(k_tmp1),1)
193
194      dbl_mb(k_tmp1+ioff)=dbl_mb(k_r1a+counter-1)*dsmult
195
196
197      call add_hash_block(d_c1,dbl_mb(k_tmp1),sizenew,
198     1   int_mb(k_r1_offsetm(jref)),ihash)
199
200       if (.not.ma_pop_stack(l_tmp1))
201     1    call errquit('tce_uss: MA problem',4,MA_ERR)
202
203         endif !totaloff
204
205       endif!erank=2
206!
207       if(erank.eq.4) then
208
209
210       orbindex(1)=moindexes(eoper(1),espin(1),jref)
211       orbindex(2)=moindexes(eoper(2),espin(2),jref)
212       orbindex(4)=moindexes(eoper(3),espin(3),jref)
213       orbindex(3)=moindexes(eoper(4),espin(4),jref)
214
215       signfact=mod(signfact,2)
216       if(signfact.ne.0) then
217        dsmult = -1.0d0
218       endif
219
220      p1new = orbinblck(orbindex(1),espin(1),jref)
221      p2new = orbinblck(orbindex(2),espin(2),jref)
222
223      h1new = orbinblck(orbindex(3),espin(4),jref)
224      h2new = orbinblck(orbindex(4),espin(3),jref)
225
226        p1off = offsetinblck(orbindex(1),espin(1),jref)
227        p2off = offsetinblck(orbindex(2),espin(2),jref)
228        h1off = offsetinblck(orbindex(3),espin(4),jref)
229        h2off = offsetinblck(orbindex(4),espin(3),jref)
230c
231      if(p1new.gt.p2new) then
232      t = p1new
233      p1new = p2new
234      p2new = t
235      t = p1off
236      p1off = p2off
237      p2off = t
238      dsmult=-1.0d0*dsmult
239      end if
240
241      if(h1new.gt.h2new) then
242      t = h1new
243      h1new = h2new
244      h2new = t
245      t = h1off
246      h1off = h2off
247      h2off = t
248      dsmult=-1.0d0*dsmult
249      end if
250
251        if((p1new.le.noabn).or.
252     1     (p2new.le.noabn).or.
253     2     (h1new.gt.noabn).or.
254     3     (h2new.gt.noabn)) then !goto 111
255            totaloff=-1
256c           ihash=-1
257        endif
258
259       ihash = h2new-1+noabn*(h1new-1+noabn *(p2new-noabn-1+nvabn
260     1 *(p1new-noabn-1)))
261
262        ilength = int_mb(k_r2_offsetm(jref))
263        totaloff = -1
264
265        do k = 1, ilength
266          if(int_mb(k_r2_offsetm(jref)+k).eq.ihash) then
267             totaloff = 1
268            goto 113
269          endif
270        enddo
271 113     continue
272
273c      if(totaloff.eq.-1) goto 111
274      if(totaloff.ne.-1)then
275         ioff = p1off*int_mb(k_rangem(jref)+h2new-1)*
276     1 int_mb(k_rangem(jref)+h1new-1)*
277     2 int_mb(k_rangem(jref)+p2new-1)+
278     2 p2off*int_mb(k_rangem(jref)+h2new-1)*
279     3 int_mb(k_rangem(jref)+h1new-1)+
280     4 h1off*int_mb(k_rangem(jref)+h2new-1)+h2off
281
282
283       sizenew = int_mb(k_rangem(jref)+p1new-1)*
284     1 int_mb(k_rangem(jref)+p2new-1)*
285     2 int_mb(k_rangem(jref)+h1new-1)*
286     3 int_mb(k_rangem(jref)+h2new-1)
287
288      if (.not.ma_push_get(mt_dbl,sizenew,'tmp1',l_tmp1,k_tmp1))
289     1       call errquit('tce_uss: MA problem',3,MA_ERR)
290
291        CALL DFILL(sizenew,0.0d0,dbl_mb(k_tmp1),1)
292
293      dbl_mb(k_tmp1+ioff)=dbl_mb(k_r1a+counter-1)*dsmult
294
295      call add_hash_block(d_c2,dbl_mb(k_tmp1),sizenew,
296     1   int_mb(k_r2_offsetm(jref)),ihash)
297
298      if (.not.ma_pop_stack(l_tmp1))
299     1    call errquit('tce_uss: MA problem',4,MA_ERR)
300        endif !totaloff
301cccc
302       if(((espin(1).eq.espin(2)).and.(espin(3).eq.espin(4)))
303     1  .and.(((wtp.ge.0).and.(p1new.eq.p2new)).or.((wth.ge.0).and.
304     1  (h1new.eq.h2new)))) then
305        fact=1.d0
306       else
307       fact=1.d0
308       endif
309        dsmult=-1.0d0*dsmult
310       if(wtp.ge.0) then
311
312       p1new1=p2new
313       p2new1=p1new
314       h1new1=h1new
315       h2new1=h2new
316       p1off1=p2off
317       p2off1=p1off
318       h1off1=h1off
319       h2off1=h2off
320
321      if(p1new1.gt.p2new1) then
322      t = p1new1
323      p1new1 = p2new1
324      p2new1 = t
325      t = p1off1
326      p1off1 = p2off1
327      p2off1 = t
328      end if
329
330      if(h1new1.gt.h2new1) then
331      t = h1new1
332      h1new1 = h2new1
333      h2new1 = t
334      t = h1off1
335      h1off1 = h2off1
336      h2off1 = t
337      end if
338       ihashold = h2new1-1+noabn*(h1new1-1+noabn *(p2new1-noabn-1+nvabn
339     1 *(p1new1-noabn-1)))
340
341        ilength = int_mb(k_r2_offsetm(jref))
342        totaloff = -1
343
344        do k = 1, ilength
345          if(int_mb(k_r2_offsetm(jref)+k).eq.ihashold) then
346             totaloff = 1
347            goto 114
348          endif
349        enddo
350 114     continue
351
352
353        if((p1new1.le.noabn).or.
354     1     (p2new1.le.noabn).or.
355     2     (h1new1.gt.noabn).or.
356     3     (h2new1.gt.noabn)) then !goto 111
357           totaloff=-1
358        endif
359
360      if(totaloff.ne.-1)then
361
362         ioff1 = p1off1*int_mb(k_rangem(jref)+h2new1-1)*
363     1 int_mb(k_rangem(jref)+h1new1-1)*
364     2 int_mb(k_rangem(jref)+p2new1-1)+
365     2 p2off1*int_mb(k_rangem(jref)+h2new1-1)*
366     3 int_mb(k_rangem(jref)+h1new1-1)+
367     4 h1off1*int_mb(k_rangem(jref)+h2new1-1)+h2off1
368
369       sizenew1 = int_mb(k_rangem(jref)+p1new1-1)*
370     1 int_mb(k_rangem(jref)+p2new1-1)*
371     2 int_mb(k_rangem(jref)+h1new1-1)*
372     3 int_mb(k_rangem(jref)+h2new1-1)
373
374        l_tmp1=0
375
376        if(ioff1.ne.ioff) then
377      if (.not.ma_push_get(mt_dbl,sizenew1,'tmp1',l_tmp1,k_tmp1))
378     1       call errquit('tce_uss: MA problem',3,MA_ERR)
379
380
381        CALL DFILL(sizenew1,0.0d0,dbl_mb(k_tmp1),1)
382
383      dbl_mb(k_tmp1+ioff1)=dbl_mb(k_r1a+counter-1)*dsmult/fact
384
385      call add_hash_block(d_c2,dbl_mb(k_tmp1),sizenew1,
386     1   int_mb(k_r2_offsetm(jref)),h2new1-1+noabn*(h1new1-1+noabn *
387     1   (p2new1-noabn-1+nvabn*(p1new1-noabn-1))))
388
389      if (.not.ma_pop_stack(l_tmp1))
390     1    call errquit('tce_uss: MA problem',4,MA_ERR)
391         endif
392        endif !totaloff
393       endif
394
395       if(wth.ge.0) then
396       p1new1=p1new
397       p2new1=p2new
398       h1new1=h2new
399       h2new1=h1new
400       p1off1=p1off
401       p2off1=p2off
402       h1off1=h2off
403       h2off1=h1off
404
405      if(p1new1.gt.p2new1) then
406      t = p1new1
407      p1new1 = p2new1
408      p2new1 = t
409      t = p1off1
410      p1off1 = p2off1
411      p2off1 = t
412      end if
413
414      if(h1new1.gt.h2new1) then
415      t = h1new1
416      h1new1 = h2new1
417      h2new1 = t
418      t = h1off1
419      h1off1 = h2off1
420      h2off1 = t
421      end if
422
423       ihashold = h2new1-1+noabn*(h1new1-1+noabn *(p2new1-noabn-1+nvabn
424     1 *(p1new1-noabn-1)))
425
426        ilength = int_mb(k_r2_offsetm(jref))
427        totaloff = -1
428
429        do k = 1, ilength
430          if(int_mb(k_r2_offsetm(jref)+k).eq.ihashold) then
431             totaloff = 1
432            goto 115
433          endif
434        enddo
435 115     continue
436
437        if((p1new1.le.noabn).or.
438     1     (p2new1.le.noabn).or.
439     2     (h1new1.gt.noabn).or.
440     3     (h2new1.gt.noabn))then ! goto 111
441           totaloff=-1
442        endif
443
444
445      if(totaloff.ne.-1)then
446
447         ioff2 = p1off1*int_mb(k_rangem(jref)+h2new1-1)*
448     1 int_mb(k_rangem(jref)+h1new1-1)*
449     2 int_mb(k_rangem(jref)+p2new1-1)+
450     2 p2off1*int_mb(k_rangem(jref)+h2new1-1)*
451     3 int_mb(k_rangem(jref)+h1new1-1)+
452     4 h1off1*int_mb(k_rangem(jref)+h2new1-1)+h2off1
453
454       sizenew1 = int_mb(k_rangem(jref)+p1new1-1)*
455     1 int_mb(k_rangem(jref)+p2new1-1)*
456     2 int_mb(k_rangem(jref)+h1new1-1)*
457     3 int_mb(k_rangem(jref)+h2new1-1)
458
459        l_tmp1=0
460
461        if(ioff2.ne.ioff) then
462      if (.not.ma_push_get(mt_dbl,sizenew1,'tmp1',l_tmp1,k_tmp1))
463     1       call errquit('tce_uss: MA problem',3,MA_ERR)
464
465
466        CALL DFILL(sizenew1,0.0d0,dbl_mb(k_tmp1),1)
467
468      dbl_mb(k_tmp1+ioff2)=dbl_mb(k_r1a+counter-1)*dsmult/fact
469
470      call add_hash_block(d_c2,dbl_mb(k_tmp1),sizenew1,
471     1   int_mb(k_r2_offsetm(jref)),h2new1-1+noabn*(h1new1-1+noabn *
472     1   (p2new1-noabn-1+nvabn*(p1new1-noabn-1))))
473
474      if (.not.ma_pop_stack(l_tmp1))
475     1    call errquit('tce_uss: MA problem',4,MA_ERR)
476         endif
477        endif !totaloff
478        endif
479c
480
481           endif
482cc       endif!all same spin
483ccccc
484!
485111    continue
486       end do
487       end do
488!
489        if (.not.ma_pop_stack(l_r1a))
490     1  call errquit('tce_uss: MA problem',2,MA_ERR)
491
492
493      end if
494      end if
495      end if
496      if(lusesub) then
497       next = NXTASKsub(nprocs,1,mypgid)
498      else
499       next = NXTASK(nprocs, 1)
500      endif
501      END IF
502      count = count + 1
503!
504      END DO
505      END DO
506!
507      if(lusesub) then
508       next = NXTASKsub(-nprocs,1,mypgid)
509       call GA_pgroup_SYNC(mypgid)
510      else
511       next = NXTASK(-nprocs, 1)
512       call GA_SYNC()
513      endif
514
515      return
516      end
517c
518