1 SUBROUTINE alpha_1_1_1(d_a,k_a_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 ( p2 h1 )_tr + = 1 * tr ( p2 h1 )_tr 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_c 15 INTEGER k_c_offset 16 INTEGER NXTASK 17 INTEGER next 18 INTEGER nprocs 19 INTEGER count 20 INTEGER p2b 21 INTEGER h1b 22 INTEGER dimc 23 INTEGER p2b_1 24 INTEGER h1b_1 25 INTEGER dim_common 26 INTEGER dima_sort 27 INTEGER dima 28 INTEGER l_a_sort 29 INTEGER k_a_sort 30 INTEGER l_a 31 INTEGER k_a 32 INTEGER l_c 33 INTEGER k_c 34 EXTERNAL NXTASK 35 nprocs = GA_NNODES() 36 count = 0 37 next = NXTASK(nprocs,1) 38 DO p2b = noab+1,noab+nvab 39 DO h1b = 1,noab 40 IF (next.eq.count) THEN 41 IF ((.not.restricted).or.(int_mb(k_spin+p2b-1)+int_mb(k_spin+h1b-1 42 &).ne.4)) THEN 43 IF (int_mb(k_spin+p2b-1) .eq. int_mb(k_spin+h1b-1)) THEN 44 IF (ieor(int_mb(k_sym+p2b-1),int_mb(k_sym+h1b-1)) .eq. irrep_tr) T 45 &HEN 46 dimc = int_mb(k_range+p2b-1) * int_mb(k_range+h1b-1) 47 CALL TCE_RESTRICTED_2(p2b,h1b,p2b_1,h1b_1) 48 dim_common = 1 49 dima_sort = int_mb(k_range+p2b-1) * int_mb(k_range+h1b-1) 50 dima = dim_common * dima_sort 51 IF (dima .gt. 0) THEN 52 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL 53 & ERRQUIT('alpha_1_1_1',0,MA_ERR) 54 IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT(' 55 &alpha_1_1_1',1,MA_ERR) 56 CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h1b_1 57 & - 1 + noab * (p2b_1 - noab - 1))) 58 CALL TCE_SORT_2(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+p2b-1) 59 &,int_mb(k_range+h1b-1),2,1,1.0d0) 60 IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('alpha_1_1_1',2,MA_ERR) 61 IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT(' 62 &alpha_1_1_1',3,MA_ERR) 63 CALL TCE_SORT_2(dbl_mb(k_a_sort),dbl_mb(k_c),int_mb(k_range+h1b-1) 64 &,int_mb(k_range+p2b-1),2,1,1.0d0) 65 CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(h1b - 66 & 1 + noab * (p2b - noab - 1))) 67 IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('alpha_1_1_1',4,MA_ERR) 68 IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('alpha_1_1_1',5,MA_E 69 &RR) 70 END IF 71 END IF 72 END IF 73 END IF 74 next = NXTASK(nprocs,1) 75 END IF 76 count = count + 1 77 END DO 78 END DO 79 next = NXTASK(-nprocs,1) 80 call GA_SYNC() 81 RETURN 82 END 83