/src/tce/ccsdtq_lambda/ccsdtq_lambda3_2.F

https://github.com/nwchemgit/nwchem · FORTRAN Legacy · 218 lines · 185 code · 0 blank · 33 comment · 0 complexity · 3cbfe74fb7be44eff98f57afd062ae87 MD5 · raw file 

    

  1. SUBROUTINE ccsdtq_lambda3_2(d_a,k_a_offset,d_b,k_b_offset,d_c,k_c_
    2. 

  2.      &offset)
    3. 

  3. C     $Id$
    4. 

  4. C     This is a Fortran77 program generated by Tensor Contraction Engine v.1.0
    5. 

  5. C     Copyright (c) Battelle & Pacific Northwest National Laboratory (2002)
    6. 

  6. C     i0 ( h4 h5 h6 p1 p2 p3 )_yf + = 1 * P( 9 ) * y ( h4 h5 p1 p2 )_y * i1 ( h6 p3 )_f
    7. 

  7.       IMPLICIT NONE
    8. 

  8. #include "global.fh"
    9. 

  9. #include "mafdecls.fh"
    10. 

  10. #include "sym.fh"
    11. 

  11. #include "errquit.fh"
    12. 

  12. #include "tce.fh"
    13. 

  13.       INTEGER d_a
    14. 

  14.       INTEGER k_a_offset
    15. 

  15.       INTEGER d_b
    16. 

  16.       INTEGER k_b_offset
    17. 

  17.       INTEGER d_c
    18. 

  18.       INTEGER k_c_offset
    19. 

  19.       INTEGER NXTASK
    20. 

  20.       INTEGER next
    21. 

  21.       INTEGER nprocs
    22. 

  22.       INTEGER count
    23. 

  23.       INTEGER h4b
    24. 

  24.       INTEGER h5b
    25. 

  25.       INTEGER h6b
    26. 

  26.       INTEGER p1b
    27. 

  27.       INTEGER p2b
    28. 

  28.       INTEGER p3b
    29. 

  29.       INTEGER dimc
    30. 

  30.       INTEGER l_c_sort
    31. 

  31.       INTEGER k_c_sort
    32. 

  32.       INTEGER h4b_1
    33. 

  33.       INTEGER h5b_1
    34. 

  34.       INTEGER p1b_1
    35. 

  35.       INTEGER p2b_1
    36. 

  36.       INTEGER h6b_2
    37. 

  37.       INTEGER p3b_2
    38. 

  38.       INTEGER dim_common
    39. 

  39.       INTEGER dima_sort
    40. 

  40.       INTEGER dima
    41. 

  41.       INTEGER dimb_sort
    42. 

  42.       INTEGER dimb
    43. 

  43.       INTEGER l_a_sort
    44. 

  44.       INTEGER k_a_sort
    45. 

  45.       INTEGER l_a
    46. 

  46.       INTEGER k_a
    47. 

  47.       INTEGER l_b_sort
    48. 

  48.       INTEGER k_b_sort
    49. 

  49.       INTEGER l_b
    50. 

  50.       INTEGER k_b
    51. 

  51.       INTEGER l_c
    52. 

  52.       INTEGER k_c
    53. 

  53.       EXTERNAL NXTASK
    54. 

  54.       nprocs = GA_NNODES()
    55. 

  55.       count = 0
    56. 

  56.       next = NXTASK(nprocs,1)
    57. 

  57.       DO h4b = 1,noab
    58. 

  58.       DO h5b = h4b,noab
    59. 

  59.       DO h6b = 1,noab
    60. 

  60.       DO p1b = noab+1,noab+nvab
    61. 

  61.       DO p2b = p1b,noab+nvab
    62. 

  62.       DO p3b = noab+1,noab+nvab
    63. 

  63.       IF (next.eq.count) THEN
    64. 

  64.       IF ((.not.restricted).or.(int_mb(k_spin+h4b-1)+int_mb(k_spin+h5b-1
    65. 

  65.      &)+int_mb(k_spin+h6b-1)+int_mb(k_spin+p1b-1)+int_mb(k_spin+p2b-1)+i
    66. 

  66.      &nt_mb(k_spin+p3b-1).ne.12)) THEN
    67. 

  67.       IF (int_mb(k_spin+h4b-1)+int_mb(k_spin+h5b-1)+int_mb(k_spin+h6b-1)
    68. 

  68.      & .eq. int_mb(k_spin+p1b-1)+int_mb(k_spin+p2b-1)+int_mb(k_spin+p3b-
    69. 

  69.      &1)) THEN
    70. 

  70.       IF (ieor(int_mb(k_sym+h4b-1),ieor(int_mb(k_sym+h5b-1),ieor(int_mb(
    71. 

  71.      &k_sym+h6b-1),ieor(int_mb(k_sym+p1b-1),ieor(int_mb(k_sym+p2b-1),int
    72. 

  72.      &_mb(k_sym+p3b-1)))))) .eq. ieor(irrep_y,irrep_f)) THEN
    73. 

  73.       dimc = int_mb(k_range+h4b-1) * int_mb(k_range+h5b-1) * int_mb(k_ra
    74. 

  74.      &nge+h6b-1) * int_mb(k_range+p1b-1) * int_mb(k_range+p2b-1) * int_m
    75. 

  75.      &b(k_range+p3b-1)
    76. 

  76.       IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c_sort,k_c_sort)) CALL
    77. 

  77.      & ERRQUIT('ccsdtq_lambda3_2',0,MA_ERR)
    78. 

  78.       CALL DFILL(dimc,0.0d0,dbl_mb(k_c_sort),1)
    79. 

  79.       IF (int_mb(k_spin+h4b-1)+int_mb(k_spin+h5b-1) .eq. int_mb(k_spin+p
    80. 

  80.      &1b-1)+int_mb(k_spin+p2b-1)) THEN
    81. 

  81.       IF (ieor(int_mb(k_sym+h4b-1),ieor(int_mb(k_sym+h5b-1),ieor(int_mb(
    82. 

  82.      &k_sym+p1b-1),int_mb(k_sym+p2b-1)))) .eq. irrep_y) THEN
    83. 

  83.       CALL TCE_RESTRICTED_4(h4b,h5b,p1b,p2b,h4b_1,h5b_1,p1b_1,p2b_1)
    84. 

  84.       CALL TCE_RESTRICTED_2(h6b,p3b,h6b_2,p3b_2)
    85. 

  85.       dim_common = 1
    86. 

  86.       dima_sort = int_mb(k_range+h4b-1) * int_mb(k_range+h5b-1) * int_mb
    87. 

  87.      &(k_range+p1b-1) * int_mb(k_range+p2b-1)
    88. 

  88.       dima = dim_common * dima_sort
    89. 

  89.       dimb_sort = int_mb(k_range+h6b-1) * int_mb(k_range+p3b-1)
    90. 

  90.       dimb = dim_common * dimb_sort
    91. 

  91.       IF ((dima .gt. 0) .and. (dimb .gt. 0)) THEN
    92. 

  92.       IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a_sort,k_a_sort)) CALL
    93. 

  93.      & ERRQUIT('ccsdtq_lambda3_2',1,MA_ERR)
    94. 

  94.       IF (.not.MA_PUSH_GET(mt_dbl,dima,'noname',l_a,k_a)) CALL ERRQUIT('
    95. 

  95.      &ccsdtq_lambda3_2',2,MA_ERR)
    96. 

  96.       CALL GET_HASH_BLOCK(d_a,dbl_mb(k_a),dima,int_mb(k_a_offset),(p2b_1
    97. 

  97.      & - noab - 1 + nvab * (p1b_1 - noab - 1 + nvab * (h5b_1 - 1 + noab 
    98. 

  98.      &* (h4b_1 - 1)))))
    99. 

  99.       CALL TCE_SORT_4(dbl_mb(k_a),dbl_mb(k_a_sort),int_mb(k_range+h4b-1)
    100. 

  100.      &,int_mb(k_range+h5b-1),int_mb(k_range+p1b-1),int_mb(k_range+p2b-1)
    101. 

  101.      &,4,3,2,1,1.0d0)
    102. 

  102.       IF (.not.MA_POP_STACK(l_a)) CALL ERRQUIT('ccsdtq_lambda3_2',3,MA_E
    103. 

  103.      &RR)
    104. 

  104.       IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b_sort,k_b_sort)) CALL
    105. 

  105.      & ERRQUIT('ccsdtq_lambda3_2',4,MA_ERR)
    106. 

  106.       IF (.not.MA_PUSH_GET(mt_dbl,dimb,'noname',l_b,k_b)) CALL ERRQUIT('
    107. 

  107.      &ccsdtq_lambda3_2',5,MA_ERR)
    108. 

  108.       CALL GET_HASH_BLOCK(d_b,dbl_mb(k_b),dimb,int_mb(k_b_offset),(p3b_2
    109. 

  109.      & - noab - 1 + nvab * (h6b_2 - 1)))
    110. 

  110.       CALL TCE_SORT_2(dbl_mb(k_b),dbl_mb(k_b_sort),int_mb(k_range+h6b-1)
    111. 

  111.      &,int_mb(k_range+p3b-1),2,1,1.0d0)
    112. 

  112.       IF (.not.MA_POP_STACK(l_b)) CALL ERRQUIT('ccsdtq_lambda3_2',6,MA_E
    113. 

  113.      &RR)
    114. 

  114.       CALL DGEMM('T','N',dima_sort,dimb_sort,dim_common,1.0d0,dbl_mb(k_a
    115. 

  115.      &_sort),dim_common,dbl_mb(k_b_sort),dim_common,1.0d0,dbl_mb(k_c_sor
    116. 

  116.      &t),dima_sort)
    117. 

  117.       IF (.not.MA_POP_STACK(l_b_sort)) CALL ERRQUIT('ccsdtq_lambda3_2',7
    118. 

  118.      &,MA_ERR)
    119. 

  119.       IF (.not.MA_POP_STACK(l_a_sort)) CALL ERRQUIT('ccsdtq_lambda3_2',8
    120. 

  120.      &,MA_ERR)
    121. 

  121.       END IF
    122. 

  122.       END IF
    123. 

  123.       END IF
    124. 

  124.       IF (.not.MA_PUSH_GET(mt_dbl,dimc,'noname',l_c,k_c)) CALL ERRQUIT('
    125. 

  125.      &ccsdtq_lambda3_2',9,MA_ERR)
    126. 

  126.       IF ((h5b .le. h6b) .and. (p2b .le. p3b)) THEN
    127. 

  127.       CALL TCE_SORT_6(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+p3b-1)
    128. 

  128.      &,int_mb(k_range+h6b-1),int_mb(k_range+p2b-1),int_mb(k_range+p1b-1)
    129. 

  129.      &,int_mb(k_range+h5b-1),int_mb(k_range+h4b-1),6,5,2,4,3,1,1.0d0)
    130. 

  130.       CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(p3b -
    131. 

  131.      & noab - 1 + nvab * (p2b - noab - 1 + nvab * (p1b - noab - 1 + nvab
    132. 

  132.      & * (h6b - 1 + noab * (h5b - 1 + noab * (h4b - 1)))))))
    133. 

  133.       END IF
    134. 

  134.       IF ((h5b .le. h6b) .and. (p3b .le. p1b)) THEN
    135. 

  135.       CALL TCE_SORT_6(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+p3b-1)
    136. 

  136.      &,int_mb(k_range+h6b-1),int_mb(k_range+p2b-1),int_mb(k_range+p1b-1)
    137. 

  137.      &,int_mb(k_range+h5b-1),int_mb(k_range+h4b-1),6,5,2,1,4,3,1.0d0)
    138. 

  138.       CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(p2b -
    139. 

  139.      & noab - 1 + nvab * (p1b - noab - 1 + nvab * (p3b - noab - 1 + nvab
    140. 

  140.      & * (h6b - 1 + noab * (h5b - 1 + noab * (h4b - 1)))))))
    141. 

  141.       END IF
    142. 

  142.       IF ((h5b .le. h6b) .and. (p1b .le. p3b) .and. (p3b .le. p2b)) THEN
    143. 

  143.       CALL TCE_SORT_6(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+p3b-1)
    144. 

  144.      &,int_mb(k_range+h6b-1),int_mb(k_range+p2b-1),int_mb(k_range+p1b-1)
    145. 

  145.      &,int_mb(k_range+h5b-1),int_mb(k_range+h4b-1),6,5,2,4,1,3,-1.0d0)
    146. 

  146.       CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(p2b -
    147. 

  147.      & noab - 1 + nvab * (p3b - noab - 1 + nvab * (p1b - noab - 1 + nvab
    148. 

  148.      & * (h6b - 1 + noab * (h5b - 1 + noab * (h4b - 1)))))))
    149. 

  149.       END IF
    150. 

  150.       IF ((h6b .le. h4b) .and. (p2b .le. p3b)) THEN
    151. 

  151.       CALL TCE_SORT_6(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+p3b-1)
    152. 

  152.      &,int_mb(k_range+h6b-1),int_mb(k_range+p2b-1),int_mb(k_range+p1b-1)
    153. 

  153.      &,int_mb(k_range+h5b-1),int_mb(k_range+h4b-1),2,6,5,4,3,1,1.0d0)
    154. 

  154.       CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(p3b -
    155. 

  155.      & noab - 1 + nvab * (p2b - noab - 1 + nvab * (p1b - noab - 1 + nvab
    156. 

  156.      & * (h5b - 1 + noab * (h4b - 1 + noab * (h6b - 1)))))))
    157. 

  157.       END IF
    158. 

  158.       IF ((h6b .le. h4b) .and. (p3b .le. p1b)) THEN
    159. 

  159.       CALL TCE_SORT_6(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+p3b-1)
    160. 

  160.      &,int_mb(k_range+h6b-1),int_mb(k_range+p2b-1),int_mb(k_range+p1b-1)
    161. 

  161.      &,int_mb(k_range+h5b-1),int_mb(k_range+h4b-1),2,6,5,1,4,3,1.0d0)
    162. 

  162.       CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(p2b -
    163. 

  163.      & noab - 1 + nvab * (p1b - noab - 1 + nvab * (p3b - noab - 1 + nvab
    164. 

  164.      & * (h5b - 1 + noab * (h4b - 1 + noab * (h6b - 1)))))))
    165. 

  165.       END IF
    166. 

  166.       IF ((h6b .le. h4b) .and. (p1b .le. p3b) .and. (p3b .le. p2b)) THEN
    167. 

  167.       CALL TCE_SORT_6(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+p3b-1)
    168. 

  168.      &,int_mb(k_range+h6b-1),int_mb(k_range+p2b-1),int_mb(k_range+p1b-1)
    169. 

  169.      &,int_mb(k_range+h5b-1),int_mb(k_range+h4b-1),2,6,5,4,1,3,-1.0d0)
    170. 

  170.       CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(p2b -
    171. 

  171.      & noab - 1 + nvab * (p3b - noab - 1 + nvab * (p1b - noab - 1 + nvab
    172. 

  172.      & * (h5b - 1 + noab * (h4b - 1 + noab * (h6b - 1)))))))
    173. 

  173.       END IF
    174. 

  174.       IF ((h4b .le. h6b) .and. (h6b .le. h5b) .and. (p2b .le. p3b)) THEN
    175. 

  175.       CALL TCE_SORT_6(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+p3b-1)
    176. 

  176.      &,int_mb(k_range+h6b-1),int_mb(k_range+p2b-1),int_mb(k_range+p1b-1)
    177. 

  177.      &,int_mb(k_range+h5b-1),int_mb(k_range+h4b-1),6,2,5,4,3,1,-1.0d0)
    178. 

  178.       CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(p3b -
    179. 

  179.      & noab - 1 + nvab * (p2b - noab - 1 + nvab * (p1b - noab - 1 + nvab
    180. 

  180.      & * (h5b - 1 + noab * (h6b - 1 + noab * (h4b - 1)))))))
    181. 

  181.       END IF
    182. 

  182.       IF ((h4b .le. h6b) .and. (h6b .le. h5b) .and. (p3b .le. p1b)) THEN
    183. 

  183.       CALL TCE_SORT_6(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+p3b-1)
    184. 

  184.      &,int_mb(k_range+h6b-1),int_mb(k_range+p2b-1),int_mb(k_range+p1b-1)
    185. 

  185.      &,int_mb(k_range+h5b-1),int_mb(k_range+h4b-1),6,2,5,1,4,3,-1.0d0)
    186. 

  186.       CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(p2b -
    187. 

  187.      & noab - 1 + nvab * (p1b - noab - 1 + nvab * (p3b - noab - 1 + nvab
    188. 

  188.      & * (h5b - 1 + noab * (h6b - 1 + noab * (h4b - 1)))))))
    189. 

  189.       END IF
    190. 

  190.       IF ((h4b .le. h6b) .and. (h6b .le. h5b) .and. (p1b .le. p3b) .and.
    191. 

  191.      & (p3b .le. p2b)) THEN
    192. 

  192.       CALL TCE_SORT_6(dbl_mb(k_c_sort),dbl_mb(k_c),int_mb(k_range+p3b-1)
    193. 

  193.      &,int_mb(k_range+h6b-1),int_mb(k_range+p2b-1),int_mb(k_range+p1b-1)
    194. 

  194.      &,int_mb(k_range+h5b-1),int_mb(k_range+h4b-1),6,2,5,4,1,3,1.0d0)
    195. 

  195.       CALL ADD_HASH_BLOCK(d_c,dbl_mb(k_c),dimc,int_mb(k_c_offset),(p2b -
    196. 

  196.      & noab - 1 + nvab * (p3b - noab - 1 + nvab * (p1b - noab - 1 + nvab
    197. 

  197.      & * (h5b - 1 + noab * (h6b - 1 + noab * (h4b - 1)))))))
    198. 

  198.       END IF
    199. 

  199.       IF (.not.MA_POP_STACK(l_c)) CALL ERRQUIT('ccsdtq_lambda3_2',10,MA_
    200. 

  200.      &ERR)
    201. 

  201.       IF (.not.MA_POP_STACK(l_c_sort)) CALL ERRQUIT('ccsdtq_lambda3_2',1
    202. 

  202.      &1,MA_ERR)
    203. 

  203.       END IF
    204. 

  204.       END IF
    205. 

  205.       END IF
    206. 

  206.       next = NXTASK(nprocs,1)
    207. 

  207.       END IF
    208. 

  208.       count = count + 1
    209. 

  209.       END DO
    210. 

  210.       END DO
    211. 

  211.       END DO
    212. 

  212.       END DO
    213. 

  213.       END DO
    214. 

  214.       END DO
    215. 

  215.       next = NXTASK(-nprocs,1)
    216. 

  216.       call GA_SYNC()
    217. 

  217.       RETURN
    218. 

  218.       END
    219.