1      subroutine tce_loc_j2(d_r2,k_r2_offset,d_t2,k_t2_offset)
2c
3c $Id$
4c
5c TO DO - initial 1.0-ing of the d_t2 file
6c
7c
8c
9c
10      implicit none
11#include "global.fh"
12#include "mafdecls.fh"
13#include "sym.fh"
14#include "util.fh"
15#include "stdio.fh"
16#include "errquit.fh"
17#include "tce.fh"
18#include "tce_main.fh"
19      integer d_r2
20      integer p1b
21      integer p2b
22      integer h3b
23      integer h4b
24      integer p1
25      integer p2
26      integer h3
27      integer h4
28      integer k_r2_offset
29      integer size
30      integer l_r2,k_r2
31      integer i
32      integer nprocs
33      integer count
34      integer next
35      integer nxtask
36c --- t2 scan ---
37      integer d_t2
38      integer k_t2_offset
39      integer l_t2,k_t2
40      integer pp1b,pp2b
41      integer hh3b,hh4b
42      integer tsize
43      integer ii
44      integer pp1,pp2,hh3,hh4
45      integer ipa1,ipa2,iha3,iha4
46      integer ip1,ip2,ih3,ih4
47      integer spin_sum,spin_suml
48      integer p2alpha
49      integer h4alpha
50      integer ip2alpha
51      integer ih4alpha
52c ---------------
53      external nxtask
54      logical nodezero
55      logical noloadbalance
56c
57      nodezero = (ga_nodeid().eq.0)
58      noloadbalance = ((ioalg.eq.4).or.
59     1                ((ioalg.eq.6).and.(.not.fileisga(d_r2))))
60      nprocs = ga_nnodes()
61      count = 0
62      next = nxtask(nprocs,1)
63      do p1b = noab+1,noab+nvab
64        do p2b = p1b,noab+nvab
65          do h3b = 1,noab
66            do h4b = h3b,noab
67              if (noloadbalance.or.(next.eq.count)) then
68                if (int_mb(k_spin+p1b-1)+int_mb(k_spin+p2b-1)
69     1            .eq. int_mb(k_spin+h3b-1)+int_mb(k_spin+h4b-1)) then
70                if ((.not.restricted).or.
71     1            (int_mb(k_spin+p1b-1)+int_mb(k_spin+p2b-1)+
72     2            int_mb(k_spin+h3b-1)+int_mb(k_spin+h4b-1).ne.8)) then
73                if (ieor(int_mb(k_sym+p1b-1),ieor(int_mb(k_sym+p2b-1),
74     1            ieor(int_mb(k_sym+h3b-1),int_mb(k_sym+h4b-1))))
75     2            .eq. irrep_x) then
76                  size = int_mb(k_range+p1b-1) * int_mb(k_range+p2b-1)
77     1                 * int_mb(k_range+h3b-1) * int_mb(k_range+h4b-1)
78                  if (.not.ma_push_get(mt_dbl,size,'r2',l_r2,k_r2))
79     1              call errquit('tce_jacobi_x2: MA problem',0,MA_ERR)
80                  call get_hash_block(d_r2,dbl_mb(k_r2),size,
81     1              int_mb(k_r2_offset),((((p1b-noab-1)*nvab+p2b-noab-1)
82     2              *noab+h3b-1)*noab+h4b-1))
83c
84                  if(restricted) then
85                   spin_sum=int_mb(k_spin+p1b-1)+int_mb(k_spin+p2b-1)+
86     1                      int_mb(k_spin+h3b-1)+int_mb(k_spin+h4b-1)
87                   if(spin_sum.eq.6) then
88                    p2alpha=int_mb(k_alpha+p2b-1)
89                    h4alpha=int_mb(k_alpha+h4b-1)
90                   end if
91                  end if
92                  i = 0
93                  do p1 = 1,int_mb(k_range+p1b-1)
94                    do p2 = 1,int_mb(k_range+p2b-1)
95                      do h3 = 1,int_mb(k_range+h3b-1)
96                        do h4 = 1,int_mb(k_range+h4b-1)
97                          i = i + 1
98                         ip1=int_mb(k_offset+p1b-1)+p1
99                         ip2=int_mb(k_offset+p2b-1)+p2
100                         ih3=int_mb(k_offset+h3b-1)+h3
101                         ih4=int_mb(k_offset+h4b-1)+h4
102                         if(restricted.and.(spin_sum.eq.6)) then
103                          ip2alpha=int_mb(k_offset+p2alpha-1)+p2
104                          ih4alpha=int_mb(k_offset+h4alpha-1)+h4
105                         end if
106c                          dbl_mb(k_r2+i-1) = dbl_mb(k_r2+i-1)
107c     1           / (-dbl_mb(k_evl_sorted+int_mb(k_offset+p1b-1)+p1-1)
108c     2              -dbl_mb(k_evl_sorted+int_mb(k_offset+p2b-1)+p2-1)
109c     3              +dbl_mb(k_evl_sorted+int_mb(k_offset+h3b-1)+h3-1)
110c     4              +dbl_mb(k_evl_sorted+int_mb(k_offset+h4b-1)+h4-1))
111c --- loop over t2 -----------
112      do pp1b = noab+1,noab+nvab
113        do pp2b = pp1b,noab+nvab
114          do hh3b = 1,noab
115            do hh4b = hh3b,noab
116                if (int_mb(k_spin+pp1b-1)+int_mb(k_spin+pp2b-1)
117     1            .eq. int_mb(k_spin+hh3b-1)+int_mb(k_spin+hh4b-1)) then
118                if ((.not.restricted).or.
119     1           (int_mb(k_spin+pp1b-1)+int_mb(k_spin+pp2b-1)+
120     2           int_mb(k_spin+hh3b-1)+int_mb(k_spin+hh4b-1).ne.8)) then
121                if (ieor(int_mb(k_sym+pp1b-1),ieor(int_mb(k_sym+pp2b-1),
122     1            ieor(int_mb(k_sym+hh3b-1),int_mb(k_sym+hh4b-1))))
123     2            .eq. 0) then
124                 tsize = int_mb(k_range+pp1b-1) * int_mb(k_range+pp2b-1)
125     1                 * int_mb(k_range+hh3b-1) * int_mb(k_range+hh4b-1)
126                  if (.not.ma_push_get(mt_dbl,tsize,'t2',l_t2,k_t2))
127     1              call errquit('tce_jacobi_t2: MA problem',0,MA_ERR)
128                  call get_hash_block(d_t2,dbl_mb(k_t2),tsize,
129     1              int_mb(k_t2_offset),
130     2              ((((pp1b-noab-1)*nvab+pp2b-noab-1)
131     2              *noab+hh3b-1)*noab+hh4b-1))
132                  if(restricted) then
133                  spin_suml=int_mb(k_spin+pp1b-1)+int_mb(k_spin+pp2b-1)+
134     1                      int_mb(k_spin+hh3b-1)+int_mb(k_spin+hh4b-1)
135                  end if
136                  ii = 0
137                  do pp1 = 1,int_mb(k_range+pp1b-1)
138                    do pp2 = 1,int_mb(k_range+pp2b-1)
139                      do hh3 = 1,int_mb(k_range+hh3b-1)
140                        do hh4 = 1,int_mb(k_range+hh4b-1)
141                          ii = ii + 1
142c
143                         ipa1=int_mb(k_offset+pp1b-1)+pp1
144                         ipa2=int_mb(k_offset+pp2b-1)+pp2
145                         iha3=int_mb(k_offset+hh3b-1)+hh3
146                         iha4=int_mb(k_offset+hh4b-1)+hh4
147c
148              if  (ipa1.lt.ipa2.AND.iha3.lt.iha4) THEN
149               if ((ip1.eq.ipa1).or.(ip1.eq.ipa2).or.
150     1            (ip2.eq.ipa1).or.(ip2.eq.ipa2).or.
151     2            (ih3.eq.iha3).or.(ih3.eq.iha4).or.
152     3            (ih4.eq.iha3).or.(ih4.eq.iha4)) then
153                   dbl_mb(k_r2+i-1)=dbl_mb(k_r2+i-1)+
154     1                              dbl_mb(k_t2+ii-1)*dbl_mb(k_t2+ii-1)
155               end if
156               if (restricted.and.(spin_sum.eq.6).and.(spin_suml.eq.4))
157     1            then
158                if ((ip2alpha.eq.ipa1).or.(ip2alpha.eq.ipa2).or.
159     1             (ih4alpha.eq.iha3).or.(ih4alpha.eq.iha4)) THEN
160                   dbl_mb(k_r2+i-1)=dbl_mb(k_r2+i-1)+
161     1                              dbl_mb(k_t2+ii-1)*dbl_mb(k_t2+ii-1)
162                end if
163               end if
164              end if
165c
166c                          dbl_mb(k_t2+ii-1) = dbl_mb(k_t2+ii-1)
167c     1           / (-dbl_mb(k_evl_sorted+int_mb(k_offset+pp1b-1)+pp1-1)
168c     2              -dbl_mb(k_evl_sorted+int_mb(k_offset+pp2b-1)+pp2-1)
169c     3              +dbl_mb(k_evl_sorted+int_mb(k_offset+hh3b-1)+hh3-1)
170c     4              +dbl_mb(k_evl_sorted+int_mb(k_offset+hh4b-1)+hh4-1))
171                        enddo
172                      enddo
173                    enddo
174                  enddo
175                  if (.not.ma_pop_stack(l_t2))
176     1              call errquit('tce_jacobi_t2: MA problem',1,MA_ERR)
177                endif
178                endif
179                endif
180            enddo
181          enddo
182        enddo
183      enddo
184c --- end of t2 loop -----
185
186                        enddo
187                      enddo
188                    enddo
189                  enddo
190                  call put_hash_block(d_r2,dbl_mb(k_r2),size,
191     1              int_mb(k_r2_offset),((((p1b-noab-1)*nvab+p2b-noab-1)
192     2              *noab+h3b-1)*noab+h4b-1))
193                  if (.not.ma_pop_stack(l_r2))
194     1              call errquit('tce_jacobi_x2: MA problem',1,MA_ERR)
195                endif
196                endif
197                endif
198                next = nxtask(nprocs,1)
199              endif
200              count = count + 1
201            enddo
202          enddo
203        enddo
204      enddo
205      next = nxtask(-nprocs,1)
206      call ga_sync()
207      return
208      end
209c
210c
211c
212c
213c
214      subroutine tce_loc_j2_one(d_r2,k_r2_offset)
215c
216c $Id$
217c
218      implicit none
219#include "global.fh"
220#include "mafdecls.fh"
221#include "sym.fh"
222#include "util.fh"
223#include "stdio.fh"
224#include "errquit.fh"
225#include "tce.fh"
226#include "tce_main.fh"
227      integer d_r2
228      integer p1b
229      integer p2b
230      integer h3b
231      integer h4b
232      integer p1
233      integer p2
234      integer h3
235      integer h4
236      integer k_r2_offset
237      integer size
238      integer l_r2,k_r2
239      integer i
240      integer nprocs
241      integer count
242      integer next
243      integer nxtask
244      external nxtask
245      logical nodezero
246      logical noloadbalance
247c
248      nodezero = (ga_nodeid().eq.0)
249      noloadbalance = ((ioalg.eq.4).or.
250     1                ((ioalg.eq.6).and.(.not.fileisga(d_r2))))
251      nprocs = ga_nnodes()
252      count = 0
253      next = nxtask(nprocs,1)
254      do p1b = noab+1,noab+nvab
255        do p2b = p1b,noab+nvab
256          do h3b = 1,noab
257            do h4b = h3b,noab
258              if (noloadbalance.or.(next.eq.count)) then
259                if (int_mb(k_spin+p1b-1)+int_mb(k_spin+p2b-1)
260     1            .eq. int_mb(k_spin+h3b-1)+int_mb(k_spin+h4b-1)) then
261                if ((.not.restricted).or.
262     1            (int_mb(k_spin+p1b-1)+int_mb(k_spin+p2b-1)+
263     2            int_mb(k_spin+h3b-1)+int_mb(k_spin+h4b-1).ne.8)) then
264                if (ieor(int_mb(k_sym+p1b-1),ieor(int_mb(k_sym+p2b-1),
265     1            ieor(int_mb(k_sym+h3b-1),int_mb(k_sym+h4b-1))))
266     2            .eq. irrep_x) then
267                  size = int_mb(k_range+p1b-1) * int_mb(k_range+p2b-1)
268     1                 * int_mb(k_range+h3b-1) * int_mb(k_range+h4b-1)
269                  if (.not.ma_push_get(mt_dbl,size,'r2',l_r2,k_r2))
270     1              call errquit('tce_jacobi_x2: MA problem',0,MA_ERR)
271                  call get_hash_block(d_r2,dbl_mb(k_r2),size,
272     1              int_mb(k_r2_offset),((((p1b-noab-1)*nvab+p2b-noab-1)
273     2              *noab+h3b-1)*noab+h4b-1))
274                  i = 0
275                  do p1 = 1,int_mb(k_range+p1b-1)
276                    do p2 = 1,int_mb(k_range+p2b-1)
277                      do h3 = 1,int_mb(k_range+h3b-1)
278                        do h4 = 1,int_mb(k_range+h4b-1)
279                          i = i + 1
280                          dbl_mb(k_r2+i-1) = 1.0d0
281                        enddo
282                      enddo
283                    enddo
284                  enddo
285                  call put_hash_block(d_r2,dbl_mb(k_r2),size,
286     1              int_mb(k_r2_offset),((((p1b-noab-1)*nvab+p2b-noab-1)
287     2              *noab+h3b-1)*noab+h4b-1))
288                  if (.not.ma_pop_stack(l_r2))
289     1              call errquit('tce_jacobi_x2: MA problem',1,MA_ERR)
290                endif
291                endif
292                endif
293                next = nxtask(nprocs,1)
294              endif
295              count = count + 1
296            enddo
297          enddo
298        enddo
299      enddo
300      next = nxtask(-nprocs,1)
301      call ga_sync()
302      return
303      end
304c
305c
306c
307c
308c
309      subroutine tce_loc_j2_inv(d_r2,k_r2_offset)
310c
311c $Id$
312c
313      implicit none
314#include "global.fh"
315#include "mafdecls.fh"
316#include "sym.fh"
317#include "util.fh"
318#include "stdio.fh"
319#include "errquit.fh"
320#include "tce.fh"
321#include "tce_main.fh"
322      integer d_r2
323      integer p1b
324      integer p2b
325      integer h3b
326      integer h4b
327      integer p1
328      integer p2
329      integer h3
330      integer h4
331      integer k_r2_offset
332      integer size
333      integer l_r2,k_r2
334      integer i
335      integer nprocs
336      integer count
337      integer next
338      integer nxtask
339      external nxtask
340      logical nodezero
341      logical noloadbalance
342c
343      nodezero = (ga_nodeid().eq.0)
344      noloadbalance = ((ioalg.eq.4).or.
345     1                ((ioalg.eq.6).and.(.not.fileisga(d_r2))))
346      nprocs = ga_nnodes()
347      count = 0
348      next = nxtask(nprocs,1)
349      do p1b = noab+1,noab+nvab
350        do p2b = p1b,noab+nvab
351          do h3b = 1,noab
352            do h4b = h3b,noab
353              if (noloadbalance.or.(next.eq.count)) then
354                if (int_mb(k_spin+p1b-1)+int_mb(k_spin+p2b-1)
355     1            .eq. int_mb(k_spin+h3b-1)+int_mb(k_spin+h4b-1)) then
356                if ((.not.restricted).or.
357     1            (int_mb(k_spin+p1b-1)+int_mb(k_spin+p2b-1)+
358     2            int_mb(k_spin+h3b-1)+int_mb(k_spin+h4b-1).ne.8)) then
359                if (ieor(int_mb(k_sym+p1b-1),ieor(int_mb(k_sym+p2b-1),
360     1            ieor(int_mb(k_sym+h3b-1),int_mb(k_sym+h4b-1))))
361     2            .eq. irrep_x) then
362                  size = int_mb(k_range+p1b-1) * int_mb(k_range+p2b-1)
363     1                 * int_mb(k_range+h3b-1) * int_mb(k_range+h4b-1)
364                  if (.not.ma_push_get(mt_dbl,size,'r2',l_r2,k_r2))
365     1              call errquit('tce_jacobi_x2: MA problem',0,MA_ERR)
366                  call get_hash_block(d_r2,dbl_mb(k_r2),size,
367     1              int_mb(k_r2_offset),((((p1b-noab-1)*nvab+p2b-noab-1)
368     2              *noab+h3b-1)*noab+h4b-1))
369                  i = 0
370                  do p1 = 1,int_mb(k_range+p1b-1)
371                    do p2 = 1,int_mb(k_range+p2b-1)
372                      do h3 = 1,int_mb(k_range+h3b-1)
373                        do h4 = 1,int_mb(k_range+h4b-1)
374                          i = i + 1
375                          dbl_mb(k_r2+i-1) = 1.0d0/dbl_mb(k_r2+i-1)
376                        enddo
377                      enddo
378                    enddo
379                  enddo
380                  call put_hash_block(d_r2,dbl_mb(k_r2),size,
381     1              int_mb(k_r2_offset),((((p1b-noab-1)*nvab+p2b-noab-1)
382     2              *noab+h3b-1)*noab+h4b-1))
383                  if (.not.ma_pop_stack(l_r2))
384     1              call errquit('tce_jacobi_x2: MA problem',1,MA_ERR)
385                endif
386                endif
387                endif
388                next = nxtask(nprocs,1)
389              endif
390              count = count + 1
391            enddo
392          enddo
393        enddo
394      enddo
395      next = nxtask(-nprocs,1)
396      call ga_sync()
397      return
398      end
399c
400c
401c
402c
403c
404c
405      subroutine tce_j2_x2_scaling(d_r2,k_r2_offset,d_j2,k_j2_offset)
406c
407c $Id$
408c
409      implicit none
410#include "global.fh"
411#include "mafdecls.fh"
412#include "sym.fh"
413#include "util.fh"
414#include "stdio.fh"
415#include "errquit.fh"
416#include "tce.fh"
417#include "tce_main.fh"
418      integer d_r2
419      integer p1b
420      integer p2b
421      integer h3b
422      integer h4b
423      integer p1
424      integer p2
425      integer h3
426      integer h4
427      integer k_r2_offset
428      integer size
429      integer l_r2,k_r2
430      integer i
431c ---
432      integer d_j2
433      integer k_j2_offset
434      integer l_j2,k_j2
435c ---
436      integer nprocs
437      integer count
438      integer next
439      integer nxtask
440      external nxtask
441      logical nodezero
442      logical noloadbalance
443c
444      nodezero = (ga_nodeid().eq.0)
445      noloadbalance = ((ioalg.eq.4).or.
446     1                ((ioalg.eq.6).and.(.not.fileisga(d_r2))))
447      nprocs = ga_nnodes()
448      count = 0
449      next = nxtask(nprocs,1)
450      do p1b = noab+1,noab+nvab
451        do p2b = p1b,noab+nvab
452          do h3b = 1,noab
453            do h4b = h3b,noab
454              if (noloadbalance.or.(next.eq.count)) then
455                if (int_mb(k_spin+p1b-1)+int_mb(k_spin+p2b-1)
456     1            .eq. int_mb(k_spin+h3b-1)+int_mb(k_spin+h4b-1)) then
457                if ((.not.restricted).or.
458     1            (int_mb(k_spin+p1b-1)+int_mb(k_spin+p2b-1)+
459     2            int_mb(k_spin+h3b-1)+int_mb(k_spin+h4b-1).ne.8)) then
460                if (ieor(int_mb(k_sym+p1b-1),ieor(int_mb(k_sym+p2b-1),
461     1            ieor(int_mb(k_sym+h3b-1),int_mb(k_sym+h4b-1))))
462     2            .eq. irrep_x) then
463                  size = int_mb(k_range+p1b-1) * int_mb(k_range+p2b-1)
464     1                 * int_mb(k_range+h3b-1) * int_mb(k_range+h4b-1)
465                  if (.not.ma_push_get(mt_dbl,size,'r2',l_r2,k_r2))
466     1              call errquit('tce_jacobi_x2: MA problem',0,MA_ERR)
467                  if (.not.ma_push_get(mt_dbl,size,'r2',l_j2,k_j2))
468     1              call errquit('tce_jacobi_x2: MA problem',0,MA_ERR)
469                  call get_hash_block(d_r2,dbl_mb(k_r2),size,
470     1              int_mb(k_r2_offset),((((p1b-noab-1)*nvab+p2b-noab-1)
471     2              *noab+h3b-1)*noab+h4b-1))
472                  call get_hash_block(d_j2,dbl_mb(k_j2),size,
473     1              int_mb(k_j2_offset),((((p1b-noab-1)*nvab+p2b-noab-1)
474     2              *noab+h3b-1)*noab+h4b-1))
475                  i = 0
476                  do p1 = 1,int_mb(k_range+p1b-1)
477                    do p2 = 1,int_mb(k_range+p2b-1)
478                      do h3 = 1,int_mb(k_range+h3b-1)
479                        do h4 = 1,int_mb(k_range+h4b-1)
480                          i = i + 1
481                    dbl_mb(k_r2+i-1) = dbl_mb(k_r2+i-1)*dbl_mb(k_j2+i-1)
482                        enddo
483                      enddo
484                    enddo
485                  enddo
486                  call put_hash_block(d_r2,dbl_mb(k_r2),size,
487     1              int_mb(k_r2_offset),((((p1b-noab-1)*nvab+p2b-noab-1)
488     2              *noab+h3b-1)*noab+h4b-1))
489                  if (.not.ma_pop_stack(l_j2))
490     1              call errquit('tce_jacobi_x2: MA problem',1,MA_ERR)
491                  if (.not.ma_pop_stack(l_r2))
492     1              call errquit('tce_jacobi_x2: MA problem',1,MA_ERR)
493                endif
494                endif
495                endif
496                next = nxtask(nprocs,1)
497              endif
498              count = count + 1
499            enddo
500          enddo
501        enddo
502      enddo
503      next = nxtask(-nprocs,1)
504      call ga_sync()
505      return
506      end
507