1c      SUBROUTINE tce_mrcc_c1_offset(size_t1m,nref,k_t1_offsetm,d_t1m)
2      SUBROUTINE tce_mrcc_c1_offset(k_t1_offsetm,d_t1m,
3     1 iref,irefnew,d_c)
4ctce_mrcc_c1_offset(k_t1_offsetm,d_t1m,iref,irefnew,d_t1c)
5      IMPLICIT NONE
6#include "global.fh"
7#include "mafdecls.fh"
8#include "sym.fh"
9#include "errquit.fh"
10#include "util.fh"
11#include "msgids.fh"
12#include "tce.fh"
13#include "tce_main.fh"
14#include "tce_mrcc.fh"
15
16      integer nprocs
17      double precision ga_dble
18      double precision ma_dble
19      integer d_off1m(maxref)
20      integer nodezero
21      integer size,sizenew
22      character*255 modelname
23      character*255 filename
24      character*3 namechunk
25      integer iref
26      integer size_t1m(maxref)
27      integer k_t1_offsetm(maxref)
28      integer l_c1,k_c1
29      integer p5b,h6b
30      integer mems
31      integer i,j,k
32      integer orbindex(2)
33      integer orbindexnew(2)
34      integer orbspin(2)
35      integer irefnew,hnew,pnew
36      integer hoff,poff
37      integer totaloff
38      integer ihash,ilength
39      integer ioff
40      integer l_t1,k_t1
41      integer l_tmp,k_tmp
42      integer d_t1m(maxref)
43      integer counter
44      integer k_a,l_a
45      integer d_c
46      integer inoabn
47      integer x,y,z
48      character*1  s,r
49      INTEGER NXTASK
50      EXTERNAL NXTASK
51      INTEGER NXTASKsub
52      EXTERNAL NXTASKsub
53      integer next,count
54      integer t
55      double precision sign
56      integer isw1,isw2
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
73c
74c ------------------
75c  allocate arrays
76c ------------------
77c
78c       if(nodezero) then
79c          write(6,*)'Start of tce_mrcc_c1_offset'
80c       endif
81c print input arrays
82c       do i=1,nref*nref
83c         write(6,*)dbl_mb(k_sqc+i-1),dbl_mb(k_heff+i-1)
84c       enddo
85c create file
86
87c        do iref=1,nref
88c           write(namechunk,"(I3.3)")iref
89c           call tce_filename('off1'//namechunk,filename)
90c           call createfile(filename,d_off1m(iref),size_t1m(iref))
91c           call reconcilefile(d_off1m(iref),size_t1m(iref))
92c        enddo
93c working arrays
94
95c        iref = 1
96c        mems = 0
97
98          do p5b = nblcks(1,iref)+nblcks(2,iref)+1,nblcks(1,iref)+
99     1 nblcks(2,iref)+nblcks(3,iref)+nblcks(4,iref)
100          do h6b = 1,nblcks(1,iref)+nblcks(2,iref)
101
102      IF (next.eq.count) THEN
103
104      if (int_mb(k_spinm(iref)+p5b-1) .eq.
105     1 int_mb(k_spinm(iref)+h6b-1)) then
106      if (ieor(int_mb(k_symm(iref)+p5b-1),int_mb(k_symm(iref)+h6b-1))
107     1 .eq. irrep_t) then
108      if ((.not.restricted).or.(int_mb(k_spinm(iref)+p5b-1)+
109     1 int_mb(k_spinm(iref)+h6b-1).ne.4)) THEN
110
111c        write(6,"('Block assigned',I4,I4,' TO ',I3)")
112c     1p5b,h6b,ga_nodeid()
113
114         size = int_mb(k_rangem(iref)+p5b-1) *
115     1 int_mb(k_rangem(iref)+h6b-1)
116
117c              if (.not.ma_push_get(mt_dbl,size,'t1',l_t1,k_t1))
118c     1          call errquit('tce_c1_offs: MA problem',0,MA_ERR)
119
120              if (.not.ma_push_get(mt_dbl,size,'c1',l_a,k_a))
121     1          call errquit('tce_c1_offs: MA problem',1,MA_ERR)
122
123c              call get_hash_block(d_t1m(iref),dbl_mb(k_t1),size,
124c     1          int_mb(k_t1_offsetm(iref)),((p5b-noab-1)*noab+h6b-1))
125
126         counter = 0
127
128         do i=1,int_mb(k_rangem(iref)+p5b-1)
129           do j=1,int_mb(k_rangem(iref)+h6b-1)
130           orbspin(2) = int_mb(k_spinm(iref)+h6b-1)-1
131           orbspin(1) = int_mb(k_spinm(iref)+p5b-1)-1
132
133             dbl_mb(k_a+counter) = 0.0d0
134             counter = counter + 1
135
136c             do irefnew=1,nref
137c             if(irefnew.ne.iref) then
138
139        isw1 = int_mb(k_offsetm(iref)+h6b-1)+j
140
141             orbindex(1) = (1 - orbspin(1)+
142     1 int_mb(k_mo_indexm(iref)+int_mb(k_offset+p5b-1)+i-1))/2
143             orbindex(2) = (1 - orbspin(2)+
144     1 int_mb(k_mo_indexm(iref)+int_mb(k_offset+h6b-1)+j-1))/2
145c
146
147        orbindexnew(1) = moindexes(orbindex(1),orbspin(1)+1,iref)
148        orbindexnew(2) = moindexes(orbindex(2),orbspin(2)+1,iref)
149
150        orbindexnew(1) = moindexes(orbindexnew(1),orbspin(1)+1,irefnew)
151        orbindexnew(2) = moindexes(orbindexnew(2),orbspin(2)+1,irefnew)
152
153c         orbindexnew(1) = orbindex(1)
154c         orbindexnew(2) = orbindex(2)
155
156c        if((orbindex(1).ne.orbindexnew(1)).or.
157c     1     (orbindex(2).ne.orbindexnew(2))) then
158c        write(6,"(I2,'/',I2,'(',I5,',',I5,')','->','(',I5,',',I5,')')")
159c     1iref,irefnew,orbindex(1),orbindex(2),orbindexnew(1),orbindexnew(2)
160
161        inoabn = nblcks(1,irefnew)+nblcks(2,irefnew)
162
163        hnew = orbinblck(orbindexnew(2),orbspin(2)+1,irefnew)
164        pnew = orbinblck(orbindexnew(1),orbspin(1)+1,irefnew)
165
166          totaloff=-1
167
168        hoff = offsetinblck(orbindexnew(2),orbspin(2)+1,irefnew)
169        poff = offsetinblck(orbindexnew(1),orbspin(1)+1,irefnew)
170
171        ihash = hnew - 1 + inoabn * (pnew - inoabn - 1)
172        ilength = int_mb(k_t1_offsetm(irefnew))
173        ioff = 0
174        totaloff = -1
175
176        do k = 1, ilength
177          if(int_mb(k_t1_offsetm(irefnew)+k).eq.ihash) then
178            totaloff = ioff
179            goto 111
180          endif
181c          ioff = int_mb(k_t1_offsetm(irefnew)+k+ilength)
182        enddo
183
184 111    continue
185
186        if((pnew.le.inoabn).or.
187     1  (hnew.gt.inoabn)) then
188          totaloff=-1
189        endif
190
191        if(totaloff.ne.-1) then
192         ioff = offsetinblck(orbindexnew(1),orbspin(1)+1,irefnew)*
193     1 int_mb(k_rangem(irefnew)+hnew-1)+
194     2 offsetinblck(orbindexnew(2),orbspin(2)+1,irefnew)
195
196       isw2 = int_mb(k_offsetm(irefnew)+hnew-1)+hoff
197
198c          if(orbspin(1).eq.0) then
199c            s='a'
200c          else
201c            s='b'
202c          endif
203c          if(orbspin(2).eq.0) then
204c            r='a'
205c          else
206c            r='b'
207c          endif
208
209c          write(6,"(I4,I4)")iref,irefnew
210c          write(6,"('[',I4,I4,']','(',I4,A1,I4,A1,')-->',
211c     1'(',I4,I4,')')")
212c     1 p5b,h6b,
213c     1 orbindex(1),s,orbindex(2),r,orbindexnew(1),orbindexnew(2)
214c      call util_flush(6)
215
216         sizenew = int_mb(k_rangem(irefnew)+pnew-1) *
217     1 int_mb(k_rangem(irefnew)+hnew-1)
218
219              if (.not.ma_push_get(mt_dbl,sizenew,'tmp',l_tmp,k_tmp))
220     1          call errquit('tce_c1_offs: MA problem',0,MA_ERR)
221              call get_hash_block(d_t1m(irefnew),dbl_mb(k_tmp),sizenew,
222     1          int_mb(k_t1_offsetm(irefnew)),
223     1 ((pnew-inoabn-1)*inoabn+hnew-1))
224c             write(6,*)(-dbl_mb(k_t1+counter-1)+dbl_mb(k_tmp+ioff))
225c k_heff is global, c(iref) missing!
226          sign=1.0d0
227c          if(mod((mod(isw1,2)+mod(isw2,2)),2).ne.0)sign=-1.0d0
228
229              dbl_mb(k_a+counter-1)=dbl_mb(k_tmp+ioff)*sign
230c              write(6,"('Counter ',I4,' pnew/hnew',I4,I4,2F16.12)")
231c     1 counter,pnew,hnew,dbl_mb(k_tmp+ioff)
232c      call util_flush(6)
233
234c*dbl_mb(k_heff+irefnew+(irefnew-1)*nref)*
235cdbl_mb(k_sqc+irefnew+(irefnew-1)*nref)
236
237              if (.not.ma_pop_stack(l_tmp))
238     1          call errquit('tce_c1_offs: MA problem',1,MA_ERR)
239        endif
240
241c         endif !nonzero C1
242
243c           endif
244c           enddo !irefnew
245         enddo
246         enddo
247
248         call put_hash_block(d_c,dbl_mb(k_a),size,
249     1   int_mb(k_t1_offsetm(iref)),((p5b-nblcks(1,iref)-nblcks(2,iref)
250     2 -1)*(nblcks(1,iref)+nblcks(2,iref))+h6b-1))
251
252c             call ma_print(dbl_mb(k_a),size,1,'C1')
253             if (.not.ma_pop_stack(l_a))
254     1          call errquit('tce_c1_offs: MA problem',2,MA_ERR)
255
256c             if (.not.ma_pop_stack(l_t1))
257c     1          call errquit('tce_c1_offs: MA problem',1,MA_ERR)
258
259      endif
260      endif
261      endif
262      if(lusesub) then
263       next = NXTASKsub(nprocs,1,mypgid)
264      else
265       next = NXTASK(nprocs, 1)
266      endif
267      END IF
268      count = count + 1
269
270          enddo ! h6b
271          enddo ! p5b
272
273      if(lusesub) then
274       next = NXTASKsub(-nprocs,1,mypgid)
275       call GA_pgroup_SYNC(mypgid)
276      else
277       next = NXTASK(-nprocs, 1)
278       call GA_SYNC()
279      endif
280
281c        write(6,"('Doubles:',I8,' Bytes:',I8)")mems,mems*8
282
283c computing offsets, offset files size equal size of amplitude files
284
285c         do
286c           do
287
288c           enddo
289c         enddo
290
291c purge memory
292
293c         if (.not.ma_pop_stack(l_c1))
294c     1       call errquit('tce_mrcc_c1: MA problem',1,MA_ERR)
295
296c delete file
297c        do iref=1,nref
298c           call deletefile(d_off1m(iref))
299c        enddo
300
301c       if(nodezero) then
302c          write(6,*)'End of procedure tce_mrcc_c1_offset'
303c       endif
304c
305c --------------------
306c  deallocate arrays
307c --------------------
308c
309
310c deleted
311
312      RETURN
313      END
314c $Id$
315