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