1 SUBROUTINE ccsdtq_lr_alpha_15_52_12_1_1(d_a,k_a_offset,d_b,k_b_off 2 &set,d_c,k_c_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 i4 ( h9 h10 h18 h15 p3 p7 )_yt + = -1 * Sum ( p5 ) * t ( p5 h15 )_t * y ( h9 h10 h18 p3 p5 p7 )_y 7 IMPLICIT NONE 8#include "global.fh" 9#include "mafdecls.fh" 10#include "sym.fh" 11#include "errquit.fh" 12#include "tce.fh" 13 INTEGER d_a 14 INTEGER k_a_offset 15 INTEGER d_b 16 INTEGER k_b_offset 17 INTEGER d_c 18 INTEGER k_c_offset 19 INTEGER nxtask 20 INTEGER next 21 INTEGER nprocs 22 INTEGER count 23 INTEGER h9b 24 INTEGER h10b 25 INTEGER h18b 26 INTEGER h15b 27 INTEGER p3b 28 INTEGER p7b 29 INTEGER dimc 30 INTEGER l_c_sort 31 INTEGER k_c_sort 32 INTEGER p5b 33 INTEGER p5b_1 34 INTEGER h15b_1 35 INTEGER h9b_2 36 INTEGER h10b_2 37 INTEGER h18b_2 38 INTEGER p3b_2 39 INTEGER p7b_2 40 INTEGER p5b_2 41 INTEGER dim_common 42 INTEGER dima_sort 43 INTEGER dima 44 INTEGER dimb_sort 45 INTEGER dimb 46 INTEGER l_a_sort 47 INTEGER k_a_sort 48 INTEGER l_a 49 INTEGER k_a 50 INTEGER l_b_sort 51 INTEGER k_b_sort 52 INTEGER l_b 53 INTEGER k_b 54 INTEGER l_c 55 INTEGER k_c 56 EXTERNAL nxtask 57 nprocs = GA_NNODES() 58 count = 0 59 next = nxtask(nprocs,1) 60 DO h9b = 1,noab 61 DO h10b = h9b,noab 62 DO h18b = h10b,noab 63 DO h15b = 1,noab 64 DO p3b = noab+1,noab+nvab 65 DO p7b = p3b,noab+nvab 66 IF (next.eq.count) THEN 67 IF ((.not.restricted).or.(int_mb(k_spin+h9b-1)+int_mb(k_spin+h10b- 68 &1)+int_mb(k_spin+h18b-1)+int_mb(k_spin+h15b-1)+int_mb(k_spin+p3b-1 69 &)+int_mb(k_spin+p7b-1).ne.12)) THEN 70 IF (int_mb(k_spin+h9b-1)+int_mb(k_spin+h10b-1)+int_mb(k_spin+h18b- 71 &1) .eq. int_mb(k_spin+h15b-1)+int_mb(k_spin+p3b-1)+int_mb(k_spin+p 72 &7b-1)) THEN 73 IF (ieor(int_mb(k_sym+h9b-1),ieor(int_mb(k_sym+h10b-1),ieor(int_mb 74 &(k_sym+h18b-1),ieor(int_mb(k_sym+h15b-1),ieor(int_mb(k_sym+p3b-1), 75 &int_mb(k_sym+p7b-1)))))) .eq. ieor(irrep_y,irrep_t)) THEN 76 dimc = int_mb(k_range+h9b-1) * int_mb(k_range+h10b-1) * int_mb(k_r 77 &ange+h18b-1) * int_mb(k_range+h15b-1) * int_mb(k_range+p3b-1) * in 78 &t_mb(k_range+p7b-1) 79 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL 80 & ERRQUIT('ccsdtq_lr_alpha_15_52_12_1_1',0,MA_ERR) 81 CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1) 82 DO p5b = noab+1,noab+nvab 83 IF (int_mb(k_spin+p5b-1) .eq. int_mb(k_spin+h15b-1)) THEN 84 IF (ieor(int_mb(k_sym+p5b-1),int_mb(k_sym+h15b-1)) .eq. irrep_t) T 85 &HEN 86 CALL TCE_RESTRICTED_2(p5b,h15b,p5b_1,h15b_1) 87 CALL TCE_RESTRICTED_6(h9b,h10b,h18b,p3b,p7b,p5b,h9b_2,h10b_2,h18b_ 88 &2,p3b_2,p7b_2,p5b_2) 89 dim_common = int_mb(k_range+p5b-1) 90 dima_sort = int_mb(k_range+h15b-1) 91 dima = dim_common * dima_sort 92 dimb_sort = int_mb(k_range+h9b-1) * int_mb(k_range+h10b-1) * int_m 93 &b(k_range+h18b-1) * int_mb(k_range+p3b-1) * int_mb(k_range+p7b-1) 94 dimb = dim_common * dimb_sort 95 IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN 96 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL 97 & ERRQUIT('ccsdtq_lr_alpha_15_52_12_1_1',1,MA_ERR) 98 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT(' 99 &ccsdtq_lr_alpha_15_52_12_1_1',2,MA_ERR) 100 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h15b_ 101 &1 - 1 + noab * (p5b_1 - noab - 1))) 102 CALL TCE_SORT_2(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p5b-1) 103 &,int_mb(k_range+h15b-1),2,1,1.0d0) 104 IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('ccsdtq_lr_alpha_15_52_12 105 &_1_1',3,MA_ERR) 106 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL 107 & ERRQUIT('ccsdtq_lr_alpha_15_52_12_1_1',4,MA_ERR) 108 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT(' 109 &ccsdtq_lr_alpha_15_52_12_1_1',5,MA_ERR) 110 IF ((p5b .lt. p3b)) THEN 111 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p7b_2 112 & - noab - 1 + nvab * (p3b_2 - noab - 1 + nvab * (p5b_2 - noab - 1 113 &+ nvab * (h18b_2 - 1 + noab * (h10b_2 - 1 + noab * (h9b_2 - 1))))) 114 &)) 115 CALL TCE_SORT_6(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h9b-1) 116 &,int_mb(k_range+h10b-1),int_mb(k_range+h18b-1),int_mb(k_range+p5b- 117 &1),int_mb(k_range+p3b-1),int_mb(k_range+p7b-1),6,5,3,2,1,4,-1.0d0) 118 END IF 119 IF ((p3b .le. p5b) .and. (p5b .le. p7b)) THEN 120 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p7b_2 121 & - noab - 1 + nvab * (p5b_2 - noab - 1 + nvab * (p3b_2 - noab - 1 122 &+ nvab * (h18b_2 - 1 + noab * (h10b_2 - 1 + noab * (h9b_2 - 1))))) 123 &)) 124 CALL TCE_SORT_6(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h9b-1) 125 &,int_mb(k_range+h10b-1),int_mb(k_range+h18b-1),int_mb(k_range+p3b- 126 &1),int_mb(k_range+p5b-1),int_mb(k_range+p7b-1),6,4,3,2,1,5,1.0d0) 127 END IF 128 IF ((p7b .lt. p5b)) THEN 129 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p5b_2 130 & - noab - 1 + nvab * (p7b_2 - noab - 1 + nvab * (p3b_2 - noab - 1 131 &+ nvab * (h18b_2 - 1 + noab * (h10b_2 - 1 + noab * (h9b_2 - 1))))) 132 &)) 133 CALL TCE_SORT_6(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h9b-1) 134 &,int_mb(k_range+h10b-1),int_mb(k_range+h18b-1),int_mb(k_range+p3b- 135 &1),int_mb(k_range+p7b-1),int_mb(k_range+p5b-1),5,4,3,2,1,6,-1.0d0) 136 END IF 137 IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('ccsdtq_lr_alpha_15_52_12 138 &_1_1',6,MA_ERR) 139 CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,1.0d0,dbl_mb(k_a 140 &_sort),dim_common,dbl_mb(k_b_sort),dim_common,1.0d0,dbl_mb(k_c_sor 141 &t),dima_sort) 142 IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('ccsdtq_lr_alpha_15_ 143 &52_12_1_1',7,MA_ERR) 144 IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('ccsdtq_lr_alpha_15_ 145 &52_12_1_1',8,MA_ERR) 146 END IF 147 END IF 148 END IF 149 END DO 150 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT(' 151 &ccsdtq_lr_alpha_15_52_12_1_1',9,MA_ERR) 152 CALL TCE_SORT_6(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+p7b-1) 153 &,int_mb(k_range+p3b-1),int_mb(k_range+h18b-1),int_mb(k_range+h10b- 154 &1),int_mb(k_range+h9b-1),int_mb(k_range+h15b-1),5,4,3,6,2,1,-1.0d0 155 &) 156 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(p7b - 157 & noab - 1 + nvab * (p3b - noab - 1 + nvab * (h15b - 1 + noab * (h1 158 &8b - 1 + noab * (h10b - 1 + noab * (h9b - 1))))))) 159 IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('ccsdtq_lr_alpha_15_52_12 160 &_1_1',10,MA_ERR) 161 IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('ccsdtq_lr_alpha_15_ 162 &52_12_1_1',11,MA_ERR) 163 END IF 164 END IF 165 END IF 166 next = nxtask(nprocs,1) 167 END IF 168 count = count + 1 169 END DO 170 END DO 171 END DO 172 END DO 173 END DO 174 END DO 175 next = nxtask(-nprocs,1) 176 call GA_SYNC() 177 RETURN 178 END 179