1 subroutine tce_diagnose_t1(d_r1,k_r1_offset,residual) 2 implicit none 3#include "global.fh" 4#include "mafdecls.fh" 5#include "sym.fh" 6#include "util.fh" 7#include "stdio.fh" 8#include "errquit.fh" 9#include "tce.fh" 10 integer d_r1 11 integer p1b 12 integer h2b 13 integer k_r1_offset 14 integer size 15 integer l_r1,k_r1 16 integer g_residual 17 double precision residual 18 integer nprocs 19 integer count 20 integer next 21 INTEGER NXTASK 22 EXTERNAL NXTASK 23 logical nodezero 24 double precision ddot 25 external ddot 26c 27c ===================== 28c Zero scratch residual 29c ===================== 30c 31 nodezero = (ga_nodeid().eq.0) 32 if (.not.ga_create(mt_dbl,1,1,'residual',1,1,g_residual)) 33 1 call errquit('tce_diagnose_t1: GA problem',0,GA_ERR) 34 residual = 0.0d0 35 call ga_put(g_residual,1,1,1,1,residual,1) 36 call ga_sync() 37c 38c ================ 39c Loop over blocks 40c ================ 41c 42 nprocs = ga_nnodes() 43 count = 0 44cc next = nxtask(nprocs,1) 45 next = NXTASK(nprocs, 1) 46 do p1b = noab+1,noab+nvab 47 do h2b = 1,noab 48 if (next.eq.count) then 49 if (int_mb(k_spin+p1b-1) .eq. int_mb(k_spin+h2b-1)) then 50 if ((.not.restricted).or.(int_mb(k_spin+p1b-1) 51 1 +int_mb(k_spin+h2b-1).ne.4)) then 52 if (ieor(int_mb(k_sym+p1b-1),int_mb(k_sym+h2b-1)).eq.0) then 53 size = int_mb(k_range+p1b-1) * int_mb(k_range+h2b-1) 54 if (.not.ma_push_get(mt_dbl,size,'r1',l_r1,k_r1)) 55 1 call errquit('tce_diagnose_t1: MA problem',0,MA_ERR) 56 call get_hash_block(d_r1,dbl_mb(k_r1),size, 57 1 int_mb(k_r1_offset),((p1b-noab-1)*noab+h2b-1)) 58 if (nodezero.and.util_print('residual', 59 1 print_debug)) call ma_print_compact 60 2 (dbl_mb(k_r1),size,1,'t1 residual') 61 residual = ddot(size,dbl_mb(k_r1),1,dbl_mb(k_r1),1) 62 call ga_acc(g_residual,1,1,1,1,residual,1,1.0d0) 63 if (.not.ma_pop_stack(l_r1)) 64 1 call errquit('tce_diagnose_t1: MA problem',1,MA_ERR) 65 endif 66 endif 67 endif 68 next = NXTASK(nprocs, 1) 69 endif 70 count = count + 1 71 enddo 72 enddo 73 next = NXTASK(-nprocs, 1) 74 call ga_sync() 75 call ga_get(g_residual,1,1,1,1,residual,1) 76c 77c 78c 79 print*,'naked residual = ',residual 80 print*,'sqrt(naked residual) = ',dsqrt(residual) 81 print*,'0.5d0*dsqrt(residual) = ',0.5d0*dsqrt(residual) 82c 83c 84c 85 residual = 0.5d0*dsqrt(residual) 86 if (.not.ga_destroy(g_residual)) 87 1 call errquit('tce_diagnose_t1: GA problem',1,GA_ERR) 88 return 89 end 90 91 92c $Id$ 93