1      subroutine tce_mrcc_mul_1(alpha,d_a,beta,d_b,k_c_offset,d_c,iref)
2        implicit none
3#include "global.fh"
4#include "rtdb.fh"
5#include "mafdecls.fh"
6#include "sym.fh"
7#include "util.fh"
8#include "stdio.fh"
9#include "errquit.fh"
10#include "tce.fh"
11#include "tce_mrcc.fh"
12#include "tce_main.fh"
13
14      double precision alpha,beta
15      integer d_a,d_b,d_c
16      integer k_c_offset
17      integer nprocs
18      integer count
19      integer next
20      INTEGER NXTASK
21      EXTERNAL NXTASK
22      INTEGER NXTASKsub
23      EXTERNAL NXTASKsub
24      logical nodezero
25      integer iref
26      integer p1b,h2b,p1,h2
27      integer inoab,invab
28      integer size
29      integer k_a,k_b,k_c
30      integer l_a,l_b,l_c
31      integer i
32      logical noloadbalance
33
34      nodezero = (ga_nodeid().eq.0)
35      count = 0
36      if(lusesub) then
37      nprocs = ga_pgroup_nnodes(mypgid)
38      call ga_pgroup_sync(mypgid)
39      next = NXTASKsub(nprocs, 1,mypgid)
40      else
41      nprocs = ga_nnodes()
42      call ga_sync()
43      next = NXTASK(nprocs, 1)
44      endif
45      noloadbalance = ((ioalg.eq.4).or.
46     1                ((ioalg.eq.6).and.(.not.fileisga(d_c))))
47
48      inoab = nblcks(1,iref)+nblcks(2,iref)
49      invab = nblcks(3,iref)+nblcks(4,iref)
50
51      do p1b = inoab+1,inoab+invab
52        do h2b = 1,inoab
53
54          if (noloadbalance.or.(next.eq.count)) then
55
56            if (int_mb(k_spinm(iref)+p1b-1) .eq.
57     1  int_mb(k_spinm(iref)+h2b-1)) then
58            if ((.not.restricted).or.(int_mb(k_spinm(iref)+p1b-1)
59     1        +int_mb(k_spinm(iref)+h2b-1).ne.4)) then
60            if (ieor(int_mb(k_symm(iref)+p1b-1),
61     1 int_mb(k_symm(iref)+h2b-1)).eq.0) then
62
63              size = int_mb(k_rangem(iref)+p1b-1) *
64     1  int_mb(k_rangem(iref)+h2b-1)
65
66              if (.not.ma_push_get(mt_dbl,size,'a',l_a,k_a))
67     1          call errquit('tce_jacobi_t1: MA problem',0,MA_ERR)
68              if (.not.ma_push_get(mt_dbl,size,'b',l_b,k_b))
69     1          call errquit('tce_jacobi_t1: MA problem',0,MA_ERR)
70              if (.not.ma_push_get(mt_dbl,size,'c',l_c,k_c))
71     1          call errquit('tce_jacobi_t1: MA problem',0,MA_ERR)
72
73              call get_hash_block(d_a,dbl_mb(k_a),size,
74     1          int_mb(k_c_offset),((p1b-inoab-1)*inoab+h2b-1))
75
76              call get_hash_block(d_b,dbl_mb(k_b),size,
77     1          int_mb(k_c_offset),((p1b-inoab-1)*inoab+h2b-1))
78
79              i = 0
80
81              do p1 = 1,int_mb(k_rangem(iref)+p1b-1)
82                do h2 = 1,int_mb(k_rangem(iref)+h2b-1)
83                  i = i + 1
84                  dbl_mb(k_c+i-1) = alpha*dbl_mb(k_a+i-1)+
85     1                               beta*dbl_mb(k_b+i-1)
86c        write(6,"('alpha/beta',2F16.12,2F16.12)")alpha,beta
87c        write(6,"(I2,':',I4,I4,I4,I4,2F16.12,2F16.12,2F16.12)")
88c     1ga_nodeid(),p1b,h2b,i,iref,
89c     1 dbl_mb(k_a+i-1),dbl_mb(k_b+i-1),dbl_mb(k_c+i-1)
90                enddo
91              enddo
92
93              call put_hash_block(d_c,dbl_mb(k_c),size,
94     1          int_mb(k_c_offset),((p1b-inoab-1)*inoab+h2b-1))
95
96              if (.not.ma_pop_stack(l_c))
97     1          call errquit('tce_mrcc_mul: MA problem',1,MA_ERR)
98              if (.not.ma_pop_stack(l_b))
99     1          call errquit('tce_mrcc_mul: MA problem',1,MA_ERR)
100              if (.not.ma_pop_stack(l_a))
101     1          call errquit('tce_mrcc_mul: MA problem',1,MA_ERR)
102            endif
103            endif
104            endif
105cc            next = nxtask(nprocs,1)
106      if(lusesub) then
107       next = NXTASKsub(nprocs,1,mypgid)
108      else
109       next = NXTASK(nprocs, 1)
110      endif
111          endif
112          count = count + 1
113        enddo
114      enddo
115cc    next = nxtask(-nprocs,1)
116      if(lusesub) then
117       next = NXTASKsub(-nprocs,1,mypgid)
118       call ga_pgroup_sync(mypgid)
119      else
120       next = NXTASK(-nprocs, 1)
121       call ga_sync()
122      endif
123
124      return
125      end
126
127c $Id$
128