1 SUBROUTINE ccsdt_lr_alpha_offdiag_15_32_1_1(d_a,k_a_offset,d_b,k_b 2 &_offset,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 i3 ( h8 h9 h10 h14 p5 p6 )_yt + = 1 * Sum ( p1 ) * t ( p1 h14 )_t * y ( h8 h9 h10 p1 p5 p6 )_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 h8b 24 INTEGER h9b 25 INTEGER h10b 26 INTEGER h14b 27 INTEGER p5b 28 INTEGER p6b 29 INTEGER dimc 30 INTEGER l_c_sort 31 INTEGER k_c_sort 32 INTEGER p1b 33 INTEGER p1b_1 34 INTEGER h14b_1 35 INTEGER h8b_2 36 INTEGER h9b_2 37 INTEGER h10b_2 38 INTEGER p5b_2 39 INTEGER p6b_2 40 INTEGER p1b_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 h8b = 1,noab 61 DO h9b = h8b,noab 62 DO h10b = h9b,noab 63 DO h14b = 1,noab 64 DO p5b = noab+1,noab+nvab 65 DO p6b = p5b,noab+nvab 66 IF (next.eq.count) THEN 67 IF ((.not.restricted).or.(int_mb(k_spin+h8b-1)+int_mb(k_spin+h9b-1 68 &)+int_mb(k_spin+h10b-1)+int_mb(k_spin+h14b-1)+int_mb(k_spin+p5b-1) 69 &+int_mb(k_spin+p6b-1).ne.12)) THEN 70 IF (int_mb(k_spin+h8b-1)+int_mb(k_spin+h9b-1)+int_mb(k_spin+h10b-1 71 &) .eq. int_mb(k_spin+h14b-1)+int_mb(k_spin+p5b-1)+int_mb(k_spin+p6 72 &b-1)) THEN 73 IF (ieor(int_mb(k_sym+h8b-1),ieor(int_mb(k_sym+h9b-1),ieor(int_mb( 74 &k_sym+h10b-1),ieor(int_mb(k_sym+h14b-1),ieor(int_mb(k_sym+p5b-1),i 75 &nt_mb(k_sym+p6b-1)))))) .eq. ieor(irrep_y,irrep_t)) THEN 76 dimc = int_mb(k_range+h8b-1) * int_mb(k_range+h9b-1) * int_mb(k_ra 77 &nge+h10b-1) * int_mb(k_range+h14b-1) * int_mb(k_range+p5b-1) * int 78 &_mb(k_range+p6b-1) 79 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL 80 & ERRQUIT('ccsdt_lr_alpha_offdiag_15_32_1_1',0,MA_ERR) 81 CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1) 82 DO p1b = noab+1,noab+nvab 83 IF (int_mb(k_spin+p1b-1) .eq. int_mb(k_spin+h14b-1)) THEN 84 IF (ieor(int_mb(k_sym+p1b-1),int_mb(k_sym+h14b-1)) .eq. irrep_t) T 85 &HEN 86 CALL TCE_RESTRICTED_2(p1b,h14b,p1b_1,h14b_1) 87 CALL TCE_RESTRICTED_6(h8b,h9b,h10b,p5b,p6b,p1b,h8b_2,h9b_2,h10b_2, 88 &p5b_2,p6b_2,p1b_2) 89 dim_common = int_mb(k_range+p1b-1) 90 dima_sort = int_mb(k_range+h14b-1) 91 dima = dim_common * dima_sort 92 dimb_sort = int_mb(k_range+h8b-1) * int_mb(k_range+h9b-1) * int_mb 93 &(k_range+h10b-1) * int_mb(k_range+p5b-1) * int_mb(k_range+p6b-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('ccsdt_lr_alpha_offdiag_15_32_1_1',1,MA_ERR) 98 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT(' 99 &ccsdt_lr_alpha_offdiag_15_32_1_1',2,MA_ERR) 100 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h14b_ 101 &1 - 1 + noab * (p1b_1 - noab - 1))) 102 CALL TCE_SORT_2(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p1b-1) 103 &,int_mb(k_range+h14b-1),2,1,1.0d0) 104 IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('ccsdt_lr_alpha_offdiag_1 105 &5_32_1_1',3,MA_ERR) 106 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL 107 & ERRQUIT('ccsdt_lr_alpha_offdiag_15_32_1_1',4,MA_ERR) 108 IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT(' 109 &ccsdt_lr_alpha_offdiag_15_32_1_1',5,MA_ERR) 110 IF ((p1b .le. p5b)) THEN 111 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p6b_2 112 & - noab - 1 + nvab * (p5b_2 - noab - 1 + nvab * (p1b_2 - noab - 1 113 &+ nvab * (h10b_2 - 1 + noab * (h9b_2 - 1 + noab * (h8b_2 - 1)))))) 114 &) 115 CALL TCE_SORT_6(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h8b-1) 116 &,int_mb(k_range+h9b-1),int_mb(k_range+h10b-1),int_mb(k_range+p1b-1 117 &),int_mb(k_range+p5b-1),int_mb(k_range+p6b-1),6,5,3,2,1,4,1.0d0) 118 END IF 119 IF ((p5b .lt. p1b) .and. (p1b .le. p6b)) THEN 120 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p6b_2 121 & - noab - 1 + nvab * (p1b_2 - noab - 1 + nvab * (p5b_2 - noab - 1 122 &+ nvab * (h10b_2 - 1 + noab * (h9b_2 - 1 + noab * (h8b_2 - 1)))))) 123 &) 124 CALL TCE_SORT_6(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h8b-1) 125 &,int_mb(k_range+h9b-1),int_mb(k_range+h10b-1),int_mb(k_range+p5b-1 126 &),int_mb(k_range+p1b-1),int_mb(k_range+p6b-1),6,4,3,2,1,5,-1.0d0) 127 END IF 128 IF ((p6b .lt. p1b)) THEN 129 CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p1b_2 130 & - noab - 1 + nvab * (p6b_2 - noab - 1 + nvab * (p5b_2 - noab - 1 131 &+ nvab * (h10b_2 - 1 + noab * (h9b_2 - 1 + noab * (h8b_2 - 1)))))) 132 &) 133 CALL TCE_SORT_6(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h8b-1) 134 &,int_mb(k_range+h9b-1),int_mb(k_range+h10b-1),int_mb(k_range+p5b-1 135 &),int_mb(k_range+p6b-1),int_mb(k_range+p1b-1),5,4,3,2,1,6,1.0d0) 136 END IF 137 IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('ccsdt_lr_alpha_offdiag_1 138 &5_32_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('ccsdt_lr_alpha_offd 143 &iag_15_32_1_1',7,MA_ERR) 144 IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('ccsdt_lr_alpha_offd 145 &iag_15_32_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 &ccsdt_lr_alpha_offdiag_15_32_1_1',9,MA_ERR) 152 CALL TCE_SORT_6(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+p6b-1) 153 &,int_mb(k_range+p5b-1),int_mb(k_range+h10b-1),int_mb(k_range+h9b-1 154 &),int_mb(k_range+h8b-1),int_mb(k_range+h14b-1),5,4,3,6,2,1,1.0d0) 155 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(p6b - 156 & noab - 1 + nvab * (p5b - noab - 1 + nvab * (h14b - 1 + noab * (h1 157 &0b - 1 + noab * (h9b - 1 + noab * (h8b - 1))))))) 158 IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('ccsdt_lr_alpha_offdiag_1 159 &5_32_1_1',10,MA_ERR) 160 IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('ccsdt_lr_alpha_offd 161 &iag_15_32_1_1',11,MA_ERR) 162 END IF 163 END IF 164 END IF 165 next = nxtask(nprocs,1) 166 END IF 167 count = count + 1 168 END DO 169 END DO 170 END DO 171 END DO 172 END DO 173 END DO 174 next = nxtask(-nprocs,1) 175 call GA_SYNC() 176 RETURN 177 END 178