1c SUBROUTINE tce_mrcc_c1_offset(size_t1m,nref,k_t1_offsetm,d_t1m) 2 SUBROUTINE tce_mrcc_c1_offset(k_t1_offsetm,d_t1m, 3 1 iref,irefnew,d_c) 4ctce_mrcc_c1_offset(k_t1_offsetm,d_t1m,iref,irefnew,d_t1c) 5 IMPLICIT NONE 6#include "global.fh" 7#include "mafdecls.fh" 8#include "sym.fh" 9#include "errquit.fh" 10#include "util.fh" 11#include "msgids.fh" 12#include "tce.fh" 13#include "tce_main.fh" 14#include "tce_mrcc.fh" 15 16 integer nprocs 17 double precision ga_dble 18 double precision ma_dble 19 integer d_off1m(maxref) 20 integer nodezero 21 integer size,sizenew 22 character*255 modelname 23 character*255 filename 24 character*3 namechunk 25 integer iref 26 integer size_t1m(maxref) 27 integer k_t1_offsetm(maxref) 28 integer l_c1,k_c1 29 integer p5b,h6b 30 integer mems 31 integer i,j,k 32 integer orbindex(2) 33 integer orbindexnew(2) 34 integer orbspin(2) 35 integer irefnew,hnew,pnew 36 integer hoff,poff 37 integer totaloff 38 integer ihash,ilength 39 integer ioff 40 integer l_t1,k_t1 41 integer l_tmp,k_tmp 42 integer d_t1m(maxref) 43 integer counter 44 integer k_a,l_a 45 integer d_c 46 integer inoabn 47 integer x,y,z 48 character*1 s,r 49 INTEGER NXTASK 50 EXTERNAL NXTASK 51 INTEGER NXTASKsub 52 EXTERNAL NXTASKsub 53 integer next,count 54 integer t 55 double precision sign 56 integer isw1,isw2 57 58 if(lusesub) then 59 60 call ga_pgroup_sync(mypgid) 61 nprocs = GA_pgroup_NNODES(mypgid) 62 count = 0 63 next = NXTASKsub(nprocs, 1,mypgid) 64 65 else 66 67 call ga_sync() 68 nprocs = GA_NNODES() 69 count = 0 70 next = NXTASK(nprocs, 1) 71 72 endif 73c 74c ------------------ 75c allocate arrays 76c ------------------ 77c 78c if(nodezero) then 79c write(6,*)'Start of tce_mrcc_c1_offset' 80c endif 81c print input arrays 82c do i=1,nref*nref 83c write(6,*)dbl_mb(k_sqc+i-1),dbl_mb(k_heff+i-1) 84c enddo 85c create file 86 87c do iref=1,nref 88c write(namechunk,"(I3.3)")iref 89c call tce_filename('off1'//namechunk,filename) 90c call createfile(filename,d_off1m(iref),size_t1m(iref)) 91c call reconcilefile(d_off1m(iref),size_t1m(iref)) 92c enddo 93c working arrays 94 95c iref = 1 96c mems = 0 97 98 do p5b = nblcks(1,iref)+nblcks(2,iref)+1,nblcks(1,iref)+ 99 1 nblcks(2,iref)+nblcks(3,iref)+nblcks(4,iref) 100 do h6b = 1,nblcks(1,iref)+nblcks(2,iref) 101 102 IF (next.eq.count) THEN 103 104 if (int_mb(k_spinm(iref)+p5b-1) .eq. 105 1 int_mb(k_spinm(iref)+h6b-1)) then 106 if (ieor(int_mb(k_symm(iref)+p5b-1),int_mb(k_symm(iref)+h6b-1)) 107 1 .eq. irrep_t) then 108 if ((.not.restricted).or.(int_mb(k_spinm(iref)+p5b-1)+ 109 1 int_mb(k_spinm(iref)+h6b-1).ne.4)) THEN 110 111c write(6,"('Block assigned',I4,I4,' TO ',I3)") 112c 1p5b,h6b,ga_nodeid() 113 114 size = int_mb(k_rangem(iref)+p5b-1) * 115 1 int_mb(k_rangem(iref)+h6b-1) 116 117c if (.not.ma_push_get(mt_dbl,size,'t1',l_t1,k_t1)) 118c 1 call errquit('tce_c1_offs: MA problem',0,MA_ERR) 119 120 if (.not.ma_push_get(mt_dbl,size,'c1',l_a,k_a)) 121 1 call errquit('tce_c1_offs: MA problem',1,MA_ERR) 122 123c call get_hash_block(d_t1m(iref),dbl_mb(k_t1),size, 124c 1 int_mb(k_t1_offsetm(iref)),((p5b-noab-1)*noab+h6b-1)) 125 126 counter = 0 127 128 do i=1,int_mb(k_rangem(iref)+p5b-1) 129 do j=1,int_mb(k_rangem(iref)+h6b-1) 130 orbspin(2) = int_mb(k_spinm(iref)+h6b-1)-1 131 orbspin(1) = int_mb(k_spinm(iref)+p5b-1)-1 132 133 dbl_mb(k_a+counter) = 0.0d0 134 counter = counter + 1 135 136c do irefnew=1,nref 137c if(irefnew.ne.iref) then 138 139 isw1 = int_mb(k_offsetm(iref)+h6b-1)+j 140 141 orbindex(1) = (1 - orbspin(1)+ 142 1 int_mb(k_mo_indexm(iref)+int_mb(k_offset+p5b-1)+i-1))/2 143 orbindex(2) = (1 - orbspin(2)+ 144 1 int_mb(k_mo_indexm(iref)+int_mb(k_offset+h6b-1)+j-1))/2 145c 146 147 orbindexnew(1) = moindexes(orbindex(1),orbspin(1)+1,iref) 148 orbindexnew(2) = moindexes(orbindex(2),orbspin(2)+1,iref) 149 150 orbindexnew(1) = moindexes(orbindexnew(1),orbspin(1)+1,irefnew) 151 orbindexnew(2) = moindexes(orbindexnew(2),orbspin(2)+1,irefnew) 152 153c orbindexnew(1) = orbindex(1) 154c orbindexnew(2) = orbindex(2) 155 156c if((orbindex(1).ne.orbindexnew(1)).or. 157c 1 (orbindex(2).ne.orbindexnew(2))) then 158c write(6,"(I2,'/',I2,'(',I5,',',I5,')','->','(',I5,',',I5,')')") 159c 1iref,irefnew,orbindex(1),orbindex(2),orbindexnew(1),orbindexnew(2) 160 161 inoabn = nblcks(1,irefnew)+nblcks(2,irefnew) 162 163 hnew = orbinblck(orbindexnew(2),orbspin(2)+1,irefnew) 164 pnew = orbinblck(orbindexnew(1),orbspin(1)+1,irefnew) 165 166 totaloff=-1 167 168 hoff = offsetinblck(orbindexnew(2),orbspin(2)+1,irefnew) 169 poff = offsetinblck(orbindexnew(1),orbspin(1)+1,irefnew) 170 171 ihash = hnew - 1 + inoabn * (pnew - inoabn - 1) 172 ilength = int_mb(k_t1_offsetm(irefnew)) 173 ioff = 0 174 totaloff = -1 175 176 do k = 1, ilength 177 if(int_mb(k_t1_offsetm(irefnew)+k).eq.ihash) then 178 totaloff = ioff 179 goto 111 180 endif 181c ioff = int_mb(k_t1_offsetm(irefnew)+k+ilength) 182 enddo 183 184 111 continue 185 186 if((pnew.le.inoabn).or. 187 1 (hnew.gt.inoabn)) then 188 totaloff=-1 189 endif 190 191 if(totaloff.ne.-1) then 192 ioff = offsetinblck(orbindexnew(1),orbspin(1)+1,irefnew)* 193 1 int_mb(k_rangem(irefnew)+hnew-1)+ 194 2 offsetinblck(orbindexnew(2),orbspin(2)+1,irefnew) 195 196 isw2 = int_mb(k_offsetm(irefnew)+hnew-1)+hoff 197 198c if(orbspin(1).eq.0) then 199c s='a' 200c else 201c s='b' 202c endif 203c if(orbspin(2).eq.0) then 204c r='a' 205c else 206c r='b' 207c endif 208 209c write(6,"(I4,I4)")iref,irefnew 210c write(6,"('[',I4,I4,']','(',I4,A1,I4,A1,')-->', 211c 1'(',I4,I4,')')") 212c 1 p5b,h6b, 213c 1 orbindex(1),s,orbindex(2),r,orbindexnew(1),orbindexnew(2) 214c call util_flush(6) 215 216 sizenew = int_mb(k_rangem(irefnew)+pnew-1) * 217 1 int_mb(k_rangem(irefnew)+hnew-1) 218 219 if (.not.ma_push_get(mt_dbl,sizenew,'tmp',l_tmp,k_tmp)) 220 1 call errquit('tce_c1_offs: MA problem',0,MA_ERR) 221 call get_hash_block(d_t1m(irefnew),dbl_mb(k_tmp),sizenew, 222 1 int_mb(k_t1_offsetm(irefnew)), 223 1 ((pnew-inoabn-1)*inoabn+hnew-1)) 224c write(6,*)(-dbl_mb(k_t1+counter-1)+dbl_mb(k_tmp+ioff)) 225c k_heff is global, c(iref) missing! 226 sign=1.0d0 227c if(mod((mod(isw1,2)+mod(isw2,2)),2).ne.0)sign=-1.0d0 228 229 dbl_mb(k_a+counter-1)=dbl_mb(k_tmp+ioff)*sign 230c write(6,"('Counter ',I4,' pnew/hnew',I4,I4,2F16.12)") 231c 1 counter,pnew,hnew,dbl_mb(k_tmp+ioff) 232c call util_flush(6) 233 234c*dbl_mb(k_heff+irefnew+(irefnew-1)*nref)* 235cdbl_mb(k_sqc+irefnew+(irefnew-1)*nref) 236 237 if (.not.ma_pop_stack(l_tmp)) 238 1 call errquit('tce_c1_offs: MA problem',1,MA_ERR) 239 endif 240 241c endif !nonzero C1 242 243c endif 244c enddo !irefnew 245 enddo 246 enddo 247 248 call put_hash_block(d_c,dbl_mb(k_a),size, 249 1 int_mb(k_t1_offsetm(iref)),((p5b-nblcks(1,iref)-nblcks(2,iref) 250 2 -1)*(nblcks(1,iref)+nblcks(2,iref))+h6b-1)) 251 252c call ma_print(dbl_mb(k_a),size,1,'C1') 253 if (.not.ma_pop_stack(l_a)) 254 1 call errquit('tce_c1_offs: MA problem',2,MA_ERR) 255 256c if (.not.ma_pop_stack(l_t1)) 257c 1 call errquit('tce_c1_offs: MA problem',1,MA_ERR) 258 259 endif 260 endif 261 endif 262 if(lusesub) then 263 next = NXTASKsub(nprocs,1,mypgid) 264 else 265 next = NXTASK(nprocs, 1) 266 endif 267 END IF 268 count = count + 1 269 270 enddo ! h6b 271 enddo ! p5b 272 273 if(lusesub) then 274 next = NXTASKsub(-nprocs,1,mypgid) 275 call GA_pgroup_SYNC(mypgid) 276 else 277 next = NXTASK(-nprocs, 1) 278 call GA_SYNC() 279 endif 280 281c write(6,"('Doubles:',I8,' Bytes:',I8)")mems,mems*8 282 283c computing offsets, offset files size equal size of amplitude files 284 285c do 286c do 287 288c enddo 289c enddo 290 291c purge memory 292 293c if (.not.ma_pop_stack(l_c1)) 294c 1 call errquit('tce_mrcc_c1: MA problem',1,MA_ERR) 295 296c delete file 297c do iref=1,nref 298c call deletefile(d_off1m(iref)) 299c enddo 300 301c if(nodezero) then 302c write(6,*)'End of procedure tce_mrcc_c1_offset' 303c endif 304c 305c -------------------- 306c deallocate arrays 307c -------------------- 308c 309 310c deleted 311 312 RETURN 313 END 314c $Id$ 315