1 SUBROUTINE wdm_pp_mo_b_b_a(d_d2,d_i0,d_v2,k_d2_offset,k_i0_offset, 2 &k_v2_offset) 3C $Id$ 4C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 5C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 6C i0 ( p1 p2 )_vd + = -1/4 * Sum ( h4 h3 p5 ) * d ( p1 p5 h3 h4 )_d * v ( h3 h4 p2 p5 )_v 7 IMPLICIT NONE 8#include "global.fh" 9#include "mafdecls.fh" 10#include "util.fh" 11#include "errquit.fh" 12#include "tce.fh" 13 INTEGER d_i0 14 INTEGER k_i0_offset 15 INTEGER d_d2 16 INTEGER k_d2_offset 17 INTEGER d_v2 18 INTEGER k_v2_offset 19 CALL wdm_pp_mo_b_b_a_1(d_d2,k_d2_offset,d_v2,k_v2_offset,d_i0,k_i0 20 &_offset) 21 RETURN 22 END 23 SUBROUTINE wdm_pp_mo_b_b_a_1(d_a,k_a_offset,d_b,k_b_offset,d_c,k_c 24 &_offset) 25C $Id$ 26C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 27C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 28C i0 ( p1 p2 )_vd + = -1/4 * Sum ( h4 h3 p5 ) * d ( p1 p5 h3 h4 )_d * v ( h3 h4 p2 p5 )_v 29 IMPLICIT NONE 30#include "global.fh" 31#include "mafdecls.fh" 32#include "sym.fh" 33#include "errquit.fh" 34#include "tce.fh" 35 INTEGER d_a 36 INTEGER k_a_offset 37 INTEGER d_b 38 INTEGER k_b_offset 39 INTEGER d_c 40 INTEGER k_c_offset 41 INTEGER nxtask 42 INTEGER next 43 INTEGER nprocs 44 INTEGER count 45 INTEGER p1b 46 INTEGER p2b 47 INTEGER dimc 48 INTEGER l_c_sort 49 INTEGER k_c_sort 50 INTEGER p5b 51 INTEGER h3b 52 INTEGER h4b 53 INTEGER p1b_1 54 INTEGER p5b_1 55 INTEGER h3b_1 56 INTEGER h4b_1 57 INTEGER h3b_2 58 INTEGER h4b_2 59 INTEGER p2b_2 60 INTEGER p5b_2 61 INTEGER dim_common 62 INTEGER dima_sort 63 INTEGER dima 64 INTEGER dimb_sort 65 INTEGER dimb 66 INTEGER l_a_sort 67 INTEGER k_a_sort 68 INTEGER l_a 69 INTEGER k_a 70 INTEGER l_b_sort 71 INTEGER k_b_sort 72 INTEGER l_b 73 INTEGER k_b 74 INTEGER nsubh(2) 75 INTEGER isubh 76 INTEGER l_c 77 INTEGER k_c 78 DOUBLE PRECISION FACTORIAL 79 EXTERNAL nxtask 80 EXTERNAL FACTORIAL 81 nprocs = GA_NNODES() 82 count = 0 83 irrep_d=0 84 next = nxtask(nprocs,1) 85 DO p1b = noab+1,noab+nvab 86 DO p2b = noab+1,noab+nvab 87 IF (next.eq.count) THEN 88 IF ((.not.restricted).or.(int_mb(k_spin+p1b-1)+int_mb(k_spin+p2b-1 89 &).ne.4)) THEN 90 IF (int_mb(k_spin+p1b-1) .eq. int_mb(k_spin+p2b-1)) THEN 91 IF (ieor(int_mb(k_sym+p1b-1),int_mb(k_sym+p2b-1)) .eq. ieor(irrep_ 92 &v,irrep_d)) THEN 93 dimc = int_mb(k_range+p1b-1) * int_mb(k_range+p2b-1) 94 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL 95 & ERRQUIT('wdm_pp_mo_b_b_a_1',0,MA_ERR) 96 CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1) 97 DO p5b = noab+1,noab+nvab 98 DO h3b = 1,noab 99 DO h4b = h3b,noab 100 IF (int_mb(k_spin+p1b-1)+int_mb(k_spin+p5b-1) .eq. int_mb(k_spin+h 101 &3b-1)+int_mb(k_spin+h4b-1)) THEN 102 IF (ieor(int_mb(k_sym+p1b-1),ieor(int_mb(k_sym+p5b-1),ieor(int_mb( 103 &k_sym+h3b-1),int_mb(k_sym+h4b-1)))) .eq. irrep_d) THEN 104 CALL TCE_RESTRICTED_4(p1b,p5b,h3b,h4b,p1b_1,p5b_1,h3b_1,h4b_1) 105 CALL TCE_RESTRICTED_4(h3b,h4b,p2b,p5b,h3b_2,h4b_2,p2b_2,p5b_2) 106 dim_common = int_mb(k_range+p5b-1) * int_mb(k_range+h3b-1) * int_m 107 &b(k_range+h4b-1) 108 dima_sort = int_mb(k_range+p1b-1) 109 dima = dim_common * dima_sort 110 dimb_sort = int_mb(k_range+p2b-1) 111 dimb = dim_common * dimb_sort 112 IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN 113 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL 114 & ERRQUIT('wdm_pp_mo_b_b_a_1',1,MA_ERR) 115 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT(' 116 &wdm_pp_mo_b_b_a_1',2,MA_ERR) 117 IF ((p5b .lt. p1b)) THEN 118c CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h4b_1 119c & - 1 + (noab+nvab) * (h3b_1 - 1 + (noab+nvab) * (p1b_1 - 1 + (noab 120c &+nvab) * (p5b_1 - 1))))) 121 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h4b_1 122 & - 1 + (noab) * (h3b_1 - 1 + (noab) * (p1b_1 - noab-1 + ( 123 & nvab) * (p5b_1 - noab-1))))) 124c 125 CALL TCE_SORT_4(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p5b-1) 126 &,int_mb(k_range+p1b-1),int_mb(k_range+h3b-1),int_mb(k_range+h4b-1) 127 &,2,4,3,1,-1.0d0) 128 END IF 129 IF ((p1b .le. p5b)) THEN 130c CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h4b_1 131c & - 1 + (noab+nvab) * (h3b_1 - 1 + (noab+nvab) * (p5b_1 - 1 + (noab 132c &+nvab) * (p1b_1 - 1))))) 133c 134 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h4b_1 135 & - 1 + (noab) * (h3b_1 - 1 + (noab) * (p5b_1 - noab-1 + ( 136 & nvab) * (p1b_1 - noab-1))))) 137c 138 CALL TCE_SORT_4(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p1b-1) 139 &,int_mb(k_range+p5b-1),int_mb(k_range+h3b-1),int_mb(k_range+h4b-1) 140 &,1,4,3,2,1.0d0) 141 END IF 142 IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('wdm_pp_mo_b_b_a_1',3,MA_ 143 &ERR) 144 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL 145 & ERRQUIT('wdm_pp_mo_b_b_a_1',4,MA_ERR) 146 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT(' 147 &wdm_pp_mo_b_b_a_1',5,MA_ERR) 148 IF ((p5b .lt. p2b)) THEN 149 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p2b_2 150 & - 1 + (noab+nvab) * (p5b_2 - 1 + (noab+nvab) * (h4b_2 - 1 + (noab 151 &+nvab) * (h3b_2 - 1))))) 152 CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h3b-1) 153 &,int_mb(k_range+h4b-1),int_mb(k_range+p5b-1),int_mb(k_range+p2b-1) 154 &,4,2,1,3,-1.0d0) 155 END IF 156 IF ((p2b .le. p5b)) THEN 157 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p5b_2 158 & - 1 + (noab+nvab) * (p2b_2 - 1 + (noab+nvab) * (h4b_2 - 1 + (noab 159 &+nvab) * (h3b_2 - 1))))) 160 CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h3b-1) 161 &,int_mb(k_range+h4b-1),int_mb(k_range+p2b-1),int_mb(k_range+p5b-1) 162 &,3,2,1,4,1.0d0) 163 END IF 164 IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('wdm_pp_mo_b_b_a_1',6,MA_ 165 &ERR) 166 nsubh(1) = 1 167 nsubh(2) = 1 168 isubh = 1 169 IF (h3b .eq. h4b) THEN 170 nsubh(isubh) = nsubh(isubh) + 1 171 ELSE 172 isubh = isubh + 1 173 END IF 174 CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,2.0d0/FACTORIAL( 175 &nsubh(1))/FACTORIAL(nsubh(2)),dbl_mb(k_a_sort),dim_common,dbl_mb(k 176 &_b_sort),dim_common,1.0d0,dbl_mb(k_c_sort),dima_sort) 177 IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('wdm_pp_mo_b_b_a_1', 178 &7,MA_ERR) 179 IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('wdm_pp_mo_b_b_a_1', 180 &8,MA_ERR) 181 END IF 182 END IF 183 END IF 184 END DO 185 END DO 186 END DO 187 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT(' 188 &wdm_pp_mo_b_b_a_1',9,MA_ERR) 189 CALL TCE_SORT_2(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+p2b-1) 190 &,int_mb(k_range+p1b-1),2,1,-1.0d0/4.0d0) 191 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(p2b - 192 & noab - 1 + nvab * (p1b - noab - 1))) 193 IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('wdm_pp_mo_b_b_a_1',10,MA 194 &_ERR) 195 IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('wdm_pp_mo_b_b_a_1', 196 &11,MA_ERR) 197 END IF 198 END IF 199 END IF 200 next = nxtask(nprocs,1) 201 END IF 202 count = count + 1 203 END DO 204 END DO 205 next = nxtask(-nprocs,1) 206 call GA_SYNC() 207 RETURN 208 END 209