1 SUBROUTINE dip_r_1_2(d_a,k_a_offset,d_b,k_b_offset,d_c,k_c_offset) 2C $Id$ 3C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 4C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) 5C i1 ( h6 p5 )_vtr + = 1 * Sum ( h4 p3 ) * tr ( p3 h4 )_tr * v ( h4 h6 p3 p5 )_v 6 IMPLICIT NONE 7#include "global.fh" 8#include "mafdecls.fh" 9#include "sym.fh" 10#include "errquit.fh" 11#include "tce.fh" 12 INTEGER d_a 13 INTEGER k_a_offset 14 INTEGER d_b 15 INTEGER k_b_offset 16 INTEGER d_c 17 INTEGER k_c_offset 18 INTEGER NXTASK 19 INTEGER next 20 INTEGER nprocs 21 INTEGER count 22 INTEGER h6b 23 INTEGER p5b 24 INTEGER dimc 25 INTEGER l_c_sort 26 INTEGER k_c_sort 27 INTEGER p3b 28 INTEGER h4b 29 INTEGER p3b_1 30 INTEGER h4b_1 31 INTEGER h6b_2 32 INTEGER h4b_2 33 INTEGER p5b_2 34 INTEGER p3b_2 35 INTEGER dim_common 36 INTEGER dima_sort 37 INTEGER dima 38 INTEGER dimb_sort 39 INTEGER dimb 40 INTEGER l_a_sort 41 INTEGER k_a_sort 42 INTEGER l_a 43 INTEGER k_a 44 INTEGER l_b_sort 45 INTEGER k_b_sort 46 INTEGER l_b 47 INTEGER k_b 48 INTEGER l_c 49 INTEGER k_c 50 EXTERNAL NXTASK 51 nprocs = GA_NNODES() 52 count = 0 53 next = NXTASK(nprocs,1) 54 DO h6b = 1,noab 55 DO p5b = noab+1,noab+nvab 56 IF (next.eq.count) THEN 57 IF ((.not.restricted).or.(int_mb(k_spin+h6b-1)+int_mb(k_spin+p5b-1 58 &).ne.4)) THEN 59 IF (int_mb(k_spin+h6b-1) .eq. int_mb(k_spin+p5b-1)) THEN 60 IF (ieor(int_mb(k_sym+h6b-1),int_mb(k_sym+p5b-1)) .eq. ieor(irrep_ 61 &v,irrep_tr)) THEN 62 dimc = int_mb(k_range+h6b-1) * int_mb(k_range+p5b-1) 63 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL 64 & ERRQUIT('dip_r_1_2',0,MA_ERR) 65 CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1) 66 DO p3b = noab+1,noab+nvab 67 DO h4b = 1,noab 68 IF (int_mb(k_spin+p3b-1) .eq. int_mb(k_spin+h4b-1)) THEN 69 IF (ieor(int_mb(k_sym+p3b-1),int_mb(k_sym+h4b-1)) .eq. irrep_tr) T 70 &HEN 71 CALL TCE_RESTRICTED_2(p3b,h4b,p3b_1,h4b_1) 72 CALL TCE_RESTRICTED_4(h6b,h4b,p5b,p3b,h6b_2,h4b_2,p5b_2,p3b_2) 73 dim_common = int_mb(k_range+p3b-1) * int_mb(k_range+h4b-1) 74 dima_sort = 1 75 dima = dim_common * dima_sort 76 dimb_sort = int_mb(k_range+h6b-1) * int_mb(k_range+p5b-1) 77 dimb = dim_common * dimb_sort 78 IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN 79 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL 80 & ERRQUIT('dip_r_1_2',1,MA_ERR) 81 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT(' 82 &dip_r_1_2',2,MA_ERR) 83 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h4b_1 84 & - 1 + noab * (p3b_1 - noab - 1))) 85 CALL TCE_SORT_2(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p3b-1) 86 &,int_mb(k_range+h4b-1),2,1,1.0d0) 87 IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('dip_r_1_2',3,MA_ERR) 88 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL 89 & ERRQUIT('dip_r_1_2',4,MA_ERR) 90 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT(' 91 &dip_r_1_2',5,MA_ERR) 92 IF ((h4b .le. h6b) .and. (p3b .le. p5b)) THEN 93 if(.not.intorb) then 94 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p5b_2 95 & - 1 + (noab+nvab) * (p3b_2 - 1 + (noab+nvab) * (h6b_2 - 1 + (noab 96 &+nvab) * (h4b_2 - 1))))) 97 else 98 CALL GET_HASH_BLOCK_I(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset), 99 &(p5b_2 100 & - 1 + (noab+nvab) * (p3b_2 - 1 + (noab+nvab) * (h6b_2 - 1 + (noab 101 &+nvab) * (h4b_2 - 1)))),p5b_2,p3b_2,h6b_2,h4b_2) 102 end if 103 CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h4b-1) 104 &,int_mb(k_range+h6b-1),int_mb(k_range+p3b-1),int_mb(k_range+p5b-1) 105 &,4,2,1,3,1.0d0) 106 END IF 107 IF ((h4b .le. h6b) .and. (p5b .lt. p3b)) THEN 108 if(.not.intorb) then 109 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p3b_2 110 & - 1 + (noab+nvab) * (p5b_2 - 1 + (noab+nvab) * (h6b_2 - 1 + (noab 111 &+nvab) * (h4b_2 - 1))))) 112 else 113 CALL GET_HASH_BLOCK_I(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset), 114 &(p3b_2 115 & - 1 + (noab+nvab) * (p5b_2 - 1 + (noab+nvab) * (h6b_2 - 1 + (noab 116 &+nvab) * (h4b_2 - 1)))),p3b_2,p5b_2,h6b_2,h4b_2) 117 end if 118 CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h4b-1) 119 &,int_mb(k_range+h6b-1),int_mb(k_range+p5b-1),int_mb(k_range+p3b-1) 120 &,3,2,1,4,-1.0d0) 121 END IF 122 IF ((h6b .lt. h4b) .and. (p3b .le. p5b)) THEN 123 if(.not.intorb) then 124 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p5b_2 125 & - 1 + (noab+nvab) * (p3b_2 - 1 + (noab+nvab) * (h4b_2 - 1 + (noab 126 &+nvab) * (h6b_2 - 1))))) 127 else 128 CALL GET_HASH_BLOCK_I(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset), 129 &(p5b_2 130 & - 1 + (noab+nvab) * (p3b_2 - 1 + (noab+nvab) * (h4b_2 - 1 + (noab 131 &+nvab) * (h6b_2 - 1)))),p5b_2,p3b_2,h4b_2,h6b_2) 132 end if 133 CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h6b-1) 134 &,int_mb(k_range+h4b-1),int_mb(k_range+p3b-1),int_mb(k_range+p5b-1) 135 &,4,1,2,3,-1.0d0) 136 END IF 137 IF ((h6b .lt. h4b) .and. (p5b .lt. p3b)) THEN 138 if(.not.intorb) then 139 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p3b_2 140 & - 1 + (noab+nvab) * (p5b_2 - 1 + (noab+nvab) * (h4b_2 - 1 + (noab 141 &+nvab) * (h6b_2 - 1))))) 142 else 143 CALL GET_HASH_BLOCK_I(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset), 144 &(p3b_2 145 & - 1 + (noab+nvab) * (p5b_2 - 1 + (noab+nvab) * (h4b_2 - 1 + (noab 146 &+nvab) * (h6b_2 - 1)))),p3b_2,p5b_2,h4b_2,h6b_2) 147 end if 148 CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h6b-1) 149 &,int_mb(k_range+h4b-1),int_mb(k_range+p5b-1),int_mb(k_range+p3b-1) 150 &,3,1,2,4,1.0d0) 151 END IF 152 IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('dip_r_1_2',6,MA_ERR) 153 CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,1.0d0,dbl_mb(k_a 154 &_sort),dim_common,dbl_mb(k_b_sort),dim_common,1.0d0,dbl_mb(k_c_sor 155 &t),dima_sort) 156 IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('dip_r_1_2',7,MA_ERR 157 &) 158 IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('dip_r_1_2',8,MA_ERR 159 &) 160 END IF 161 END IF 162 END IF 163 END DO 164 END DO 165 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT(' 166 &dip_r_1_2',9,MA_ERR) 167 CALL TCE_SORT_2(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+p5b-1) 168 &,int_mb(k_range+h6b-1),2,1,1.0d0) 169 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(p5b - 170 & noab - 1 + nvab * (h6b - 1))) 171 IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('dip_r_1_2',10,MA_ERR) 172 IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('dip_r_1_2',11,MA_ER 173 &R) 174 END IF 175 END IF 176 END IF 177 next = NXTASK(nprocs,1) 178 END IF 179 count = count + 1 180 END DO 181 END DO 182 next = NXTASK(-nprocs,1) 183 call GA_SYNC() 184 RETURN 185 END 186