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