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