diff --git a/src/tce/ccsd/GNUmakefile b/src/tce/ccsd/GNUmakefile index 12afc29042..91a1185ace 100644 --- a/src/tce/ccsd/GNUmakefile +++ b/src/tce/ccsd/GNUmakefile @@ -6,7 +6,7 @@ OBJ_OPTIMIZE = ccsd_e.o ccsd_t1.o ccsd_t2.o cc2_t1.o cc2_t2.o \ ccsd_1prdm.o ccsd_1prdm_hh.o ccsd_1prdm_hp.o \ ccsd_1prdm_ph.o ccsd_1prdm_pp.o \ icsd_t1.o icsd_t2.o \ - ccsd_kernels.o ccsd_t2_8.o tce_1b_dens_print.o + ccsd_kernels.o ccsd_t2_7.o ccsd_t2_8.o tce_1b_dens_print.o LIB_INCLUDES = -I../include @@ -15,14 +15,10 @@ LIBRARY = libtce.a USES_BLAS = ccsd_e.F ccsd_t1.F ccsd_t2.F cc2_t1.F cc2_t2.F \ ccsd_1prdm_hh.F ccsd_1prdm_hp.F ccsd_1prdm_ph.F \ ccsd_1prdm_pp.F ccsd_1prdm.F \ - icsd_t1.F icsd_t2.F ccsd_t2_8.F ccsd_kernels.F sd_t2_8_loops.F - + icsd_t1.F icsd_t2.F ccsd_t2_7.F ccsd_t2_8.F LIB_DEFINES = -DDEBUG_PRINT -# This replaces 3*TCE_SORT4+DGEMM with 6D loops (ccsd_kernels.F). -#LIB_DEFINES += -DUSE_LOOPS_NOT_DGEMM - # replace this with something better later ifdef USE_OPENACC_TRPDRV FOPTIONS += -DUSE_TCE_CUBLAS diff --git a/src/tce/ccsd/ccsd_t2.F b/src/tce/ccsd/ccsd_t2.F index d64ae63982..67a200a2dc 100644 --- a/src/tce/ccsd/ccsd_t2.F +++ b/src/tce/ccsd/ccsd_t2.F @@ -5424,510 +5424,6 @@ SUBROUTINE ccsd_t2_7(d_a,k_a_offset,d_b,k_b_offset,d_c,k_c_offset) - - SUBROUTINE ccsd_t2_7_1(d_a,k_a_offset,d_c,k_c_offset) -C $Id$ -C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 -C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) -C i1 ( h6 p3 h1 p5 )_v + = 1 * v ( h6 p3 h1 p5 )_v - IMPLICIT NONE -#include "global.fh" -#include "mafdecls.fh" -#include "sym.fh" -#include "errquit.fh" -#include "tce.fh" - INTEGER d_a,d_c - INTEGER k_a_offset,k_c_offset - INTEGER NXTASK,next,nprocs,count - INTEGER p3b,h6b,h1b,p5b,p3b_1,h6b_1,h1b_1,p5b_1 - INTEGER dimc - INTEGER k_as,l_as,k_a,l_a - EXTERNAL NXTASK - nprocs = GA_NNODES() - count = 0 - next = NXTASK(nprocs, 1) - DO p3b = noab+1,noab+nvab - DO h1b = 1,noab - DO p5b = noab+1,noab+nvab - DO h6b = 1,noab - IF ((.not.restricted).or.(int_mb(k_spin+p3b-1) - 1 +int_mb(k_spin+h6b-1)+int_mb(k_spin+h1b-1) - 2 +int_mb(k_spin+p5b-1).ne.8)) THEN - IF (int_mb(k_spin+p3b-1)+int_mb(k_spin+h6b-1) .eq. - 1 int_mb(k_spin+h1b-1)+int_mb(k_spin+p5b-1)) THEN - IF (ieor(int_mb(k_sym+p3b-1),ieor(int_mb(k_sym+h6b-1), - 1 ieor(int_mb(k_sym+h1b-1),int_mb(k_sym+p5b-1)))) - 2 .eq. irrep_v) THEN - IF (next.eq.count) THEN - dimc = int_mb(k_range+p3b-1) * int_mb(k_range+h6b-1) - 1 * int_mb(k_range+h1b-1) * int_mb(k_range+p5b-1) - CALL TCE_RESTRICTED_4(p3b,h6b,h1b,p5b, - 1 p3b_1,h6b_1,h1b_1,p5b_1) - IF (dimc .gt. 0) THEN - IF (.not.MA_PUSH_GET(mt_dbl,dimc,'as',l_as,k_as)) - 1 CALL ERRQUIT('ccsd_t2_7_1',0,MA_ERR) - IF (.not.MA_PUSH_GET(mt_dbl,dimc,'a',l_a,k_a)) - 1 CALL ERRQUIT('ccsd_t2_7_1',1,MA_ERR) - IF ((h6b .le. p3b) .and. (h1b .le. p5b)) THEN - if(.not.intorb) then - CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dimc, - 1 int_mb(k_a_offset),(p5b_1 - 1 + (noab+nvab) * - 2 (h1b_1 - 1 + (noab+nvab) * (p3b_1 - 1 + - 3 (noab+nvab) * (h6b_1 - 1))))) - else - CALL GET_HASH_BLOCK_I(d_a,dbl_mb(k_a),dimc, - 1 int_mb(k_a_offset),(p5b_1 - 1 + (noab+nvab) * - 2 (h1b_1 - 1 + (noab+nvab) * (p3b_1 - 1 + - 3 (noab+nvab) * (h6b_1 - 1)))), - 4 p5b_1,h1b_1,p3b_1,h6b_1) - end if - CALL TCE_SORT_4(dbl_mb(k_a),dbl_mb(k_as), - 1 int_mb(k_range+h6b-1),int_mb(k_range+p3b-1), - 2 int_mb(k_range+h1b-1),int_mb(k_range+p5b-1), - 3 2,1,3,4,1.0d0) - END IF - IF (.not.MA_POP_STACK(l_a)) - 1 CALL ERRQUIT('ccsd_t2_7_1',2,MA_ERR) - CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_as),dimc, - 1 int_mb(k_c_offset),(h6b -1 + noab * - 2 (p5b - noab -1 +nvab * (h1b - 1 + noab * - 3 ( p3b - noab -1 ))))) - IF (.not.MA_POP_STACK(l_as)) - 1 CALL ERRQUIT('ccsd_t2_7_1',5,MA_ERR) - END IF - next = NXTASK(nprocs, 1) - END IF - count = count + 1 - END IF - END IF - END IF - END DO - END DO - END DO - END DO - next = NXTASK(-nprocs, 1) - call GA_SYNC() - RETURN - END - - - - - - SUBROUTINE ccsd_t2_7_2(d_a,k_a_offset,d_b,k_b_offset,d_c,k_c_offse - &t) -C $Id$ -C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 -C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) -C i1 ( h6 p3 h1 p5 )_vt + = -1 * Sum ( p7 ) * t ( p7 h1 )_t * v ( h6 p3 p5 p7 )_v - IMPLICIT NONE -#include "global.fh" -#include "mafdecls.fh" -#include "sym.fh" -#include "errquit.fh" -#include "tce.fh" - INTEGER d_a - INTEGER k_a_offset - INTEGER d_b - INTEGER k_b_offset - INTEGER d_c - INTEGER k_c_offset - INTEGER NXTASK - INTEGER next - INTEGER nprocs - INTEGER count - INTEGER p3b - INTEGER h6b - INTEGER h1b - INTEGER p5b - INTEGER dimc - INTEGER l_cs - INTEGER k_cs - INTEGER p7b - INTEGER p7b_1 - INTEGER h1b_1 - INTEGER p3b_2 - INTEGER h6b_2 - INTEGER p5b_2 - INTEGER p7b_2 - INTEGER dim_common - INTEGER dima_sort - INTEGER dima - INTEGER dimb_sort - INTEGER dimb - INTEGER l_as - INTEGER k_as - INTEGER l_a - INTEGER k_a - INTEGER l_bs - INTEGER k_bs - INTEGER l_b - INTEGER k_b - INTEGER l_c - INTEGER k_c - integer p7b_in - EXTERNAL NXTASK - nprocs = GA_NNODES() - count = 0 - next = NXTASK(nprocs, 1) - DO p3b = noab+1,noab+nvab - DO h1b = 1,noab - DO p5b = noab+1,noab+nvab - DO h6b = 1,noab - IF ((.not.restricted).or.(int_mb(k_spin+p3b-1)+int_mb(k_spin+h6b-1 - &)+int_mb(k_spin+h1b-1)+int_mb(k_spin+p5b-1).ne.8)) THEN - IF (int_mb(k_spin+p3b-1)+int_mb(k_spin+h6b-1) .eq. int_mb(k_spin+h - &1b-1)+int_mb(k_spin+p5b-1)) THEN - IF (ieor(int_mb(k_sym+p3b-1),ieor(int_mb(k_sym+h6b-1),ieor(int_mb( - &k_sym+h1b-1),int_mb(k_sym+p5b-1)))) .eq. ieor(irrep_v,irrep_t)) TH - &EN - IF (next.eq.count) THEN - dimc = int_mb(k_range+p3b-1) * int_mb(k_range+h6b-1) * int_mb(k_ra - &nge+h1b-1) * int_mb(k_range+p5b-1) - IF (.not.MA_PUSH_GET(mt_dbl,dimc,'cs',l_cs,k_cs)) CALL - & ERRQUIT('ccsd_t2_7_2',0,MA_ERR) - CALL DFILL(dimc,0.0d0,dbl_mb(k_cs),1) -#if 0 - DO p7b = noab+1,noab+nvab -#else - do p7b_in=ga_nodeid()+1,ga_nodeid()+nvab - p7b=mod(p7b_in,nvab)+noab+1 -#endif - IF (int_mb(k_spin+p7b-1) .eq. int_mb(k_spin+h1b-1)) THEN - IF (ieor(int_mb(k_sym+p7b-1),int_mb(k_sym+h1b-1)) .eq. irrep_t) TH - &EN - CALL TCE_RESTRICTED_2(p7b,h1b,p7b_1,h1b_1) - CALL TCE_RESTRICTED_4(p3b,h6b,p5b,p7b,p3b_2,h6b_2,p5b_2,p7b_2) - dim_common = int_mb(k_range+p7b-1) - dima_sort = int_mb(k_range+h1b-1) - dima = dim_common * dima_sort - dimb_sort = int_mb(k_range+p3b-1) * int_mb(k_range+h6b-1) * int_mb - &(k_range+p5b-1) - dimb = dim_common * dimb_sort - IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN - IF (.not.MA_PUSH_GET(mt_dbl,dima,'as',l_as,k_as)) CALL - & ERRQUIT('ccsd_t2_7_2',1,MA_ERR) - IF (.not.MA_PUSH_GET(mt_dbl,dima,'a',l_a,k_a)) CALL ERRQUIT(' - &ccsd_t2_7_2',2,MA_ERR) - CALL GET_HASH_BLOCK_MA(dbl_mb(d_a),dbl_mb(k_a),dima, - & int_mb(k_a_offset),(h1b_1 - & - 1 + noab * (p7b_1 - noab - 1))) - CALL TCE_SORT_2(dbl_mb(k_a),dbl_mb(k_as),int_mb(k_range+p7b-1) - &,int_mb(k_range+h1b-1),2,1,1.0d0) - IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('ccsd_t2_7_2',3,MA_ERR) - IF (.not.MA_PUSH_GET(mt_dbl,dimb,'bs',l_bs,k_bs)) CALL - & ERRQUIT('ccsd_t2_7_2',4,MA_ERR) - IF (.not.MA_PUSH_GET(mt_dbl,dimb,'b',l_b,k_b)) CALL ERRQUIT(' - &ccsd_t2_7_2',5,MA_ERR) - IF ((h6b .le. p3b) .and. (p7b .lt. p5b)) THEN - if(.not.intorb) then - CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p5b_2 - & - 1 + (noab+nvab) * (p7b_2 - 1 + (noab+nvab) * (p3b_2 - 1 + (noab - &+nvab) * (h6b_2 - 1))))) - else - CALL GET_HASH_BLOCK_I(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset), - &(p5b_2 - & - 1 + (noab+nvab) * (p7b_2 - 1 + (noab+nvab) * (p3b_2 - 1 + (noab - &+nvab) * (h6b_2 - 1)))),p5b_2,p7b_2,p3b_2,h6b_2) - end if - CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_bs),int_mb(k_range+h6b-1) - &,int_mb(k_range+p3b-1),int_mb(k_range+p7b-1),int_mb(k_range+p5b-1) - &,4,1,2,3,-1.0d0) - END IF - IF ((h6b .le. p3b) .and. (p5b .le. p7b)) THEN - if(.not.intorb) then - CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p7b_2 - & - 1 + (noab+nvab) * (p5b_2 - 1 + (noab+nvab) * (p3b_2 - 1 + (noab - &+nvab) * (h6b_2 - 1))))) - else - CALL GET_HASH_BLOCK_I(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset), - &(p7b_2 - & - 1 + (noab+nvab) * (p5b_2 - 1 + (noab+nvab) * (p3b_2 - 1 + (noab - &+nvab) * (h6b_2 - 1)))),p7b_2,p5b_2,p3b_2,h6b_2) - end if - CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_bs),int_mb(k_range+h6b-1) - &,int_mb(k_range+p3b-1),int_mb(k_range+p5b-1),int_mb(k_range+p7b-1) - &,3,1,2,4,1.0d0) - END IF - IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('ccsd_t2_7_2',6,MA_ERR) - CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,1.0d0,dbl_mb(k_a - &s),dim_common,dbl_mb(k_bs),dim_common,1.0d0,dbl_mb(k_cs - &),dima_sort) - IF (.not.MA_POP_STACK(l_bs)) CALL ERRQUIT('ccsd_t2_7_2',7,MA_E - &RR) - IF (.not.MA_POP_STACK(l_as)) CALL ERRQUIT('ccsd_t2_7_2',8,MA_E - &RR) - END IF - END IF - END IF - END DO - IF (.not.MA_PUSH_GET(mt_dbl,dimc,'c',l_c,k_c)) CALL ERRQUIT(' - &ccsd_t2_7_2',9,MA_ERR) - CALL TCE_SORT_4(dbl_mb(k_cs),dbl_mb(k_c),int_mb(k_range+p5b-1) - &,int_mb(k_range+h6b-1),int_mb(k_range+p3b-1),int_mb(k_range+h1b-1) - &,3,2,4,1,-1.0d0) - CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset), - &(h6b -1 + noab * (p5b - noab -1 +nvab * (h1b - 1 + noab * - &( p3b - noab -1 ))))) - IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('ccsd_t2_7_2',10,MA_ERR) - IF (.not.MA_POP_STACK(l_cs)) CALL ERRQUIT('ccsd_t2_7_2',11,MA_ - &ERR) - next = NXTASK(nprocs, 1) - END IF - count = count + 1 - END IF - END IF - END IF - END DO - END DO - END DO - END DO - next = NXTASK(-nprocs, 1) - call GA_SYNC() - RETURN - END - SUBROUTINE ccsd_t2_7_3(d_a,k_a_offset,d_b,k_b_offset,d_c,k_c_offse - &t) -C $Id$ -C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 -C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) -C i1 ( h6 p3 h1 p5 )_vt + = -1/2 * Sum ( h8 p7 ) * t ( p3 p7 h1 h8 )_t * v ( h6 h8 p5 p7 )_v - IMPLICIT NONE -#include "global.fh" -#include "mafdecls.fh" -#include "sym.fh" -#include "errquit.fh" -#include "tce.fh" - INTEGER d_a - INTEGER k_a_offset - INTEGER d_b - INTEGER k_b_offset - INTEGER d_c - INTEGER k_c_offset - INTEGER NXTASK - INTEGER next - INTEGER nprocs - INTEGER count - INTEGER p3b - INTEGER h6b - INTEGER h1b - INTEGER p5b - INTEGER dimc - INTEGER l_cs - INTEGER k_cs - INTEGER p7b - INTEGER h8b - INTEGER p3b_1 - INTEGER p7b_1 - INTEGER h1b_1 - INTEGER h8b_1 - INTEGER h6b_2 - INTEGER h8b_2 - INTEGER p5b_2 - INTEGER p7b_2 - INTEGER dim_common - INTEGER dima_sort - INTEGER dima - INTEGER dimb_sort - INTEGER dimb - INTEGER l_as - INTEGER k_as - INTEGER l_a - INTEGER k_a - INTEGER l_bs - INTEGER k_bs - INTEGER l_b - INTEGER k_b - INTEGER l_c - INTEGER k_c - integer p7b_in,h8b_in - EXTERNAL NXTASK - nprocs = GA_NNODES() - count = 0 - next = NXTASK(nprocs, 1) - - DO p3b = noab+1,noab+nvab - DO h1b = 1,noab - DO p5b = noab+1,noab+nvab - DO h6b = 1,noab - IF ((.not.restricted).or.(int_mb(k_spin+p3b-1)+int_mb(k_spin+h6b-1 - &)+int_mb(k_spin+h1b-1)+int_mb(k_spin+p5b-1).ne.8)) THEN - IF (int_mb(k_spin+p3b-1)+int_mb(k_spin+h6b-1) .eq. int_mb(k_spin+h - &1b-1)+int_mb(k_spin+p5b-1)) THEN - IF (ieor(int_mb(k_sym+p3b-1),ieor(int_mb(k_sym+h6b-1),ieor(int_mb( - &k_sym+h1b-1),int_mb(k_sym+p5b-1)))) .eq. ieor(irrep_v,irrep_t)) TH - &EN - IF (next.eq.count) THEN - dimc = int_mb(k_range+p3b-1) * int_mb(k_range+h6b-1) * int_mb(k_ra - &nge+h1b-1) * int_mb(k_range+p5b-1) - IF (.not.MA_PUSH_GET(mt_dbl,dimc,'cs',l_cs,k_cs)) CALL - & ERRQUIT('ccsd_t2_7_3',0,MA_ERR) - CALL DFILL(dimc,0.0d0,dbl_mb(k_cs),1) -#if 0 - DO h8b = 1,noab - DO p7b = noab+1,noab+nvab -#else - do h8b_in=ga_nodeid(),ga_nodeid()+noab-1 - h8b=mod(h8b_in,noab)+1 - do p7b_in=ga_nodeid()+1,ga_nodeid()+nvab - p7b=mod(p7b_in,nvab)+noab+1 - -#endif - IF (int_mb(k_spin+p3b-1)+int_mb(k_spin+p7b-1) .eq. int_mb(k_spin+h - &1b-1)+int_mb(k_spin+h8b-1)) THEN - IF (ieor(int_mb(k_sym+p3b-1),ieor(int_mb(k_sym+p7b-1),ieor(int_mb( - &k_sym+h1b-1),int_mb(k_sym+h8b-1)))) .eq. irrep_t) THEN - CALL TCE_RESTRICTED_4(p3b,p7b,h1b,h8b,p3b_1,p7b_1,h1b_1,h8b_1) - CALL TCE_RESTRICTED_4(h6b,h8b,p5b,p7b,h6b_2,h8b_2,p5b_2,p7b_2) - dim_common = int_mb(k_range+p7b-1) * int_mb(k_range+h8b-1) - dima_sort = int_mb(k_range+p3b-1) * int_mb(k_range+h1b-1) - dima = dim_common * dima_sort - dimb_sort = int_mb(k_range+h6b-1) * int_mb(k_range+p5b-1) - dimb = dim_common * dimb_sort - IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN - IF (.not.MA_PUSH_GET(mt_dbl,dima,'as',l_as,k_as)) CALL - & ERRQUIT('ccsd_t2_7_3',1,MA_ERR) - IF (.not.MA_PUSH_GET(mt_dbl,dima,'a',l_a,k_a)) CALL ERRQUIT(' - &ccsd_t2_7_3',2,MA_ERR) - IF ((p7b .lt. p3b) .and. (h8b .lt. h1b)) THEN - CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h1b_1 - & - 1 + noab * (h8b_1 - 1 + noab * (p3b_1 - noab - 1 + nvab * (p7b_ - &1 - noab - 1))))) - CALL TCE_SORT_4(dbl_mb(k_a),dbl_mb(k_as),int_mb(k_range+p7b-1) - &,int_mb(k_range+p3b-1),int_mb(k_range+h8b-1),int_mb(k_range+h1b-1) - &,4,2,3,1,1.0d0) - END IF - IF ((p7b .lt. p3b) .and. (h1b .le. h8b)) THEN - CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h8b_1 - & - 1 + noab * (h1b_1 - 1 + noab * (p3b_1 - noab - 1 + nvab * (p7b_ - &1 - noab - 1))))) - CALL TCE_SORT_4(dbl_mb(k_a),dbl_mb(k_as),int_mb(k_range+p7b-1) - &,int_mb(k_range+p3b-1),int_mb(k_range+h1b-1),int_mb(k_range+h8b-1) - &,3,2,4,1,-1.0d0) - END IF - IF ((p3b .le. p7b) .and. (h8b .lt. h1b)) THEN - CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h1b_1 - & - 1 + noab * (h8b_1 - 1 + noab * (p7b_1 - noab - 1 + nvab * (p3b_ - &1 - noab - 1))))) - CALL TCE_SORT_4(dbl_mb(k_a),dbl_mb(k_as),int_mb(k_range+p3b-1) - &,int_mb(k_range+p7b-1),int_mb(k_range+h8b-1),int_mb(k_range+h1b-1) - &,4,1,3,2,-1.0d0) - END IF - IF ((p3b .le. p7b) .and. (h1b .le. h8b)) THEN - CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h8b_1 - & - 1 + noab * (h1b_1 - 1 + noab * (p7b_1 - noab - 1 + nvab * (p3b_ - &1 - noab - 1))))) - CALL TCE_SORT_4(dbl_mb(k_a),dbl_mb(k_as),int_mb(k_range+p3b-1) - &,int_mb(k_range+p7b-1),int_mb(k_range+h1b-1),int_mb(k_range+h8b-1) - &,3,1,4,2,1.0d0) - END IF - IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('ccsd_t2_7_3',3,MA_ERR) - IF (.not.MA_PUSH_GET(mt_dbl,dimb,'bs',l_bs,k_bs)) CALL - & ERRQUIT('ccsd_t2_7_3',4,MA_ERR) - IF (.not.MA_PUSH_GET(mt_dbl,dimb,'b',l_b,k_b)) CALL ERRQUIT(' - &ccsd_t2_7_3',5,MA_ERR) - IF ((h8b .lt. h6b) .and. (p7b .lt. p5b)) THEN - if(.not.intorb) then - CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p5b_2 - & - 1 + (noab+nvab) * (p7b_2 - 1 + (noab+nvab) * (h6b_2 - 1 + (noab - &+nvab) * (h8b_2 - 1))))) - else - CALL GET_HASH_BLOCK_I(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset), - &(p5b_2 - & - 1 + (noab+nvab) * (p7b_2 - 1 + (noab+nvab) * (h6b_2 - 1 + (noab - &+nvab) * (h8b_2 - 1)))),p5b_2,p7b_2,h6b_2,h8b_2) - end if - CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_bs),int_mb(k_range+h8b-1) - &,int_mb(k_range+h6b-1),int_mb(k_range+p7b-1),int_mb(k_range+p5b-1) - &,4,2,1,3,1.0d0) - END IF - IF ((h8b .lt. h6b) .and. (p5b .le. p7b)) THEN - if(.not.intorb) then - CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p7b_2 - & - 1 + (noab+nvab) * (p5b_2 - 1 + (noab+nvab) * (h6b_2 - 1 + (noab - &+nvab) * (h8b_2 - 1))))) - else - CALL GET_HASH_BLOCK_I(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset), - &(p7b_2 - & - 1 + (noab+nvab) * (p5b_2 - 1 + (noab+nvab) * (h6b_2 - 1 + (noab - &+nvab) * (h8b_2 - 1)))),p7b_2,p5b_2,h6b_2,h8b_2) - end if - CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_bs),int_mb(k_range+h8b-1) - &,int_mb(k_range+h6b-1),int_mb(k_range+p5b-1),int_mb(k_range+p7b-1) - &,3,2,1,4,-1.0d0) - END IF - IF ((h6b .le. h8b) .and. (p7b .lt. p5b)) THEN - if(.not.intorb) then - CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p5b_2 - & - 1 + (noab+nvab) * (p7b_2 - 1 + (noab+nvab) * (h8b_2 - 1 + (noab - &+nvab) * (h6b_2 - 1))))) - else - CALL GET_HASH_BLOCK_I(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset), - &(p5b_2 - & - 1 + (noab+nvab) * (p7b_2 - 1 + (noab+nvab) * (h8b_2 - 1 + (noab - &+nvab) * (h6b_2 - 1)))),p5b_2,p7b_2,h8b_2,h6b_2) - end if - CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_bs),int_mb(k_range+h6b-1) - &,int_mb(k_range+h8b-1),int_mb(k_range+p7b-1),int_mb(k_range+p5b-1) - &,4,1,2,3,-1.0d0) - END IF - IF ((h6b .le. h8b) .and. (p5b .le. p7b)) THEN - if(.not.intorb) then - CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p7b_2 - & - 1 + (noab+nvab) * (p5b_2 - 1 + (noab+nvab) * (h8b_2 - 1 + (noab - &+nvab) * (h6b_2 - 1))))) - else - CALL GET_HASH_BLOCK_I(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset), - &(p7b_2 - & - 1 + (noab+nvab) * (p5b_2 - 1 + (noab+nvab) * (h8b_2 - 1 + (noab - &+nvab) * (h6b_2 - 1)))),p7b_2,p5b_2,h8b_2,h6b_2) - end if - CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_bs),int_mb(k_range+h6b-1) - &,int_mb(k_range+h8b-1),int_mb(k_range+p5b-1),int_mb(k_range+p7b-1) - &,3,1,2,4,1.0d0) - END IF - IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('ccsd_t2_7_3',6,MA_ERR) - CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,1.0d0,dbl_mb(k_a - &s),dim_common,dbl_mb(k_bs),dim_common,1.0d0,dbl_mb(k_cs - &),dima_sort) - IF (.not.MA_POP_STACK(l_bs)) CALL ERRQUIT('ccsd_t2_7_3',7,MA_E - &RR) - IF (.not.MA_POP_STACK(l_as)) CALL ERRQUIT('ccsd_t2_7_3',8,MA_E - &RR) - END IF - END IF - END IF - END DO - END DO - IF (.not.MA_PUSH_GET(mt_dbl,dimc,'c',l_c,k_c)) CALL ERRQUIT(' - &ccsd_t2_7_3',9,MA_ERR) - CALL TCE_SORT_4(dbl_mb(k_cs),dbl_mb(k_c),int_mb(k_range+p5b-1) - &,int_mb(k_range+h6b-1),int_mb(k_range+h1b-1),int_mb(k_range+p3b-1) - &,4,2,3,1,-1.0d0/2.0d0) - CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset), - &(h6b -1 + noab * (p5b - noab -1 +nvab * (h1b - 1 + noab * - &( p3b - noab -1 ))))) - IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('ccsd_t2_7_3',10,MA_ERR) - IF (.not.MA_POP_STACK(l_cs)) CALL ERRQUIT('ccsd_t2_7_3',11,MA_ - &ERR) - next = NXTASK(nprocs, 1) - END IF - count = count + 1 - END IF - END IF - END IF - END DO - END DO - END DO - END DO - next = NXTASK(-nprocs, 1) - call GA_SYNC() - RETURN - END - - - - subroutine c2f_t2_t12(d_t1,k_t1_offset, 1 d_t2,k_t2_offset) c diff --git a/src/tce/ccsd/ccsd_t2_7.F b/src/tce/ccsd/ccsd_t2_7.F new file mode 100644 index 0000000000..166a62e151 --- /dev/null +++ b/src/tce/ccsd/ccsd_t2_7.F @@ -0,0 +1,502 @@ + SUBROUTINE ccsd_t2_7_1(d_a,k_a_offset,d_c,k_c_offset) +C $Id$ +C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 +C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) +C i1 ( h6 p3 h1 p5 )_v + = 1 * v ( h6 p3 h1 p5 )_v + IMPLICIT NONE +#include "global.fh" +#include "mafdecls.fh" +#include "sym.fh" +#include "errquit.fh" +#include "tce.fh" + INTEGER d_a,d_c + INTEGER k_a_offset,k_c_offset + INTEGER NXTASK,next,nprocs,count + INTEGER p3b,h6b,h1b,p5b,p3b_1,h6b_1,h1b_1,p5b_1 + INTEGER dimc + INTEGER k_as,l_as,k_a,l_a + EXTERNAL NXTASK + nprocs = GA_NNODES() + count = 0 + next = NXTASK(nprocs, 1) + DO p3b = noab+1,noab+nvab + DO h1b = 1,noab + DO p5b = noab+1,noab+nvab + DO h6b = 1,noab + IF ((.not.restricted).or.(int_mb(k_spin+p3b-1) + 1 +int_mb(k_spin+h6b-1)+int_mb(k_spin+h1b-1) + 2 +int_mb(k_spin+p5b-1).ne.8)) THEN + IF (int_mb(k_spin+p3b-1)+int_mb(k_spin+h6b-1) .eq. + 1 int_mb(k_spin+h1b-1)+int_mb(k_spin+p5b-1)) THEN + IF (ieor(int_mb(k_sym+p3b-1),ieor(int_mb(k_sym+h6b-1), + 1 ieor(int_mb(k_sym+h1b-1),int_mb(k_sym+p5b-1)))) + 2 .eq. irrep_v) THEN + IF (next.eq.count) THEN + dimc = int_mb(k_range+p3b-1) * int_mb(k_range+h6b-1) + 1 * int_mb(k_range+h1b-1) * int_mb(k_range+p5b-1) + CALL TCE_RESTRICTED_4(p3b,h6b,h1b,p5b, + 1 p3b_1,h6b_1,h1b_1,p5b_1) + IF (dimc .gt. 0) THEN + IF (.not.MA_PUSH_GET(mt_dbl,dimc,'as',l_as,k_as)) + 1 CALL ERRQUIT('ccsd_t2_7_1',0,MA_ERR) + IF (.not.MA_PUSH_GET(mt_dbl,dimc,'a',l_a,k_a)) + 1 CALL ERRQUIT('ccsd_t2_7_1',1,MA_ERR) + IF ((h6b .le. p3b) .and. (h1b .le. p5b)) THEN + if(.not.intorb) then + CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dimc, + 1 int_mb(k_a_offset),(p5b_1 - 1 + (noab+nvab) * + 2 (h1b_1 - 1 + (noab+nvab) * (p3b_1 - 1 + + 3 (noab+nvab) * (h6b_1 - 1))))) + else + CALL GET_HASH_BLOCK_I(d_a,dbl_mb(k_a),dimc, + 1 int_mb(k_a_offset),(p5b_1 - 1 + (noab+nvab) * + 2 (h1b_1 - 1 + (noab+nvab) * (p3b_1 - 1 + + 3 (noab+nvab) * (h6b_1 - 1)))), + 4 p5b_1,h1b_1,p3b_1,h6b_1) + end if + CALL TCE_SORT_4(dbl_mb(k_a),dbl_mb(k_as), + 1 int_mb(k_range+h6b-1),int_mb(k_range+p3b-1), + 2 int_mb(k_range+h1b-1),int_mb(k_range+p5b-1), + 3 2,1,3,4,1.0d0) + END IF + IF (.not.MA_POP_STACK(l_a)) + 1 CALL ERRQUIT('ccsd_t2_7_1',2,MA_ERR) + CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_as),dimc, + 1 int_mb(k_c_offset),(h6b -1 + noab * + 2 (p5b - noab -1 +nvab * (h1b - 1 + noab * + 3 ( p3b - noab -1 ))))) + IF (.not.MA_POP_STACK(l_as)) + 1 CALL ERRQUIT('ccsd_t2_7_1',5,MA_ERR) + END IF + next = NXTASK(nprocs, 1) + END IF + count = count + 1 + END IF + END IF + END IF + END DO + END DO + END DO + END DO + next = NXTASK(-nprocs, 1) + call GA_SYNC() + RETURN + END + + + + + + SUBROUTINE ccsd_t2_7_2(d_a,k_a_offset,d_b,k_b_offset,d_c,k_c_offse + &t) +C $Id$ +C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 +C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) +C i1 ( h6 p3 h1 p5 )_vt + = -1 * Sum ( p7 ) * t ( p7 h1 )_t * v ( h6 p3 p5 p7 )_v + IMPLICIT NONE +#include "global.fh" +#include "mafdecls.fh" +#include "sym.fh" +#include "errquit.fh" +#include "tce.fh" + INTEGER d_a + INTEGER k_a_offset + INTEGER d_b + INTEGER k_b_offset + INTEGER d_c + INTEGER k_c_offset + INTEGER NXTASK + INTEGER next + INTEGER nprocs + INTEGER count + INTEGER p3b + INTEGER h6b + INTEGER h1b + INTEGER p5b + INTEGER dimc + INTEGER l_cs + INTEGER k_cs + INTEGER p7b + INTEGER p7b_1 + INTEGER h1b_1 + INTEGER p3b_2 + INTEGER h6b_2 + INTEGER p5b_2 + INTEGER p7b_2 + INTEGER dim_common + INTEGER dima_sort + INTEGER dima + INTEGER dimb_sort + INTEGER dimb + INTEGER l_as + INTEGER k_as + INTEGER l_a + INTEGER k_a + INTEGER l_bs + INTEGER k_bs + INTEGER l_b + INTEGER k_b + INTEGER l_c + INTEGER k_c + integer p7b_in + EXTERNAL NXTASK + nprocs = GA_NNODES() + count = 0 + next = NXTASK(nprocs, 1) + DO p3b = noab+1,noab+nvab + DO h1b = 1,noab + DO p5b = noab+1,noab+nvab + DO h6b = 1,noab + IF ((.not.restricted).or.(int_mb(k_spin+p3b-1)+int_mb(k_spin+h6b-1 + &)+int_mb(k_spin+h1b-1)+int_mb(k_spin+p5b-1).ne.8)) THEN + IF (int_mb(k_spin+p3b-1)+int_mb(k_spin+h6b-1) .eq. int_mb(k_spin+h + &1b-1)+int_mb(k_spin+p5b-1)) THEN + IF (ieor(int_mb(k_sym+p3b-1),ieor(int_mb(k_sym+h6b-1),ieor(int_mb( + &k_sym+h1b-1),int_mb(k_sym+p5b-1)))) .eq. ieor(irrep_v,irrep_t)) TH + &EN + IF (next.eq.count) THEN + dimc = int_mb(k_range+p3b-1) * int_mb(k_range+h6b-1) * int_mb(k_ra + &nge+h1b-1) * int_mb(k_range+p5b-1) + IF (.not.MA_PUSH_GET(mt_dbl,dimc,'cs',l_cs,k_cs)) CALL + & ERRQUIT('ccsd_t2_7_2',0,MA_ERR) + CALL DFILL(dimc,0.0d0,dbl_mb(k_cs),1) +#if 0 + DO p7b = noab+1,noab+nvab +#else + do p7b_in=ga_nodeid()+1,ga_nodeid()+nvab + p7b=mod(p7b_in,nvab)+noab+1 +#endif + IF (int_mb(k_spin+p7b-1) .eq. int_mb(k_spin+h1b-1)) THEN + IF (ieor(int_mb(k_sym+p7b-1),int_mb(k_sym+h1b-1)) .eq. irrep_t) TH + &EN + CALL TCE_RESTRICTED_2(p7b,h1b,p7b_1,h1b_1) + CALL TCE_RESTRICTED_4(p3b,h6b,p5b,p7b,p3b_2,h6b_2,p5b_2,p7b_2) + dim_common = int_mb(k_range+p7b-1) + dima_sort = int_mb(k_range+h1b-1) + dima = dim_common * dima_sort + dimb_sort = int_mb(k_range+p3b-1) * int_mb(k_range+h6b-1) * int_mb + &(k_range+p5b-1) + dimb = dim_common * dimb_sort + IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN + IF (.not.MA_PUSH_GET(mt_dbl,dima,'as',l_as,k_as)) CALL + & ERRQUIT('ccsd_t2_7_2',1,MA_ERR) + IF (.not.MA_PUSH_GET(mt_dbl,dima,'a',l_a,k_a)) CALL ERRQUIT(' + &ccsd_t2_7_2',2,MA_ERR) + CALL GET_HASH_BLOCK_MA(dbl_mb(d_a),dbl_mb(k_a),dima, + & int_mb(k_a_offset),(h1b_1 + & - 1 + noab * (p7b_1 - noab - 1))) + CALL TCE_SORT_2(dbl_mb(k_a),dbl_mb(k_as),int_mb(k_range+p7b-1) + &,int_mb(k_range+h1b-1),2,1,1.0d0) + IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('ccsd_t2_7_2',3,MA_ERR) + IF (.not.MA_PUSH_GET(mt_dbl,dimb,'bs',l_bs,k_bs)) CALL + & ERRQUIT('ccsd_t2_7_2',4,MA_ERR) + IF (.not.MA_PUSH_GET(mt_dbl,dimb,'b',l_b,k_b)) CALL ERRQUIT(' + &ccsd_t2_7_2',5,MA_ERR) + IF ((h6b .le. p3b) .and. (p7b .lt. p5b)) THEN + if(.not.intorb) then + CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p5b_2 + & - 1 + (noab+nvab) * (p7b_2 - 1 + (noab+nvab) * (p3b_2 - 1 + (noab + &+nvab) * (h6b_2 - 1))))) + else + CALL GET_HASH_BLOCK_I(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset), + &(p5b_2 + & - 1 + (noab+nvab) * (p7b_2 - 1 + (noab+nvab) * (p3b_2 - 1 + (noab + &+nvab) * (h6b_2 - 1)))),p5b_2,p7b_2,p3b_2,h6b_2) + end if + CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_bs),int_mb(k_range+h6b-1) + &,int_mb(k_range+p3b-1),int_mb(k_range+p7b-1),int_mb(k_range+p5b-1) + &,4,1,2,3,-1.0d0) + END IF + IF ((h6b .le. p3b) .and. (p5b .le. p7b)) THEN + if(.not.intorb) then + CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p7b_2 + & - 1 + (noab+nvab) * (p5b_2 - 1 + (noab+nvab) * (p3b_2 - 1 + (noab + &+nvab) * (h6b_2 - 1))))) + else + CALL GET_HASH_BLOCK_I(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset), + &(p7b_2 + & - 1 + (noab+nvab) * (p5b_2 - 1 + (noab+nvab) * (p3b_2 - 1 + (noab + &+nvab) * (h6b_2 - 1)))),p7b_2,p5b_2,p3b_2,h6b_2) + end if + CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_bs),int_mb(k_range+h6b-1) + &,int_mb(k_range+p3b-1),int_mb(k_range+p5b-1),int_mb(k_range+p7b-1) + &,3,1,2,4,1.0d0) + END IF + IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('ccsd_t2_7_2',6,MA_ERR) + CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,1.0d0,dbl_mb(k_a + &s),dim_common,dbl_mb(k_bs),dim_common,1.0d0,dbl_mb(k_cs + &),dima_sort) + IF (.not.MA_POP_STACK(l_bs)) CALL ERRQUIT('ccsd_t2_7_2',7,MA_E + &RR) + IF (.not.MA_POP_STACK(l_as)) CALL ERRQUIT('ccsd_t2_7_2',8,MA_E + &RR) + END IF + END IF + END IF + END DO + IF (.not.MA_PUSH_GET(mt_dbl,dimc,'c',l_c,k_c)) CALL ERRQUIT(' + &ccsd_t2_7_2',9,MA_ERR) + CALL TCE_SORT_4(dbl_mb(k_cs),dbl_mb(k_c),int_mb(k_range+p5b-1) + &,int_mb(k_range+h6b-1),int_mb(k_range+p3b-1),int_mb(k_range+h1b-1) + &,3,2,4,1,-1.0d0) + CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset), + &(h6b -1 + noab * (p5b - noab -1 +nvab * (h1b - 1 + noab * + &( p3b - noab -1 ))))) + IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('ccsd_t2_7_2',10,MA_ERR) + IF (.not.MA_POP_STACK(l_cs)) CALL ERRQUIT('ccsd_t2_7_2',11,MA_ + &ERR) + next = NXTASK(nprocs, 1) + END IF + count = count + 1 + END IF + END IF + END IF + END DO + END DO + END DO + END DO + next = NXTASK(-nprocs, 1) + call GA_SYNC() + RETURN + END + + + + SUBROUTINE ccsd_t2_7_3(d_a,k_a_offset,d_b,k_b_offset,d_c,k_c_offse + &t) +C $Id$ +C This is a Fortran77 program generated by Tensor Contraction Engine v.1.0 +C Copyright (c) Battelle & Pacific Northwest National Laboratory (2002) +C i1 ( h6 p3 h1 p5 )_vt + = -1/2 * Sum ( h8 p7 ) * t ( p3 p7 h1 h8 )_t * v ( h6 h8 p5 p7 )_v + IMPLICIT NONE +#include "global.fh" +#include "mafdecls.fh" +#include "sym.fh" +#include "errquit.fh" +#include "tce.fh" + INTEGER d_a + INTEGER k_a_offset + INTEGER d_b + INTEGER k_b_offset + INTEGER d_c + INTEGER k_c_offset + INTEGER NXTASK + INTEGER next + INTEGER nprocs + INTEGER count + INTEGER p3b + INTEGER h6b + INTEGER h1b + INTEGER p5b + INTEGER dimc + INTEGER l_cs + INTEGER k_cs + INTEGER p7b + INTEGER h8b + INTEGER p3b_1 + INTEGER p7b_1 + INTEGER h1b_1 + INTEGER h8b_1 + INTEGER h6b_2 + INTEGER h8b_2 + INTEGER p5b_2 + INTEGER p7b_2 + INTEGER dim_common + INTEGER dima_sort + INTEGER dima + INTEGER dimb_sort + INTEGER dimb + INTEGER l_as + INTEGER k_as + INTEGER l_a + INTEGER k_a + INTEGER l_bs + INTEGER k_bs + INTEGER l_b + INTEGER k_b + INTEGER l_c + INTEGER k_c + integer p7b_in,h8b_in + EXTERNAL NXTASK + nprocs = GA_NNODES() + count = 0 + next = NXTASK(nprocs, 1) + + DO p3b = noab+1,noab+nvab + DO h1b = 1,noab + DO p5b = noab+1,noab+nvab + DO h6b = 1,noab + IF ((.not.restricted).or.(int_mb(k_spin+p3b-1)+int_mb(k_spin+h6b-1 + &)+int_mb(k_spin+h1b-1)+int_mb(k_spin+p5b-1).ne.8)) THEN + IF (int_mb(k_spin+p3b-1)+int_mb(k_spin+h6b-1) .eq. int_mb(k_spin+h + &1b-1)+int_mb(k_spin+p5b-1)) THEN + IF (ieor(int_mb(k_sym+p3b-1),ieor(int_mb(k_sym+h6b-1),ieor(int_mb( + &k_sym+h1b-1),int_mb(k_sym+p5b-1)))) .eq. ieor(irrep_v,irrep_t)) TH + &EN + IF (next.eq.count) THEN + dimc = int_mb(k_range+p3b-1) * int_mb(k_range+h6b-1) * int_mb(k_ra + &nge+h1b-1) * int_mb(k_range+p5b-1) + IF (.not.MA_PUSH_GET(mt_dbl,dimc,'cs',l_cs,k_cs)) CALL + & ERRQUIT('ccsd_t2_7_3',0,MA_ERR) + CALL DFILL(dimc,0.0d0,dbl_mb(k_cs),1) +#if 0 + DO h8b = 1,noab + DO p7b = noab+1,noab+nvab +#else + do h8b_in=ga_nodeid(),ga_nodeid()+noab-1 + h8b=mod(h8b_in,noab)+1 + do p7b_in=ga_nodeid()+1,ga_nodeid()+nvab + p7b=mod(p7b_in,nvab)+noab+1 + +#endif + IF (int_mb(k_spin+p3b-1)+int_mb(k_spin+p7b-1) .eq. int_mb(k_spin+h + &1b-1)+int_mb(k_spin+h8b-1)) THEN + IF (ieor(int_mb(k_sym+p3b-1),ieor(int_mb(k_sym+p7b-1),ieor(int_mb( + &k_sym+h1b-1),int_mb(k_sym+h8b-1)))) .eq. irrep_t) THEN + CALL TCE_RESTRICTED_4(p3b,p7b,h1b,h8b,p3b_1,p7b_1,h1b_1,h8b_1) + CALL TCE_RESTRICTED_4(h6b,h8b,p5b,p7b,h6b_2,h8b_2,p5b_2,p7b_2) + dim_common = int_mb(k_range+p7b-1) * int_mb(k_range+h8b-1) + dima_sort = int_mb(k_range+p3b-1) * int_mb(k_range+h1b-1) + dima = dim_common * dima_sort + dimb_sort = int_mb(k_range+h6b-1) * int_mb(k_range+p5b-1) + dimb = dim_common * dimb_sort + IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN + IF (.not.MA_PUSH_GET(mt_dbl,dima,'as',l_as,k_as)) CALL + & ERRQUIT('ccsd_t2_7_3',1,MA_ERR) + IF (.not.MA_PUSH_GET(mt_dbl,dima,'a',l_a,k_a)) CALL ERRQUIT(' + &ccsd_t2_7_3',2,MA_ERR) + IF ((p7b .lt. p3b) .and. (h8b .lt. h1b)) THEN + CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h1b_1 + & - 1 + noab * (h8b_1 - 1 + noab * (p3b_1 - noab - 1 + nvab * (p7b_ + &1 - noab - 1))))) + CALL TCE_SORT_4(dbl_mb(k_a),dbl_mb(k_as),int_mb(k_range+p7b-1) + &,int_mb(k_range+p3b-1),int_mb(k_range+h8b-1),int_mb(k_range+h1b-1) + &,4,2,3,1,1.0d0) + END IF + IF ((p7b .lt. p3b) .and. (h1b .le. h8b)) THEN + CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h8b_1 + & - 1 + noab * (h1b_1 - 1 + noab * (p3b_1 - noab - 1 + nvab * (p7b_ + &1 - noab - 1))))) + CALL TCE_SORT_4(dbl_mb(k_a),dbl_mb(k_as),int_mb(k_range+p7b-1) + &,int_mb(k_range+p3b-1),int_mb(k_range+h1b-1),int_mb(k_range+h8b-1) + &,3,2,4,1,-1.0d0) + END IF + IF ((p3b .le. p7b) .and. (h8b .lt. h1b)) THEN + CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h1b_1 + & - 1 + noab * (h8b_1 - 1 + noab * (p7b_1 - noab - 1 + nvab * (p3b_ + &1 - noab - 1))))) + CALL TCE_SORT_4(dbl_mb(k_a),dbl_mb(k_as),int_mb(k_range+p3b-1) + &,int_mb(k_range+p7b-1),int_mb(k_range+h8b-1),int_mb(k_range+h1b-1) + &,4,1,3,2,-1.0d0) + END IF + IF ((p3b .le. p7b) .and. (h1b .le. h8b)) THEN + CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(h8b_1 + & - 1 + noab * (h1b_1 - 1 + noab * (p7b_1 - noab - 1 + nvab * (p3b_ + &1 - noab - 1))))) + CALL TCE_SORT_4(dbl_mb(k_a),dbl_mb(k_as),int_mb(k_range+p3b-1) + &,int_mb(k_range+p7b-1),int_mb(k_range+h1b-1),int_mb(k_range+h8b-1) + &,3,1,4,2,1.0d0) + END IF + IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('ccsd_t2_7_3',3,MA_ERR) + IF (.not.MA_PUSH_GET(mt_dbl,dimb,'bs',l_bs,k_bs)) CALL + & ERRQUIT('ccsd_t2_7_3',4,MA_ERR) + IF (.not.MA_PUSH_GET(mt_dbl,dimb,'b',l_b,k_b)) CALL ERRQUIT(' + &ccsd_t2_7_3',5,MA_ERR) + IF ((h8b .lt. h6b) .and. (p7b .lt. p5b)) THEN + if(.not.intorb) then + CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p5b_2 + & - 1 + (noab+nvab) * (p7b_2 - 1 + (noab+nvab) * (h6b_2 - 1 + (noab + &+nvab) * (h8b_2 - 1))))) + else + CALL GET_HASH_BLOCK_I(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset), + &(p5b_2 + & - 1 + (noab+nvab) * (p7b_2 - 1 + (noab+nvab) * (h6b_2 - 1 + (noab + &+nvab) * (h8b_2 - 1)))),p5b_2,p7b_2,h6b_2,h8b_2) + end if + CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_bs),int_mb(k_range+h8b-1) + &,int_mb(k_range+h6b-1),int_mb(k_range+p7b-1),int_mb(k_range+p5b-1) + &,4,2,1,3,1.0d0) + END IF + IF ((h8b .lt. h6b) .and. (p5b .le. p7b)) THEN + if(.not.intorb) then + CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p7b_2 + & - 1 + (noab+nvab) * (p5b_2 - 1 + (noab+nvab) * (h6b_2 - 1 + (noab + &+nvab) * (h8b_2 - 1))))) + else + CALL GET_HASH_BLOCK_I(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset), + &(p7b_2 + & - 1 + (noab+nvab) * (p5b_2 - 1 + (noab+nvab) * (h6b_2 - 1 + (noab + &+nvab) * (h8b_2 - 1)))),p7b_2,p5b_2,h6b_2,h8b_2) + end if + CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_bs),int_mb(k_range+h8b-1) + &,int_mb(k_range+h6b-1),int_mb(k_range+p5b-1),int_mb(k_range+p7b-1) + &,3,2,1,4,-1.0d0) + END IF + IF ((h6b .le. h8b) .and. (p7b .lt. p5b)) THEN + if(.not.intorb) then + CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p5b_2 + & - 1 + (noab+nvab) * (p7b_2 - 1 + (noab+nvab) * (h8b_2 - 1 + (noab + &+nvab) * (h6b_2 - 1))))) + else + CALL GET_HASH_BLOCK_I(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset), + &(p5b_2 + & - 1 + (noab+nvab) * (p7b_2 - 1 + (noab+nvab) * (h8b_2 - 1 + (noab + &+nvab) * (h6b_2 - 1)))),p5b_2,p7b_2,h8b_2,h6b_2) + end if + CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_bs),int_mb(k_range+h6b-1) + &,int_mb(k_range+h8b-1),int_mb(k_range+p7b-1),int_mb(k_range+p5b-1) + &,4,1,2,3,-1.0d0) + END IF + IF ((h6b .le. h8b) .and. (p5b .le. p7b)) THEN + if(.not.intorb) then + CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p7b_2 + & - 1 + (noab+nvab) * (p5b_2 - 1 + (noab+nvab) * (h8b_2 - 1 + (noab + &+nvab) * (h6b_2 - 1))))) + else + CALL GET_HASH_BLOCK_I(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset), + &(p7b_2 + & - 1 + (noab+nvab) * (p5b_2 - 1 + (noab+nvab) * (h8b_2 - 1 + (noab + &+nvab) * (h6b_2 - 1)))),p7b_2,p5b_2,h8b_2,h6b_2) + end if + CALL TCE_SORT_4(dbl_mb(k_b),dbl_mb(k_bs),int_mb(k_range+h6b-1) + &,int_mb(k_range+h8b-1),int_mb(k_range+p5b-1),int_mb(k_range+p7b-1) + &,3,1,2,4,1.0d0) + END IF + IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('ccsd_t2_7_3',6,MA_ERR) + CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,1.0d0,dbl_mb(k_a + &s),dim_common,dbl_mb(k_bs),dim_common,1.0d0,dbl_mb(k_cs + &),dima_sort) + IF (.not.MA_POP_STACK(l_bs)) CALL ERRQUIT('ccsd_t2_7_3',7,MA_E + &RR) + IF (.not.MA_POP_STACK(l_as)) CALL ERRQUIT('ccsd_t2_7_3',8,MA_E + &RR) + END IF + END IF + END IF + END DO + END DO + IF (.not.MA_PUSH_GET(mt_dbl,dimc,'c',l_c,k_c)) CALL ERRQUIT(' + &ccsd_t2_7_3',9,MA_ERR) + CALL TCE_SORT_4(dbl_mb(k_cs),dbl_mb(k_c),int_mb(k_range+p5b-1) + &,int_mb(k_range+h6b-1),int_mb(k_range+h1b-1),int_mb(k_range+p3b-1) + &,4,2,3,1,-1.0d0/2.0d0) + CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset), + &(h6b -1 + noab * (p5b - noab -1 +nvab * (h1b - 1 + noab * + &( p3b - noab -1 ))))) + IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('ccsd_t2_7_3',10,MA_ERR) + IF (.not.MA_POP_STACK(l_cs)) CALL ERRQUIT('ccsd_t2_7_3',11,MA_ + &ERR) + next = NXTASK(nprocs, 1) + END IF + count = count + 1 + END IF + END IF + END IF + END DO + END DO + END DO + END DO + next = NXTASK(-nprocs, 1) + call GA_SYNC() + RETURN + END