1ckbn         subroutine tce_mrcc_print_summary(iter,dsummary)
2ckbn         implicit none
3ckbn#include "tce.fh"
4ckbn#include "mafdecls.fh"
5ckbn#include "stdio.fh"
6ckbn#include "rtdb.fh"
7ckbn#include "errquit.fh"
8ckbn#include "sym.fh"
9ckbn#include "tce_mrcc.fh"
10ckbn#include "global.fh"
11ckbn#include "tce_main.fh"
12ckbn
13ckbn      integer iter
14ckbn      double precision dsummary(5000,2)
15ckbn      logical nodezero
16ckbn      integer i,j
17ckbn
18ckbn      nodezero = (ga_nodeid().eq.0)
19ckbn
20ckbn      dsummary(1,2) = 0.0d0
21ckbn
22ckbn      if(nodezero) then
23ckbn        write(LuOut,"(/)")
24ckbn        call util_print_centered
25ckbn     1  (LuOut,'======================================================',
26ckbn     2  40,.false.)
27ckbn       call util_print_centered
28ckbn     1  (LuOut,'Summary output from iterations',
29ckbn     2  40,.false.)
30ckbn        call util_print_centered
31ckbn     1  (LuOut,'======================================================',
32ckbn     2  40,.false.)
33ckbn        write(LuOut,*)
34ckbn
35ckbn        write(LuOut,9100)
36ckbn        call util_print_centered
37ckbn     1  (LuOut,'------------------------------------------------------',
38ckbn     2  40,.false.)
39ckbn        do i=1,iter
40ckbn         write(LuOut,9200)i,(dsummary(i,j),j=1,2)
41ckbn        enddo
42ckbn        call util_print_centered
43ckbn     1  (LuOut,'======================================================',
44ckbn     2  40,.false.)
45ckbn      endif
46ckbn
47ckbn      if (nodezero) call util_flush(LuOut)
48ckbn
49ckbn 9100 format(15x,'  Iteration  ',3x,'Energy (a.u.)',9x,'Corr. energy')
50ckbn 9200 format(17x,1x,i4,40f22.12,7x)
51ckbn
52ckbn      return
53ckbn      end
54
55
56         subroutine tce_mrcc_print_t1type(d_t1,k_t1_offset,iref,irefnew)
57         implicit none
58#include "tce.fh"
59#include "mafdecls.fh"
60#include "stdio.fh"
61#include "rtdb.fh"
62#include "errquit.fh"
63#include "sym.fh"
64#include "tce_mrcc.fh"
65#include "global.fh"
66#include "tce_main.fh"
67
68      integer p5b,h6b
69      logical nodezero
70      integer d_t1,k_t1_offset
71      integer l_t1,k_t1
72      integer size
73      integer iref,inoab,counter
74      integer orbspin(2),orbindex(2)
75      integer i,j
76      character*2 s,r
77      integer irefnew,lastparam
78
79      nodezero = (ga_nodeid().eq.0)
80      inoab = nblcks(1,iref)+nblcks(2,iref)
81c DEBUG
82c      nodezero=.true.
83c
84      lastparam=nblcks(1,iref)+nblcks(2,iref)+nblcks(3,iref)+
85     1 nblcks(4,iref)
86
87      if (nodezero) write(LuOut,'(A,I4,A)')
88     + "Printing T1/R1 array when T1 >0.1 for ",iref," if any"
89
90      DO p5b = nblcks(1,iref)+nblcks(2,iref)+1,lastparam
91      DO h6b = 1,nblcks(1,iref)+nblcks(2,iref)
92      IF (int_mb(k_spinm(iref)+p5b-1) .eq. int_mb(k_spinm(iref)+
93     1h6b-1)) THEN
94      IF (ieor(int_mb(k_symm(iref)+p5b-1),int_mb(k_symm(iref)+
95     1h6b-1)) .eq. irrep_t) THEN
96      IF ((.not.restricted).or.(int_mb(k_spinm(iref)+p5b-1)+
97     1int_mb(k_spinm(iref)+h6b-1).ne.4)) THEN
98
99
100         size = int_mb(k_rangem(iref)+p5b-1) *
101     1 int_mb(k_rangem(iref)+h6b-1)
102
103         if (.not.ma_push_get(mt_dbl,size,'t1',l_t1,k_t1))
104     1   call errquit('tce_c1_offs: MA problem',0,MA_ERR)
105         call get_hash_block(d_t1,dbl_mb(k_t1),size,
106     1   int_mb(k_t1_offset),((p5b-inoab-1)*inoab+h6b-1))
107
108         counter = 0
109
110         do i=1,int_mb(k_rangem(iref)+p5b-1)
111           orbspin(1) = int_mb(k_spinm(iref)+p5b-1)-1
112           do j=1,int_mb(k_rangem(iref)+h6b-1)
113            orbspin(2) = int_mb(k_spinm(iref)+h6b-1)-1
114
115             counter = counter + 1
116
117             orbindex(1) = (1 - orbspin(1)+
118     1 int_mb(k_mo_indexm(iref)+int_mb(k_offsetm(iref)+p5b-1)+i-1))/2
119             orbindex(2) = (1 - orbspin(2)+
120     1 int_mb(k_mo_indexm(iref)+int_mb(k_offsetm(iref)+h6b-1)+j-1))/2
121
122c       if(nodezero)write(6,*)orbindex(1),orbindex(2)
123
124
125c       if(nodezero)write(6,*)orbindex(1),orbindex(2)
126
127              if(orbspin(1).eq.0) then
128               s='Pa'
129              else
130               s='Pb'
131              endif
132
133              if(orbspin(2).eq.0) then
134               r='Ha'
135              else
136               r='Hb'
137              endif
138
139      if(nodezero .and. (abs(dbl_mb(k_t1+counter-1)) .gt. 0.1d0)) then
140               write(LuOut,"('(',I5,a2,I5,a2,')=',2F16.12)")
141
142     +moindexes(orbindex(2),orbspin(2)+1,iref),r,
143     +moindexes(orbindex(1),orbspin(1)+1,iref),s,
144     +dbl_mb(k_t1+counter-1)
145      endif
146
147           enddo
148          enddo
149
150         if (.not.ma_pop_stack(l_t1))
151     1   call errquit('tce_c1_offs: MA problem',2,MA_ERR)
152
153      endif
154      endif
155      endif
156
157      enddo
158      enddo
159
160      call util_flush(LuOut)
161
162       return
163       end
164
165         subroutine tce_mrcc_print_t2type(d_t2,k_t2_offset,iref,irefnew)
166         implicit none
167#include "tce.fh"
168#include "mafdecls.fh"
169#include "stdio.fh"
170#include "rtdb.fh"
171#include "errquit.fh"
172#include "sym.fh"
173#include "tce_mrcc.fh"
174#include "global.fh"
175#include "tce_main.fh"
176
177      integer p1b,p2b,h3b,h4b
178      logical nodezero
179      integer d_t2,k_t2_offset
180      integer l_a,k_a
181      integer size
182      integer iref,inoab,counter
183      integer orbspin(4),orbindex(4)
184      integer i,j,m,n
185      character*2 s,r,t,u
186      integer irefnew
187      integer ihash,invab
188
189      nodezero = (ga_nodeid().eq.0)
190c DEBUG
191c      nodezero=.true.
192c
193
194      if (nodezero) write(LuOut,'(A,I4,A)')
195     + "Printing T2/R2 array when T2 >0.1 for ",iref," if any"
196
197      inoab = nblcks(1,iref)+nblcks(2,iref)
198      invab = nblcks(3,iref)+nblcks(4,iref)
199
200      DO p1b = inoab+1,inoab+invab
201      DO p2b = p1b,inoab+invab
202      DO h3b = 1,inoab
203      DO h4b = h3b,inoab
204
205      IF (int_mb(k_spinm(iref)+p1b-1)+int_mb(k_spinm(iref)+p2b-1)
206     1.eq.int_mb(k_spinm(iref)+h3b-1)+int_mb(k_spinm(iref)+h4b-1))THEN
207      IF (ieor(int_mb(k_symm(iref)+p1b-1),ieor(int_mb(k_symm(iref)+p2b
208     1-1),ieor(int_mb(k_symm(iref)+h3b-1),int_mb(k_symm(iref)+h4b-1))))
209     1  .eq. irrep_t) THEN
210      IF ((.not.restricted).or.(int_mb(k_spinm(iref)+p1b-1)+
211     1 int_mb(k_spinm(iref)+p2b-1)+int_mb(k_spinm(iref)+h3b-1)
212     1 +int_mb(k_spinm(iref)+h4b-1).ne.8)) THEN
213
214         size = int_mb(k_rangem(iref)+p1b-1) *
215     1 int_mb(k_rangem(iref)+p2b-1)*int_mb(k_rangem(iref)+h3b-1)*
216     2 int_mb(k_rangem(iref)+h4b-1)
217
218              if (.not.ma_push_get(mt_dbl,size,'c2',l_a,k_a))
219     1          call errquit('tce_c2_offs: MA problem',11,MA_ERR)
220
221         counter = 0
222
223        ihash = (h4b - 1 +
224     2  inoab * (h3b - 1 + inoab * (p2b-
225     &inoab - 1 + invab * (p1b - inoab - 1))))
226
227
228        call get_hash_block(d_t2,dbl_mb(k_a),size,
229     1  int_mb(k_t2_offset),ihash)
230
231         do i=1,int_mb(k_rangem(iref)+p1b-1)
232          orbspin(1) = int_mb(k_spinm(iref)+p1b-1)-1
233           do j=1,int_mb(k_rangem(iref)+p2b-1)
234            orbspin(2) = int_mb(k_spinm(iref)+p2b-1)-1
235             do m=1,int_mb(k_rangem(iref)+h3b-1)
236             orbspin(3) = int_mb(k_spinm(iref)+h3b-1)-1
237              do n=1,int_mb(k_rangem(iref)+h4b-1)
238              orbspin(4) = int_mb(k_spinm(iref)+h4b-1)-1
239
240             counter = counter + 1
241
242             orbindex(1) = (1 - orbspin(1)+
243     1 int_mb(k_mo_indexm(iref)+int_mb(k_offsetm(iref)+p1b-1)+i-1))/2
244             orbindex(2) = (1 - orbspin(2)+
245     1 int_mb(k_mo_indexm(iref)+int_mb(k_offsetm(iref)+p2b-1)+j-1))/2
246             orbindex(3) = (1 - orbspin(3)+
247     1 int_mb(k_mo_indexm(iref)+int_mb(k_offsetm(iref)+h3b-1)+m-1))/2
248             orbindex(4) = (1 - orbspin(4)+
249     1 int_mb(k_mo_indexm(iref)+int_mb(k_offsetm(iref)+h4b-1)+n-1))/2
250              if(orbspin(1).eq.0) then
251               s='Pa'
252              else
253               s='Pb'
254              endif
255
256              if(orbspin(2).eq.0) then
257               r='Pa'
258              else
259               r='Pb'
260              endif
261
262              if(orbspin(3).eq.0) then
263               t='Ha'
264              else
265               t='Hb'
266              endif
267
268              if(orbspin(4).eq.0) then
269               u='Ha'
270              else
271               u='Hb'
272              endif
273
274      if(nodezero .and. (abs(dbl_mb(k_a+counter-1)) .gt. 0.1d0)) then
275               write(LuOut,"('(',I5,a2,I5,a2,I5,a2,I5,a2,')=',2F16.12)")
276     +moindexes(orbindex(3),orbspin(3)+1,iref),t,
277     +moindexes(orbindex(4),orbspin(4)+1,iref),u,
278     +moindexes(orbindex(1),orbspin(1)+1,iref),s,
279     +moindexes(orbindex(2),orbspin(2)+1,iref),r,
280     +dbl_mb(k_a+counter-1)
281      endif
282
283
284           enddo
285           enddo
286           enddo
287          enddo
288
289         if (.not.ma_pop_stack(l_a))
290     1   call errquit('tce_c1_offs: MA problem',2,MA_ERR)
291
292      endif
293      endif
294      endif
295
296      enddo
297      enddo
298           enddo
299           enddo
300
301      if (nodezero) call util_flush(LuOut)
302
303       return
304       end
305
306         subroutine tce_mrcc_debug_pfile(d_a,size_a,fname,iter,iref)
307         implicit none
308#include "tce.fh"
309#include "mafdecls.fh"
310#include "stdio.fh"
311#include "rtdb.fh"
312#include "errquit.fh"
313#include "sym.fh"
314#include "tce_mrcc.fh"
315#include "global.fh"
316#include "tce_main.fh"
317
318      integer d_a,size_a,iter
319      character*4 fname
320      character*3 sname,siter,sipg,sref
321      double precision dbuff
322      integer i,ipg,iref
323
324      write(sname,"(I3.3)")ga_nodeid()
325      write(siter,"(I3.3)")iter
326      write(sref,"(I3.3)")iref
327
328      if(lusesub) then
329      ipg =int_mb(k_innodes+ga_nnodes()+ga_nodeid())
330      else
331      ipg = 1
332      endif
333
334      write(sipg,"(I3.3)")ipg
335
336      open(unit=20+ga_nodeid(),file='/mscf/home/brab894/JOBS/TESTS/H2O/'
337     1 //fname//sname//siter//sipg//sref//'.file',status='unknown')
338
339      do i=1,size_a
340        call ga_get(d_a,i,i,1,1,dbuff,1)
341        write(20+ga_nodeid(),"(F16.12)")dbuff
342      enddo
343
344      close(20+ga_nodeid())
345
346      return
347      end
348
349c         subroutine tce_mrcc_denomstats(iter,iref)
350c         implicit none
351c#include "tce.fh"
352c#include "mafdecls.fh"
353c#include "stdio.fh"
354c#include "rtdb.fh"
355c#include "errquit.fh"
356c#include "sym.fh"
357c#include "tce_mrcc.fh"
358c#include "global.fh"
359c#include "tce_main.fh"
360c
361c         integer iter,iref,nodezero
362c
363c         nodezero = (ga_nodeid().eq.0)
364c
365c         return
366c         end
367c $Id$
368