1      subroutine uccsdt_triples_amplitudes(d_amp, spina, spinc)
2      implicit none
3#include "errquit.fh"
4#include "cuccsdtP.fh"
5#include "global.fh"
6#include "mafdecls.fh"
7#include "amplitudes.fh"
8      integer ind, list,
9     &     max_lenia, symkc, lenkc, l_t2, k_t2, symia,
10     &     a, alo, ahi, syma, asub, asublo, asubhi, asubdim, spina,
11     &     b, blo, bhi, symb, bsub, bsublo, bsubhi, bsubdim, spinb,
12     &     c, clo, chi, symc, csub, csublo, csubhi, csubdim, spinc,
13     &     e, elo, ehi, syme, esub, esublo, esubhi, esubdim, spine,
14     &     i, ilo, ihi, symi, isub, isublo, isubhi, isubdim, spini,
15     &     j, jlo, jhi, symj, jsub, jsublo, jsubhi, jsubdim, spinj,
16     &     k, klo, khi, symk, ksub, ksublo, ksubhi, ksubdim, spink,
17     &     m, mlo, mhi, symm, msub, msublo, msubhi, msubdim, spinm,
18     $     nproc, me, ei, cik, ma, kbc, mb, ia, ek, aki, l, lenia,
19     $     symib, symie, symke, symmc, lenke, kc, max_lenke,
20     $     ptr, d_amp, g_t2, kac, offset, actual_lenkc, actual_lenia,
21     $     mc, ica, actual_lenib, ib, bki, icb,
22     $     max_lenje, symje, lenje, symmb, aji, ej, iab, bji
23
24      double precision buf(1000)
25c
26c     Offset maps a 4-d array into a 1-d array.  It is used to look up
27c     ptr(ind,i,j,k,l) where ptr is dimensioned ptr(2,dim1,dim2,dim3,dim4)
28c     with dim1-4 = listinfo(6-9,list)
29c
30      offset(ind,i,j,k,l,list) =
31     $     ind-1 +
32     $     2*(i-1 +
33     $     listinfo(6,list)*(j-1 +
34     $     listinfo(7,list)*(k-1 +
35     $     listinfo(8,list)*(l-1))))
36c
37c     t(ia,kc)
38c
39      spink = spinc
40      spini = spina
41      spinb = spina
42      spine = spina
43c
44c     get local memory of size max "lenkc"
45c
46      max_lenia = 0
47      do symia = 0,7
48        lenia = ov_len(symia,spini,spina)
49        if (lenia.gt.max_lenia)max_lenia = lenia
50      enddo
51      if(.not.ma_push_get(mt_dbl,max_lenia,'t2',l_t2,k_t2))
52     $     call errquit('t2s: t2?',max_lenia, MA_ERR)
53c
54      me = ga_nodeid()
55      nproc = ga_nnodes()
56c
57c     loop over symkc
58c
59      alo = asuper(1)
60      ahi = asuper(2)
61      blo = bsuper(1)
62      bhi = bsuper(2)
63      clo = csuper(1)
64      chi = csuper(2)
65      ilo = nc(spini) + 1
66      ihi = nc(spini) + no(spini)
67      do symkc = 0,7
68        symia = symkc
69        symib = symkc
70        symie = symkc
71        lenia = ov_len(symia,spini,spina)
72        actual_lenkc = ov_off(chi+1,symkc,spink,spinc) -
73     $       ov_off(clo,symkc,spink,spinc)
74        if(actual_lenkc.gt.0.and.lenia.gt.0) then
75          if (.not.uccsdt_ampfile_read_t2(d_amp,
76     $         spini, spina, spink, spinc, symkc, clo, chi,
77     $         g_t2, .true., 'column'))
78     $         call errquit('amp_read_t2: reading t2 failed', d_amp,
79     &       DISK_ERR)
80          kc = 1
81          do c = clo, chi
82            csub = cblock_inv(c)
83            csublo = cblock(1,csub)
84            csubdim = cblock(2,csub) - cblock(1,csub) + 1
85            symc = cblock(3,csub)
86            symk = ieor(symkc,symc)
87            do k = o_sym(1,symk,spink), o_sym(2,symk,spink)
88              IF (MOD(KC,NPROC).eq.ME) THEN
89                ksub = oblock_inv(k,spink)
90                ksublo = oblock(1,ksub,spink)
91                ksubdim = oblock(2,ksub,spink) -
92     $               oblock(1,ksub,spink) + 1
93                call ga_get(g_t2,1,lenia,kc,kc,dbl_mb(k_t2),1)
94c               if (.not.ma_verify_allocator_stuff())
95c               $               call errquit(' after ga ',0)
96c
97c               14.  t(e,c,i,k) spin(e)=spin(a) mixed = t(a,c,i,k)
98c
99                do i = ilo, ihi
100                  isub = oblock_inv(i,spini)
101                  isublo = oblock(1,isub,spini)
102                  isubdim = oblock(2,isub,spini) -
103     $                 oblock(1,isub,spini) + 1
104                  symi = oblock(3,isub,spini)
105                  syme = ieor(symie,symi)
106                  esublo = v_sym(1,syme,spine)
107                  esubhi = v_sym(2,syme,spine)
108                  esubdim = esubhi - esublo + 1
109                  if (esubdim.gt.0)then
110                    cik = (c-csublo + csubdim*(i-isublo +
111     $                   isubdim*(k-ksublo)))
112                    list = 14
113                    ptr = int_mb(listinfo(2,list) +
114     $                   offset(1,1,csub,isub,ksub,list))
115                    ptr = ptr + esubdim*cik
116                    ei = k_t2 + ov_off(esublo,symie,spini,spine) +
117     $                   i - o_sym(1,symi,spini)
118                    call dfill(1000, 0.0d0, buf, 1)
119                    do e = 1, esubdim
120                      buf(e) = dbl_mb(ei+(e-1)*no_sym(symi,spini))
121                    enddo
122                    call ga_put(listinfo(5,list),ptr,
123     $                   ptr+esubdim-1,1,1,buf,1)
124                  endif
125                enddo
126c
127c               20.  t(m,k,a,c) spin(m)=spin(a) mixed = t(i,a,k,c)  m=i
128c
129                do a = alo, ahi
130                  asub = ablock_inv(a)
131                  asublo = ablock(1,asub)
132                  asubdim = ablock(2,asub) - ablock(1,asub) + 1
133                  syma = ablock(3,asub)
134                  symm = ieor(symia,syma)
135                  spinm = spini
136                  msublo = o_sym(1,symm,spinm)
137                  msubhi = o_sym(2,symm,spinm)
138                  msubdim = msubhi - msublo + 1
139                  if (msubdim.gt.0)then
140                    kac = (k-ksublo + ksubdim*(a-asublo +
141     $                   asubdim*(c-csublo)))
142                    list = 20
143                    ptr = int_mb(listinfo(2,list) +
144     $                   offset(1,1,ksub,asub,csub,list))
145                    ptr = ptr + msubdim*kac
146                    ma = k_t2 + ov_off(a,symia,spini,spina)
147                    call ga_put(listinfo(5,list),ptr,
148     $                   ptr+msubdim-1,1,1,dbl_mb(ma),1)
149                  endif
150                enddo
151c
152c               21.  t(m,k,b,c) spin(m)=spin(b) mixed = t(i,a,k,c)  m=i
153c
154                do b = blo, bhi
155                  bsub = bblock_inv(b)
156                  bsublo = bblock(1,bsub)
157                  bsubdim = bblock(2,bsub) - bblock(1,bsub) + 1
158                  symb = bblock(3,bsub)
159                  symm = ieor(symib,symb)
160                  spinm = spini
161                  msublo = o_sym(1,symm,spinm)
162                  msubhi = o_sym(2,symm,spinm)
163                  msubdim = msubhi - msublo + 1
164                  if (msubdim.gt.0)then
165                    kbc = (k-ksublo + ksubdim*(b-bsublo +
166     $                   bsubdim*(c-csublo)))
167                    list = 21
168                    ptr = int_mb(listinfo(2,list) +
169     $                   offset(1,1,ksub,bsub,csub,list))
170                    ptr = ptr + msubdim*kbc
171                    mb = k_t2 + ov_off(b,symib,spini,spinb)
172                    call ga_put(listinfo(5,list),ptr,
173     $                   ptr+msubdim-1,1,1,dbl_mb(mb),1)
174                  endif
175                enddo
176              ENDIF             ! end parallel work
177              kc = kc + 1
178            enddo
179          enddo
180          if (.not. ga_destroy(g_t2))
181     $         call errquit('t2s: ga_destroy?',1, GA_ERR)
182        endif
183      enddo
184      if (.not. ma_pop_stack(l_t2))
185     $     call errquit('t2s: ma_pop_stack?',1, MA_ERR)
186c
187c     get local memory of size max "lenkc"
188c
189      spine = spink
190      max_lenke = 0
191      do symke = 0,7
192        lenke = ov_len(symke,spink,spine)
193        if (lenke.gt.max_lenke)max_lenke = lenke
194      enddo
195      if(.not.ma_push_get(mt_dbl,max_lenke,'t2',l_t2,k_t2))
196     $     call errquit('t2s: t2?',max_lenke, MA_ERR)
197c
198      klo = nc(spink) + 1
199      khi = nc(spink) + no(spink)
200      do symia = 0,7
201        symke = symia
202        symmc = symia
203        lenke = ov_len(symke,spink,spine)
204        actual_lenia = ov_off(ahi+1,symia,spini,spina) -
205     $       ov_off(alo,symia,spini,spina)
206        if(actual_lenia.gt.0.and.lenke.gt.0) then
207          if (.not.uccsdt_ampfile_read_t2(d_amp,
208     $         spink, spine, spini, spina, symia, alo, ahi,
209     $         g_t2, .true., 'column'))
210     $         call errquit('amp_read_t2: reading t2 failed', d_amp,
211     &       DISK_ERR)
212          ia = 1
213          do a = alo, ahi
214            asub = ablock_inv(a)
215            asublo = ablock(1,asub)
216            asubdim = ablock(2,asub) - ablock(1,asub) + 1
217            syma = ablock(3,asub)
218            symi = ieor(symia,syma)
219            do i = o_sym(1,symi,spini), o_sym(2,symi,spini)
220              IF (MOD(IA,NPROC).eq.ME) THEN
221                isub = oblock_inv(i,spini)
222                isublo = oblock(1,isub,spini)
223                isubdim = oblock(2,isub,spini) -
224     $               oblock(1,isub,spini) + 1
225                call ga_get(g_t2,1,lenke,ia,ia,dbl_mb(k_t2),1)
226c               if (.not.ma_verify_allocator_stuff())
227c               $               call errquit(' after ga ',0)
228c
229c               17.  t(e,a,k,i) spin(e)=spin(k) mixed = t(k,e,i,a)
230c
231                do k = klo, khi
232                  ksub = oblock_inv(k,spink)
233                  ksublo = oblock(1,ksub,spink)
234                  ksubdim = oblock(2,ksub,spink) -
235     $                 oblock(1,ksub,spink) + 1
236                  symk = oblock(3,ksub,spink)
237                  syme = ieor(symke,symk)
238                  esublo = v_sym(1,syme,spine)
239                  esubhi = v_sym(2,syme,spine)
240                  esubdim = esubhi - esublo + 1
241                  if (esubdim.gt.0)then
242                    aki = (a-asublo + asubdim*(k-ksublo +
243     $                   ksubdim*(i-isublo)))
244                    list = 17
245                    ptr = int_mb(listinfo(2,list) +
246     $                   offset(1,1,asub,ksub,isub,list))
247                    ptr = ptr + esubdim*aki
248                    ek = k_t2 + ov_off(esublo,symke,spink,spine) +
249     $                   k - o_sym(1,symk,spink)
250                    call dfill(1000, 0.0d0, buf, 1)
251                    do e = 1, esubdim
252                      buf(e) = dbl_mb(ek+(e-1)*no_sym(symk,spink))
253                    enddo
254                    call ga_put(listinfo(5,list),ptr,
255     $                   ptr+esubdim-1,1,1,buf,1)
256                  endif
257                enddo
258c
259c               22.  t(m,i,c,a) spin(m)=spin(c) mixed = t(m,c,i,a)
260c
261                do c = clo, chi
262                  csub = cblock_inv(c)
263                  csublo = cblock(1,csub)
264                  csubdim = cblock(2,csub) - cblock(1,csub) + 1
265                  symc = cblock(3,csub)
266                  symm = ieor(symmc,symc)
267                  spinm = spinc
268                  msublo = o_sym(1,symm,spinm)
269                  msubhi = o_sym(2,symm,spinm)
270                  msubdim = msubhi - msublo + 1
271                  if (msubdim.gt.0)then
272                    ica = (i-isublo + isubdim*(c-csublo +
273     $                   csubdim*(a-asublo)))
274                    list = 22
275                    ptr = int_mb(listinfo(2,list) +
276     $                   offset(1,1,isub,csub,asub,list))
277                    ptr = ptr + msubdim*ica
278                    mc = k_t2 + ov_off(c,symmc,spinm,spinc)
279                    call ga_put(listinfo(5,list),ptr,
280     $                   ptr+msubdim-1,1,1,dbl_mb(mc),1)
281                  endif
282                enddo
283              ENDIF             ! end parallel work
284              ia = ia + 1
285            enddo
286          enddo
287          if (.not. ga_destroy(g_t2))
288     $         call errquit('t2s: ga_destroy?',1, GA_ERR)
289        endif
290      enddo
291c
292      do symib = 0,7
293        symke = symib
294        symmc = symib
295        lenke = ov_len(symke,spink,spine)
296        actual_lenib = ov_off(bhi+1,symib,spini,spinb) -
297     $       ov_off(blo,symib,spini,spinb)
298        if(actual_lenib.gt.0.and.lenke.gt.0) then
299          if (.not.uccsdt_ampfile_read_t2(d_amp,
300     $         spink, spine, spini, spinb, symib, blo, bhi,
301     $         g_t2, .true., 'column'))
302     $         call errquit('amp_read_t2: reading t2 failed', d_amp,
303     &       DISK_ERR)
304          ib = 1
305          do b = blo, bhi
306            bsub = bblock_inv(b)
307            bsublo = bblock(1,bsub)
308            bsubdim = bblock(2,bsub) - bblock(1,bsub) + 1
309            symb = bblock(3,bsub)
310            symi = ieor(symib,symb)
311            do i = o_sym(1,symi,spini), o_sym(2,symi,spini)
312              IF (MOD(IB,NPROC).eq.ME) THEN
313                isub = oblock_inv(i,spini)
314                isublo = oblock(1,isub,spini)
315                isubdim = oblock(2,isub,spini) -
316     $               oblock(1,isub,spini) + 1
317                call ga_get(g_t2,1,lenke,ib,ib,dbl_mb(k_t2),1)
318c               if (.not.ma_verify_allocator_stuff())
319c               $               call errquit(' after ga ',0)
320c
321c               18.  t(e,b,k,i) spin(e)=spin(k) mixed = t(k,e,i,b)
322c
323                do k = klo, khi
324                  ksub = oblock_inv(k,spink)
325                  ksublo = oblock(1,ksub,spink)
326                  ksubdim = oblock(2,ksub,spink) -
327     $                 oblock(1,ksub,spink) + 1
328                  symk = oblock(3,ksub,spink)
329                  syme = ieor(symke,symk)
330                  esublo = v_sym(1,syme,spine)
331                  esubhi = v_sym(2,syme,spine)
332                  esubdim = esubhi - esublo + 1
333                  if (esubdim.gt.0)then
334                    bki = (b-bsublo + bsubdim*(k-ksublo +
335     $                   ksubdim*(i-isublo)))
336                    list = 18
337                    ptr = int_mb(listinfo(2,list) +
338     $                   offset(1,1,bsub,ksub,isub,list))
339                    ptr = ptr + esubdim*bki
340                    ek = k_t2 + ov_off(esublo,symke,spink,spine) +
341     $                   k - o_sym(1,symk,spink)
342                    call dfill(1000, 0.0d0, buf, 1)
343                    do e = 1, esubdim
344                      buf(e) = dbl_mb(ek+(e-1)*no_sym(symk,spink))
345                    enddo
346                    call ga_put(listinfo(5,list),ptr,
347     $                   ptr+esubdim-1,1,1,buf,1)
348                  endif
349                enddo
350c
351c               23.  t(m,i,c,b) spin(m)=spin(c) mixed = t(m,c,i,b)
352c
353                do c = clo, chi
354                  csub = cblock_inv(c)
355                  csublo = cblock(1,csub)
356                  csubdim = cblock(2,csub) - cblock(1,csub) + 1
357                  symc = cblock(3,csub)
358                  symm = ieor(symmc,symc)
359                  spinm = spinc
360                  msublo = o_sym(1,symm,spinm)
361                  msubhi = o_sym(2,symm,spinm)
362                  msubdim = msubhi - msublo + 1
363                  if (msubdim.gt.0)then
364                    icb = (i-isublo + isubdim*(c-csublo +
365     $                   csubdim*(b-bsublo)))
366                    list = 23
367                    ptr = int_mb(listinfo(2,list) +
368     $                   offset(1,1,isub,csub,bsub,list))
369                    ptr = ptr + msubdim*icb
370                    mc = k_t2 + ov_off(c,symmc,spinm,spinc)
371                    call ga_put(listinfo(5,list),ptr,
372     $                   ptr+msubdim-1,1,1,dbl_mb(mc),1)
373                  endif
374                enddo
375              ENDIF             ! end parallel work
376              ib = ib + 1
377            enddo
378          enddo
379          if (.not. ga_destroy(g_t2))
380     $         call errquit('t2s: ga_destroy?',1, GA_ERR)
381        endif
382      enddo
383
384      if (.not. ma_pop_stack(l_t2))
385     $     call errquit('t2s: ma_pop_stack?',1, MA_ERR)
386
387c
388c     get local memory of size max "lenkc"
389c
390      spinj = spini
391      spine = spinj
392      max_lenje = 0
393      do symje = 0,7
394        lenje = ov_len(symje,spinj,spine)
395        if (lenje.gt.max_lenje)max_lenje = lenje
396      enddo
397      if(.not.ma_push_get(mt_dbl,max_lenje,'t2',l_t2,k_t2))
398     $     call errquit('t2s: t2?',max_lenje, MA_ERR)
399c
400      jlo = nc(spinj) + 1
401      jhi = nc(spinj) + no(spinj)
402      do symia = 0,7
403        symje = symia
404        symmb = symia
405        lenje = ov_len(symje,spinj,spine)
406        actual_lenia = ov_off(ahi+1,symia,spini,spina) -
407     $       ov_off(alo,symia,spini,spina)
408        if(actual_lenia.gt.0.and.lenje.gt.0) then
409          if (.not.uccsdt_ampfile_read_t2(d_amp,
410     $         spinj, spine, spini, spina, symia, alo, ahi,
411     $         g_t2, .true., 'column'))
412     $         call errquit('amp_read_t2: reading t2 failed', d_amp,
413     &       DISK_ERR)
414          ia = 1
415          do a = alo, ahi
416            asub = ablock_inv(a)
417            asublo = ablock(1,asub)
418            asubdim = ablock(2,asub) - ablock(1,asub) + 1
419            syma = ablock(3,asub)
420            symi = ieor(symia,syma)
421            do i = o_sym(1,symi,spini), o_sym(2,symi,spini)
422              IF (MOD(IA,NPROC).eq.ME) THEN
423                isub = oblock_inv(i,spini)
424                isublo = oblock(1,isub,spini)
425                isubdim = oblock(2,isub,spini) -
426     $               oblock(1,isub,spini) + 1
427                call ga_get(g_t2,1,lenje,ia,ia,dbl_mb(k_t2),1)
428c               if (.not.ma_verify_allocator_stuff())
429c               $               call errquit(' after ga ',0)
430c
431c               15.  t(e,a,j,i) spin(e)=spin(j) pure = t(j,e,i,a)
432c
433                do j = jlo, jhi
434                  jsub = oblock_inv(j,spinj)
435                  jsublo = oblock(1,jsub,spinj)
436                  jsubdim = oblock(2,jsub,spinj) -
437     $                 oblock(1,jsub,spinj) + 1
438                  symj = oblock(3,jsub,spinj)
439                  syme = ieor(symje,symj)
440                  esublo = v_sym(1,syme,spine)
441                  esubhi = v_sym(2,syme,spine)
442                  esubdim = esubhi - esublo + 1
443                  if (esubdim.gt.0)then
444                    aji = (a-asublo + asubdim*(j-jsublo +
445     $                   jsubdim*(i-isublo)))
446                    list = 15
447                    ptr = int_mb(listinfo(2,list) +
448     $                   offset(1,1,asub,jsub,isub,list))
449                    ptr = ptr + esubdim*aji
450                    ej = k_t2 + ov_off(esublo,symje,spinj,spine) +
451     $                   j - o_sym(1,symj,spinj)
452                    call dfill(1000, 0.0d0, buf, 1)
453                    do e = 1, esubdim
454                      buf(e) = dbl_mb(ej+(e-1)*no_sym(symj,spinj))
455                    enddo
456                    call ga_put(listinfo(5,list),ptr,
457     $                   ptr+esubdim-1,1,1,buf,1)
458                  endif
459                enddo
460c
461c               19.  t(m,i,a,b) pure spin = -t(m,b,i,a)
462c
463                do b = blo, bhi
464                  bsub = bblock_inv(b)
465                  bsublo = bblock(1,bsub)
466                  bsubdim = bblock(2,bsub) - bblock(1,bsub) + 1
467                  symb = bblock(3,bsub)
468                  symm = ieor(symmb,symb)
469                  spinm = spinb
470                  msublo = o_sym(1,symm,spinm)
471                  msubhi = o_sym(2,symm,spinm)
472                  msubdim = msubhi - msublo + 1
473                  if (msubdim.gt.0)then
474                    iab = (i-isublo + isubdim*(a-asublo +
475     $                   asubdim*(b-bsublo)))
476                    list = 19
477                    ptr = int_mb(listinfo(2,list) +
478     $                   offset(1,1,isub,asub,bsub,list))
479                    ptr = ptr + msubdim*iab
480                    mb = k_t2 + ov_off(b,symmb,spinm,spinb)
481                    call dscal(msubdim,-1.0d0,dbl_mb(mb),1)
482                    call ga_put(listinfo(5,list),ptr,
483     $                   ptr+msubdim-1,1,1,dbl_mb(mb),1)
484                    call dscal(msubdim,-1.0d0,dbl_mb(mb),1)
485                  endif
486                enddo
487              ENDIF             ! end parallel work
488              ia = ia + 1
489            enddo
490          enddo
491          if (.not. ga_destroy(g_t2))
492     $         call errquit('t2s: ga_destroy?',1, GA_ERR)
493        endif
494      enddo
495      do symib = 0,7
496        symje = symib
497        symmb = symib
498        lenje = ov_len(symje,spinj,spine)
499        actual_lenib = ov_off(bhi+1,symib,spini,spinb) -
500     $       ov_off(blo,symib,spini,spinb)
501        if(actual_lenib.gt.0.and.lenje.gt.0) then
502          if (.not.uccsdt_ampfile_read_t2(d_amp,
503     $         spinj, spine, spini, spinb, symib, blo, bhi,
504     $         g_t2, .true., 'column'))
505     $         call errquit('amp_read_t2: reading t2 failed', d_amp,
506     &       DISK_ERR)
507          ib = 1
508          do b = blo, bhi
509            bsub = bblock_inv(b)
510            bsublo = bblock(1,bsub)
511            bsubdim = bblock(2,bsub) - bblock(1,bsub) + 1
512            symb = bblock(3,bsub)
513            symi = ieor(symib,symb)
514            do i = o_sym(1,symi,spini), o_sym(2,symi,spini)
515              IF (MOD(IB,NPROC).eq.ME) THEN
516                isub = oblock_inv(i,spini)
517                isublo = oblock(1,isub,spini)
518                isubdim = oblock(2,isub,spini) -
519     $               oblock(1,isub,spini) + 1
520                call ga_get(g_t2,1,lenje,ib,ib,dbl_mb(k_t2),1)
521c               if (.not.ma_verify_allocator_stuff())
522c               $               call errquit(' after ga ',0)
523c
524c               16.  t(e,b,j,i) spin(e)=spin(j) pure = t(j,e,i,b)
525c
526                do j = jlo, jhi
527                  jsub = oblock_inv(j,spinj)
528                  jsublo = oblock(1,jsub,spinj)
529                  jsubdim = oblock(2,jsub,spinj) -
530     $                 oblock(1,jsub,spinj) + 1
531                  symj = oblock(3,jsub,spinj)
532                  syme = ieor(symje,symj)
533                  esublo = v_sym(1,syme,spine)
534                  esubhi = v_sym(2,syme,spine)
535                  esubdim = esubhi - esublo + 1
536                  if (esubdim.gt.0)then
537                    bji = (b-bsublo + bsubdim*(j-jsublo +
538     $                   jsubdim*(i-isublo)))
539                    list = 16
540                    ptr = int_mb(listinfo(2,list) +
541     $                   offset(1,1,bsub,jsub,isub,list))
542                    ptr = ptr + esubdim*bji
543                    ej = k_t2 + ov_off(esublo,symje,spinj,spine) +
544     $                   j - o_sym(1,symj,spinj)
545                    call dfill(1000, 0.0d0, buf, 1)
546                    do e = 1, esubdim
547                      buf(e) = dbl_mb(ej+(e-1)*no_sym(symj,spinj))
548                    enddo
549                    call ga_put(listinfo(5,list),ptr,
550     $                   ptr+esubdim-1,1,1,buf,1)
551                  endif
552                enddo
553              ENDIF             ! end parallel work
554              ib = ib + 1
555            enddo
556          enddo
557          if (.not. ga_destroy(g_t2))
558     $         call errquit('t2s: ga_destroy?',1, GA_ERR)
559        endif
560      enddo
561      if (.not. ma_pop_stack(l_t2))
562     $     call errquit('t2s: ma_pop_stack?',1, MA_ERR)
563c
564      end
565
566c $Id$
567