1      subroutine tce_ccsd_1prdm(d_t1,d_t2,d_lambda1,d_lambda2,
2     1                    d_hh,d_pp,
3     1                    k_t1_offset,k_t2_offset,
4     1                    k_l1_offset,k_l2_offset,
5     1                    k_hh_offset,k_pp_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"
14c
15      integer d_t1,k_t1_offset
16      integer d_t2,k_t2_offset
17      integer d_lambda1,k_l1_offset
18      integer d_lambda2,k_l2_offset
19      integer d_hh,k_hh_offset
20      integer d_pp,k_pp_offset
21c
22c     integer k_force
23c
24      character*255 filename
25c
26c     ====
27c     1PDM
28c     ====
29      integer d_ph,l_ph_offset,k_ph_offset,size_ph
30      integer d_hp,l_hp_offset,k_hp_offset,size_hp
31      integer d_1pdm,l_1pdm_offset,k_1pdm_offset,size_1pdm
32c     ===========================
33c     atomic orbital tiles
34c     ===========================
35      integer atpart2
36      integer nalength2(200)
37      integer a2length2(200)
38c
39      double precision cpu,wall,r1,residual
40      integer dummy, iter
41c     ===========================
42c     GA for 1PDM_AO and 1PWDM_AO
43c     ===========================
44      integer  ga_create_atom_blocked
45      external ga_create_atom_blocked
46      integer  g_1pdm
47c
48      integer dima,l_a,k_a
49c
50      logical nodezero
51c
52      integer l_test,k_test,l_r2,k_r2,size,l_r1,k_r1
53      integer g1,g2,g3,g4,g1b,g2b,g3b,g4b
54      integer ig1,ig2,ig3,ig4,igg1,igg2,igg3,igg4
55      integer k,l,ind1,ind2
56      integer dim_2pdm, k_2pdm, l_2pdm
57      integer dim_1pdm, k_1pdm, l_1pdm
58      integer dim_1pwdm,k_1pwdm,l_1pwdm
59      integer k_2eint,l_2eint,k_1eint,l_1eint
60c
61      double precision res
62      integer l_zvec_x,k_zvec_x
63      integer m,e,a,b,q,r,s,n,f
64c
65c     debug
66      logical zvec_debug, wdm_debug
67c
68      logical ao_1prdm_write
69      external ao_1prdm_write
70c     parallel
71      integer next
72      integer count
73      integer nxtask
74      external nxtask
75      integer nprocs
76c
77      nodezero=(ga_nodeid().eq.0)
78c
79c     =================================================================
80c     !!! Attention: frozen orbital option was not considered !!!
81c     =================================================================
82c
83c     ========================
84c     1PDM Hole-Particle Block
85c     ========================
86      call tce_filename('hp',filename)
87      call tce_dens_hp_offset(l_hp_offset,k_hp_offset,size_hp)
88      call createfile(filename,d_hp,size_hp)
89      call ccsd_1pdm_hp_mo(d_hp,d_lambda1,k_hp_offset,k_l1_offset)
90      call reconcilefile(d_hp,size_hp)
91c     ========================
92c     1PDM Particle-Hole Block
93c     ========================
94      call tce_filename('ph',filename)
95      call tce_dens_ph_offset(l_ph_offset,k_ph_offset,size_ph)
96      call createfile(filename,d_ph,size_ph)
97      call ccsd_1pdm_ph_mo(d_ph,d_t1,d_t2,d_lambda1,d_lambda2,
98     1     k_ph_offset,k_t1_offset,k_t2_offset,k_l1_offset,k_l2_offset)
99      call reconcilefile(d_ph,size_ph)
100c     =====================================================================================================
101c     put 1PDM Hole-Hole, Hole-Particle, Particle-Hole, and Particle-Particle Block four pieces in one file
102c     =====================================================================================================
103      call tce_filename('1pdm',filename)
104      call tce_1pdm_offset(l_1pdm_offset,k_1pdm_offset,size_1pdm)
105      call createfile(filename,d_1pdm,size_1pdm)
106c
107      call put_1pdm_hh(d_1pdm,k_1pdm_offset,d_hh,k_hh_offset)
108      call put_1pdm_hp(d_1pdm,k_1pdm_offset,d_hp,k_hp_offset)
109      call put_1pdm_ph_2(d_1pdm,k_1pdm_offset,d_ph,k_ph_offset)
110      call put_1pdm_pp(d_1pdm,k_1pdm_offset,d_pp,k_pp_offset)
111      call reconcilefile(d_1pdm,size_1pdm)
112c    =================================
113c    HF REFERENCE CONTRIBUTION TO 1PDM
114c    =================================
115      nprocs=ga_nnodes( )
116      count=0
117      next=nxtask(nprocs,1)
118c
119      do g1b=1,noab
120         if(count.eq.next) then
121c
122         if ((.not.restricted).or.(int_mb(k_spin+g1b-1).ne.2)) then
123            dima=int_mb(k_range+g1b-1)*int_mb(k_range+g1b-1)
124            if (.not.ma_push_get(mt_dbl,dima,'noname',l_a,k_a))
125     1      call errquit('ccsd_gradients: ma problem',2,ma_err)
126            call get_hash_block(d_1pdm,dbl_mb(k_a),dima,
127     1           int_mb(k_1pdm_offset),(g1b-1)+(g1b-1)*(noab+nvab))
128            do g1=1,int_mb(k_range+g1b-1)
129               dbl_mb(k_a+(g1-1)+(g1-1)*int_mb(k_range+g1b-1))=
130     1         dbl_mb(k_a+(g1-1)+(g1-1)*int_mb(k_range+g1b-1))+1.d0
131            enddo
132            call put_hash_block(d_1pdm,dbl_mb(k_a),dima,
133     1           int_mb(k_1pdm_offset),(g1b-1)+(g1b-1)*(noab+nvab))
134            if (.not.ma_pop_stack(l_a))
135     1      call errquit('ccsd_gradients: ma problem',3,ma_err)
136         endif
137         next=nxtask(nprocs,1)
138         endif
139         count=count+1
140      enddo
141      next=nxtask(-nprocs,1)
142      call ga_sync( )
143c     ====================================
144c     Do the back transformation
145c     ===================================
146      g_1pdm = ga_create_atom_blocked(geom, ao_bas_han,
147     $         'density matrix')
148      call ao_tiles(atpart2,nalength2,a2length2,30)
149      call btrans1(d_1pdm,k_1pdm_offset,g_1pdm,atpart2,nalength2)
150      call ga_symmetrize(g_1pdm)
151c     ====================================
152c     DUMP it to a file
153c     ====================================
154c      call ga_print(g_1pdm)
155       if(.not.ao_1prdm_write(nbf,g_1pdm))
156     1   call errquit('tce_ccsd_1prdm: ao_1prdm_write failed',0,0)
157c      call ga_zero(g_1pdm)
158c      call ga_print(g_1pdm)
159c      call ao_1prdm_read(nbf,g_1pdm)
160c      call ga_print(g_1pdm)
161c     =============================
162c     clean up the files and arrays
163c     =============================
164      if (.not. ga_destroy(g_1pdm)) call errquit
165     1   ('tce_ccsd_1prdm: error destroying density', 1, GA_ERR)
166c
167      call deletefile(d_1pdm)
168      if(.not.ma_pop_stack(l_1pdm_offset))
169     1  call errquit('tce_ccsd_1prdm: ma problem',17,ma_err)
170c
171      call deletefile(d_ph)
172      if(.not.ma_pop_stack(l_ph_offset))
173     1  call errquit('tce_ccsd_1prdm: ma problem',17,ma_err)
174c
175      call deletefile(d_hp)
176      if(.not.ma_pop_stack(l_hp_offset))
177     1  call errquit('tce_ccsd_1prdm: ma problem',17,ma_err)
178c
179      end
180
181c $Id$
182