1      subroutine tce_eomccsd_1prdm(d_hh,d_pp,d_t1,d_t2,d_x0,d_x1,d_x2,
2     1                         d_y1,d_y2,k_hh_offset,k_pp_offset,
3     1                         k_t1_offset,k_t2_offset,
4     1                         k_x0_offset,k_x1_offset,k_x2_offset,
5     3                         k_y1_offset,k_y2_offset)
6      implicit none
7#include "global.fh"
8#include "mafdecls.fh"
9#include "util.fh"
10#include "errquit.fh"
11#include "tce.fh"
12#include "tce_main.fh"
13#include "rtdb.fh"
14      integer d_hh,k_hh_offset
15      integer d_pp,k_pp_offset
16      integer d_t1,k_t1_offset
17      integer d_t2,k_t2_offset
18      integer d_x0,k_x0_offset
19      integer d_x1,k_x1_offset
20      integer d_x2,k_x2_offset
21      integer d_y1,k_y1_offset
22      integer d_y2,k_y2_offset
23c
24      character*255 filename
25c     ====
26c     1PDM
27c     ====
28      integer d_hp,l_hp_offset,k_hp_offset,size_hp
29      integer d_ph,l_ph_offset,k_ph_offset,size_ph
30      integer d_1pdm,l_1pdm_offset,k_1pdm_offset,size_1pdm
31c     ====================
32c     atomic orbital tiles
33c     ====================
34c      integer atpart
35c      integer nalength(200)
36c      integer a2length(200)
37c
38      double precision cpu,wall,r1,residual
39      integer dummy, iter
40c     ==============
41c     GA for 1PDM_AO
42c     ==============
43      integer  ga_create_atom_blocked
44      external ga_create_atom_blocked
45      integer  g_1pdm
46c
47      logical  nodezero
48c
49      integer g1b, g1
50      integer dima, l_a, k_a
51c
52c     parallel
53      integer next
54      integer count
55      integer nxtask
56      external nxtask
57      integer nprocs
58c
59      nodezero=(ga_nodeid().eq.0)
60c
61c     ============================================================
62c     !!! Attention: frozen orbital option was not considered !!!
63c     ============================================================
64c
65c     ==========================
66c     1PDM Hole-Particle Block
67c     ==========================
68      call tce_filename('hp',filename)
69      call tce_dens_hp_offset(l_hp_offset,k_hp_offset,size_hp)
70      call createfile(filename,d_hp,size_hp)
71      call eomccsd_1pdm_hp_mo(d_hp,d_x0,d_x1,d_y1,d_y2,
72     1      k_hp_offset,k_x0_offset,k_x1_offset,
73     2      k_y1_offset,k_y2_offset)
74      call reconcilefile(d_hp,size_hp)
75c     ===========================
76c     1PDM Particle-Hole Block
77c     ==========================
78      call tce_filename('ph',filename)
79      call tce_dens_ph_offset(l_ph_offset,k_ph_offset,size_ph)
80      call createfile(filename,d_ph,size_ph)
81      call eomccsd_1pdm_ph_mo(d_ph,d_t1,d_t2,
82     1              d_x0,d_x1,d_x2,d_y1,d_y2,
83     1     k_ph_offset,k_t1_offset,k_t2_offset,
84     1     k_x0_offset,k_x1_offset,k_x2_offset,
85     1     k_y1_offset,k_y2_offset)
86      call reconcilefile(d_ph,size_ph)
87c     =====================================================================================================
88c     put 1PDM Hole-Hole, Hole-Particle, Particle-Hole, and Particle-Particle Block four pieces in one file
89c     =====================================================================================================
90      call tce_filename('1pdm',filename)
91      call tce_1pdm_offset(l_1pdm_offset,k_1pdm_offset,size_1pdm)
92      call createfile(filename,d_1pdm,size_1pdm)
93c
94      call put_1pdm_hh(d_1pdm,k_1pdm_offset,d_hh,k_hh_offset)
95      call put_1pdm_hp(d_1pdm,k_1pdm_offset,d_hp,k_hp_offset)
96      call put_1pdm_ph_2(d_1pdm,k_1pdm_offset,d_ph,k_ph_offset)
97      call put_1pdm_pp(d_1pdm,k_1pdm_offset,d_pp,k_pp_offset)
98      call reconcilefile(d_1pdm,size_1pdm)
99c    =================================
100c    HF REFERENCE CONTRIBUTION TO 1PDM
101c    =================================
102      nprocs=ga_nnodes( )
103      count=0
104      next=nxtask(nprocs,1)
105c
106      do g1b=1,noab
107         if(count.eq.next) then
108c
109         if ((.not.restricted).or.(int_mb(k_spin+g1b-1).ne.2)) then
110            dima=int_mb(k_range+g1b-1)*int_mb(k_range+g1b-1)
111            if (.not.ma_push_get(mt_dbl,dima,'noname',l_a,k_a))
112     1      call errquit('tce_eomccsd_1prdm: ma problem',2,ma_err)
113            call get_hash_block(d_1pdm,dbl_mb(k_a),dima,
114     1           int_mb(k_1pdm_offset),(g1b-1)+(g1b-1)*(noab+nvab))
115            do g1=1,int_mb(k_range+g1b-1)
116               dbl_mb(k_a+(g1-1)+(g1-1)*int_mb(k_range+g1b-1))=
117     1         dbl_mb(k_a+(g1-1)+(g1-1)*int_mb(k_range+g1b-1))+1.d0
118            enddo
119            call put_hash_block(d_1pdm,dbl_mb(k_a),dima,
120     1           int_mb(k_1pdm_offset),(g1b-1)+(g1b-1)*(noab+nvab))
121            if (.not.ma_pop_stack(l_a))
122     1      call errquit('tce_eomccsd_1prdm: ma problem',3,ma_err)
123         endif
124         next=nxtask(nprocs,1)
125         endif
126         count=count+1
127      enddo
128      next=nxtask(-nprocs,1)
129      call ga_sync( )
130c     ====================================
131c     Do the back transformation
132c     ===================================
133      g_1pdm = ga_create_atom_blocked(geom, ao_bas_han,
134     $         'density matrix')
135c      call ga_zero(g_1pdm)
136      call ao_tiles(atpart,nalength,a2length,30)
137      call btrans1(d_1pdm,k_1pdm_offset,g_1pdm,atpart,nalength)
138c      call ga_symmetrize(g_1pdm)
139c     ====================================
140c     DUMP it to a file
141c     ====================================
142c      call ga_zero(g_1pdm)
143c      call ga_print(g_1pdm)
144      call ao_1prdm_write(nbf,g_1pdm)
145c      call ao_1prdm_read(nbf,g_1pdm)
146c      call ga_print(g_1pdm)
147c     =============================
148c     clean up the files and arrays
149c     =============================
150      if (.not. ga_destroy(g_1pdm)) call errquit
151     1   ('tce_ccsd_1prdm: error destroying density', 1, GA_ERR)
152c
153      call deletefile(d_1pdm)
154      if(.not.ma_pop_stack(l_1pdm_offset))
155     1  call errquit('tce_ccsd_1prdm: ma problem',17,ma_err)
156c
157      call deletefile(d_ph)
158      if(.not.ma_pop_stack(l_ph_offset))
159     1  call errquit('tce_ccsd_1prdm: ma problem',17,ma_err)
160c
161      call deletefile(d_hp)
162      if(.not.ma_pop_stack(l_hp_offset))
163     1  call errquit('tce_ccsd_1prdm: ma problem',17,ma_err)
164c
165      end
166c $Id$
167