1      subroutine tce_mo1e(g_ao1e,d_mo1e,k_f1_offset)
2c
3c $Id$
4c
5c     Spin-spatial-symmetry blocked Fock matrix transformations.
6c
7      implicit none
8#include "rtdb.fh"
9#include "global.fh"
10#include "mafdecls.fh"
11#include "stdio.fh"
12#include "util.fh"
13#include "sym.fh"
14#include "sf.fh"
15#include "errquit.fh"
16#include "tce.fh"
17#include "tce_main.fh"
18      integer g_ao1e(2)           ! AO Fock matrices
19      integer l_ao1e,k_ao1e       ! AO Fock matrices
20      integer l_mo1e,k_mo1e       ! MO Fock matrices
21      integer l_work,k_work       ! Work space
22      integer sf_size,sf_offset ! SF size and offset
23      integer d_mo1e              ! File handle
24      integer spin                ! Spin
25      integer g1b,g2b             ! Block indexes
26      integer range_g1,range_g2   ! Block ranges
27      integer offset_g1,offset_g2 ! Block offsets
28      integer size_g1g2
29      integer k_f1_offset
30      integer key_g1g2
31      logical nodezero
32      INTEGER NXTASK
33      INTEGER next
34      INTEGER nprocs
35      INTEGER count
36      EXTERNAL NXTASK
37c
38c     =====================================
39c     Determine the size of SF and allocate
40c     =====================================
41c
42      nodezero = (ga_nodeid().eq.0)
43ccx      sf_size=0
44ccx      do g1b = 1,noa+nob+nva+nvb
45ccx        do g2b = 1,noa+nob+nva+nvb
46ccx          if (int_mb(k_spin+g1b-1) .eq. int_mb(k_spin+g2b-1)) then
47ccx          if ((.not.restricted).or.(int_mb(k_spin+g1b-1)
48ccx     1      +int_mb(k_spin+g2b-1).ne.4)) then
49ccx          if (ieor(int_mb(k_sym+g1b-1),int_mb(k_sym+g2b-1))
50ccx     1      .eq. 0) then
51ccx            sf_size = sf_size + int_mb(k_range+g1b-1)
52ccx     1                        * int_mb(k_range+g2b-1)
53ccx          endif
54ccx          endif
55ccx          endif
56ccx        enddo
57ccx      enddo
58ccx      if (.not.ma_push_get(mt_dbl,sf_size,'MO Fock',
59ccx     1  l_mo1e,k_mo1e)) call errquit('tce_mo1e: MA problem',3,MA_ERR)
60c
61c     ==============
62c     Transformation
63c     ==============
64c
65      nprocs = GA_NNODES()
66      count = 0
67      next = NXTASK(nprocs, 1)
68c
69      sf_offset=0
70      do g2b = 1,noa+nob+nva+nvb
71        do g1b = 1,noa+nob+nva+nvb
72          IF (next.eq.count) THEN
73            if (int_mb(k_spin+g1b-1) .eq. int_mb(k_spin+g2b-1)) then
74              if ((.not.restricted).or.(int_mb(k_spin+g1b-1)
75     1          +int_mb(k_spin+g2b-1).ne.4)) then
76                if (ieor(int_mb(k_sym+g1b-1),int_mb(k_sym+g2b-1))
77     1            .eq. 0) then
78                  spin = int_mb(k_spin+g1b-1)
79                  range_g1 = int_mb(k_range+g1b-1)
80                  range_g2 = int_mb(k_range+g2b-1)
81                  offset_g1 = int_mb(k_offset+g1b-1)*nbf
82                  offset_g2 = int_mb(k_offset+g2b-1)*nbf
83                  if (.not.ma_push_get(mt_dbl,range_g1*nbf,'Work',
84     1              l_work,k_work)) call errquit('tce_mo1e: MA problem',
85     2                                           0,MA_ERR)
86                  if (.not.ma_push_get(mt_dbl,nbf*nbf,'AO Fock',
87     1              l_ao1e,k_ao1e)) call errquit('tce_mo1e: MA problem',
88     2              1,MA_ERR)
89                  call ga_get(g_ao1e(spin),1,nbf,1,nbf,dbl_mb(k_ao1e),
90     1                        nbf)
91                  call dgemm('T','N',range_g1,nbf,nbf,1.0d0,
92     1              dbl_mb(k_movecs_sorted+offset_g1),nbf,
93     2              dbl_mb(k_ao1e),nbf,0.0d0,dbl_mb(k_work),range_g1)
94                  if (.not.ma_pop_stack(l_ao1e))
95     1              call errquit('tce_mo1e: MA problem',2,MA_ERR)
96c open local file
97                  size_g1g2=range_g1*range_g2
98                  if (.not.ma_push_get(mt_dbl,size_g1g2,'MO Fock',
99     1                l_mo1e,k_mo1e))
100     2                call errquit('tce_mo1e: MA problem',3,MA_ERR)
101c zeroing ---
102                  call dfill(size_g1g2, 0.0d0, dbl_mb(k_mo1e), 1)
103c
104                  call dgemm('N','N',range_g1,range_g2,nbf,1.0d0,
105     1              dbl_mb(k_work),range_g1,
106     2              dbl_mb(k_movecs_sorted+offset_g2),nbf,
107     3              0.0d0,dbl_mb(k_mo1e),range_g1)
108c finding offset
109                  key_g1g2=g1b - 1 + (noab+nvab) * (g2b - 1)
110                  call put_hash_block(d_mo1e,dbl_mb(k_mo1e),size_g1g2,
111     1                                int_mb(k_f1_offset),key_g1g2)
112c close local file
113                  if (.not.ma_pop_stack(l_mo1e))
114     1                call errquit('tce_mo1e: MA problem',6,MA_ERR)
115c
116ccx            if (nodezero.and.util_print('mo1e',print_debug))
117ccx     1        call ma_print(dbl_mb(k_mo1e+sf_offset),
118ccx     2        range_g1,range_g2,'Spin symmetry block of Fock')
119                  if (.not.ma_pop_stack(l_work))
120     1              call errquit('tce_mo1e: MA problem',5,MA_ERR)
121ccx            sf_offset = sf_offset + range_g1 * range_g2
122                endif
123              endif
124            endif
125            next = NXTASK(nprocs, 1)
126          END IF
127          count = count + 1
128        enddo
129      enddo
130      next = NXTASK(-nprocs, 1)
131      call GA_SYNC()
132c
133c     ===========
134c     Write to SF
135c     ===========
136c
137ccx      call put_block(d_mo1e,dbl_mb(k_mo1e),sf_size,0)
138c
139c     ===================
140c     Close SF and return
141c     ===================
142c
143ccx      if (nodezero.and.util_print('mo1e',print_debug)) then
144ccx        call sf_print(d_mo1e,sf_size)
145ccx      endif
146ccx      if (.not.ma_pop_stack(l_mo1e))
147ccx     1  call errquit('tce_mo1e: MA problem',6,MA_ERR)
148      if (.not.ga_destroy(g_ao1e(1)))
149     1  call errquit('tce_mo1e: GA problem',2,GA_ERR)
150      if (.not.ga_destroy(g_ao1e(2)))
151     1  call errquit('tce_mo1e: GA problem',3,GA_ERR)
152      return
153      end
154
155
156
157      subroutine tce_mo1e_epsilon(d_mo1e)
158c
159c     Spin-spatial-symmetry blocked Fock matrix formation from epsilons.
160c
161      implicit none
162#include "rtdb.fh"
163#include "global.fh"
164#include "mafdecls.fh"
165#include "stdio.fh"
166#include "util.fh"
167#include "sym.fh"
168#include "sf.fh"
169#include "errquit.fh"
170#include "tce.fh"
171#include "tce_main.fh"
172      integer l_mo1e,k_mo1e       ! MO Fock matrices
173      integer sf_size,sf_offset   ! SF size and offset
174      integer d_mo1e              ! File handle
175      integer spin                ! Spin
176      integer g1b,g2b             ! Block indexes
177      integer range_g1,range_g2   ! Block ranges
178      integer g1,g2
179      logical nodezero
180c
181c     =====================================
182c     Determine the size of SF and allocate
183c     =====================================
184c
185      nodezero = (ga_nodeid().eq.0)
186      sf_size=0
187      do g1b = 1,noa+nob+nva+nvb
188        do g2b = 1,noa+nob+nva+nvb
189          if (int_mb(k_spin+g1b-1) .eq. int_mb(k_spin+g2b-1)) then
190          if ((.not.restricted).or.(int_mb(k_spin+g1b-1)
191     1      +int_mb(k_spin+g2b-1).ne.4)) then
192          if (ieor(int_mb(k_sym+g1b-1),int_mb(k_sym+g2b-1))
193     1      .eq. 0) then
194            sf_size = sf_size + int_mb(k_range+g1b-1)
195     1                        * int_mb(k_range+g2b-1)
196          endif
197          endif
198          endif
199        enddo
200      enddo
201      if (.not.ma_push_get(mt_dbl,sf_size,'MO Fock',
202     1  l_mo1e,k_mo1e)) call errquit('tce_mo1e: MA problem',3,MA_ERR)
203c
204c     ==============
205c     Transformation
206c     ==============
207c
208      sf_offset=0
209      do g2b = 1,noa+nob+nva+nvb
210        do g1b = 1,noa+nob+nva+nvb
211          if (int_mb(k_spin+g1b-1) .eq. int_mb(k_spin+g2b-1)) then
212          if ((.not.restricted).or.(int_mb(k_spin+g1b-1)
213     1      +int_mb(k_spin+g2b-1).ne.4)) then
214          if (ieor(int_mb(k_sym+g1b-1),int_mb(k_sym+g2b-1))
215     1      .eq. 0) then
216            spin = int_mb(k_spin+g1b-1)
217            range_g1 = int_mb(k_range+g1b-1)
218            range_g2 = int_mb(k_range+g2b-1)
219            do g2 = 1, range_g2
220              do g1 = 1, range_g1
221                if ((g1b.eq.g2b).and.(g1.eq.g2)) then
222                  dbl_mb(k_mo1e+sf_offset+(g2-1)*range_g1+g1-1)=
223     1            dbl_mb(k_evl_sorted+int_mb(k_offset+g1b-1)+g1-1)
224                else
225                  dbl_mb(k_mo1e+sf_offset+(g2-1)*range_g1+g1-1)=0.0d0
226                endif
227              enddo
228            enddo
229            if (nodezero.and.util_print('mo1e',print_debug))
230     1        call ma_print(dbl_mb(k_mo1e+sf_offset),
231     2        range_g1,range_g2,'Spin symmetry block of Fock')
232            sf_offset = sf_offset + range_g1 * range_g2
233          endif
234          endif
235          endif
236        enddo
237      enddo
238c
239c     ===========
240c     Write to SF
241c     ===========
242c
243      call put_block(d_mo1e,dbl_mb(k_mo1e),sf_size,0)
244c
245c     ===================
246c     Close SF and return
247c     ===================
248c
249      if (nodezero.and.util_print('mo1e',print_debug)) then
250        call sf_print(d_mo1e,sf_size)
251      endif
252      if (.not.ma_pop_stack(l_mo1e))
253     1  call errquit('tce_mo1e: MA problem',6,MA_ERR)
254      return
255      end
256