gcc/testsuite/gfortran.dg/pr68251.f90

   1 ! PR middle-end/68251
   2 ! Reduced testcase by Joost VandeVondele <Joost.VandeVondele@mat.ethz.ch>
   3
   4 ! { dg-do compile }
   5 ! { dg-options "-O3" }
   6
   7 MODULE hfx_contract_block
   8   INTEGER, PARAMETER :: dp=8
   9 CONTAINS
  10   SUBROUTINE contract_block(ma_max,mb_max,mc_max,md_max,kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale)
  11     REAL(KIND=dp) :: kbd(mb_max*md_max), kbc(mb_max*mc_max), &
  12       kad(ma_max*md_max), kac(ma_max*mc_max), pbd(mb_max*md_max), &
  13       pbc(mb_max*mc_max), pad(ma_max*md_max), pac(ma_max*mc_max), &
  14       prim(ma_max*mb_max*mc_max*md_max), scale
  15     SELECT CASE(ma_max)
  16     CASE(1)
  17       SELECT CASE(mb_max)
  18       CASE(1)
  19         SELECT CASE(mc_max)
  20         CASE(1)
  21           SELECT CASE(md_max)
  22           CASE(1)
  23             CALL block_1_1_1_1(kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale)
  24             CALL block_1_1_1_2(kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale)
  25             CALL block_1_1_11(md_max,kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale)
  26           END SELECT
  27         END SELECT
  28         SELECT CASE(mc_max)
  29         CASE(1)
  30           SELECT CASE(md_max)
  31           CASE(2)
  32             CALL block_1_2_1_2(kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale)
  33             CALL block_1_2_1_3(kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale)
  34             CALL block_1_2_1_4(kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale)
  35             CALL block_1_2_1_5(kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale)
  36             CALL block_1_2_1_6(kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale)
  37             CALL block_1_2_1_7(kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale)
  38             CALL block_1_2_2_2(kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale)
  39             CALL block_1_2_2_4(kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale)
  40             CALL block_1_2_4_1(kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale)
  41             CALL block_1_2_6_1(kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale)
  42           END SELECT
  43           SELECT CASE(md_max)
  44           CASE(1)
  45             CALL block_1_2_7_1(kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale)
  46           END SELECT
  47         END SELECT
  48         SELECT CASE(mc_max)
  49         CASE(1)
  50           SELECT CASE(md_max)
  51           CASE(1)
  52             CALL block_1_3_1_1(kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale)
  53             CALL block_1_3_1_3(kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale)
  54             CALL block_1_3_1_4(kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale)
  55             CALL block_1_3_1_5(kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale)
  56             CALL block_1_3_1_6(kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale)
  57             CALL block_1_3_1(md_max,kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale)
  58             CALL block_1_3_2_1(kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale)
  59             CALL block_1_3_2_2(kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale)
  60             CALL block_1_3_2_3(kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale)
  61           END SELECT
  62           SELECT CASE(md_max)
  63           CASE(1)
  64             CALL block_1_3_3_1(kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale)
  65             CALL block_1_3_3_2(kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale)
  66           END SELECT
  67           SELECT CASE(md_max)
  68           CASE(1)
  69             CALL block_1_3_5(md_max,kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale)
  70             CALL block_1_3_5(md_max,kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale)
  71           END SELECT
  72         END SELECT
  73         SELECT CASE(mc_max)
  74         CASE(1)
  75           SELECT CASE(md_max)
  76           CASE(1)
  77             CALL block_1_4_1_1(kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale)
  78             CALL block_1_4_1_2(kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale)
  79             CALL block_1_4_1_3(kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale)
  80           END SELECT
  81           SELECT CASE(md_max)
  82           CASE(1)
  83             CALL block_1_4_2_1(kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale)
  84             CALL block_1_4_2_2(kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale)
  85             CALL block_1_4_3_1(kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale)
  86             CALL block_1_4_3(md_max,kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale)
  87             CALL block_1_4_3(md_max,kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale)
  88             CALL block_1_4_3(md_max,kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale)
  89             CALL block_1_4_3(md_max,kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale)
  90             CALL block_1_4_3(md_max,kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale)
  91             CALL block_1_4_3(md_max,kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale)
  92             CALL block_1_4_3(md_max,kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale)
  93             CALL block_1_4_3(md_max,kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale)
  94             CALL block_1_4_4_1(kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale)
  95             CALL block_1_4_4(md_max,kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale)
  96           END SELECT
  97           SELECT CASE(md_max)
  98           CASE(1)
  99             CALL block_1_5_1_3(kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale)
 100             CALL block_1_5_1(md_max,kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale)
 101             CALL block_1_5_1(md_max,kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale)
 102             CALL block_1_5_1(md_max,kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale)
 103             CALL block_1_5_1(md_max,kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale)
 104             CALL block_1_5_1(md_max,kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale)
 105             CALL block_1_5_1(md_max,kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale)
 106             CALL block_1_5_1(md_max,kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale)
 107           END SELECT
 108           SELECT CASE(md_max)
 109           CASE(1)
 110             CALL block_1_6_1_1(kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale)
 111             CALL block_1_6_1_2(kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale)
 112             CALL block_1_6_1_3(kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale)
 113           END SELECT
 114           SELECT CASE(md_max)
 115           CASE(1)
 116             CALL block_1_6_2_1(kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale)
 117           END SELECT
 118         END SELECT
 119         SELECT CASE(mc_max)
 120         CASE(1)
 121           SELECT CASE(md_max)
 122           END SELECT
 123         END SELECT
 124       END SELECT
 125       SELECT CASE(mb_max)
 126       CASE(1)
 127         SELECT CASE(mc_max)
 128         CASE(1)
 129           SELECT CASE(md_max)
 130           CASE(1)
 131             CALL block_2_1_1_3(kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale)
 132             CALL block_2_1_1_4(kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale)
 133             CALL block_2_1_1_5(kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale)
 134             CALL block_2_1_1_6(kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale)
 135             CALL block_2_1_2_1(kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale)
 136             CALL block_2_1_2_2(kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale)
 137             CALL block_2_1_2_4(kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale)
 138           END SELECT
 139         END SELECT
 140         SELECT CASE(mc_max)
 141         CASE(1)
 142           SELECT CASE(md_max)
 143           CASE(1)
 144             CALL block_2_2_1_1(kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale)
 145             CALL block_2_2_2_1(kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale)
 146             CALL block_2_2_3_1(kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale)
 147           END SELECT
 148         END SELECT
 149         SELECT CASE(mc_max)
 150         CASE(1)
 151           SELECT CASE(md_max)
 152           CASE(7)
 153             CALL block_3_2_1(md_max,kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale)
 154             CALL block_3_2_1(md_max,kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale)
 155             CALL block_3_2_1(md_max,kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale)
 156             CALL block_3_2_1(md_max,kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale)
 157             CALL block_3_2_1(md_max,kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale)
 158           END SELECT
 159         END SELECT
 160         SELECT CASE(mc_max)
 161         CASE(1)
 162           SELECT CASE(md_max)
 163           CASE(1)
 164             CALL block_3_5_1_1(kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale)
 165             CALL block_3_5_1(md_max,kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale)
 166             CALL block_3_5_1(md_max,kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale)
 167             CALL block_3_5_1(md_max,kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale)
 168             CALL block_3_5_1(md_max,kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale)
 169             CALL block_3_5_1(md_max,kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale)
 170             CALL block_3_5_1(md_max,kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale)
 171             CALL block_3_5_1(md_max,kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale)
 172             CALL block_3_5_1(md_max,kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale)
 173             CALL block_3_5_1(md_max,kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale)
 174             CALL block_3_5_1(md_max,kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale)
 175           END SELECT
 176           CALL block_3_6(mc_max,md_max,kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale)
 177           CALL block_3_6(mc_max,md_max,kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale)
 178           CALL block_3_6(mc_max,md_max,kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale)
 179           CALL block_3_6(mc_max,md_max,kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale)
 180           CALL block_3_6(mc_max,md_max,kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale)
 181           CALL block_3_6(mc_max,md_max,kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale)
 182           CALL block_3_6(mc_max,md_max,kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale)
 183           CALL block_3_6(mc_max,md_max,kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale)
 184           CALL block_3_6(mc_max,md_max,kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale)
 185           CALL block_3_6(mc_max,md_max,kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale)
 186         END SELECT
 187         CALL block_3_9(mc_max,md_max,kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale)
 188       END SELECT
 189       SELECT CASE(mb_max)
 190       CASE(1)
 191         SELECT CASE(mc_max)
 192         CASE(1)
 193           SELECT CASE(md_max)
 194           CASE(1)
 195             CALL block_4_1_1_2(kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale)
 196             CALL block_4_1_1_3(kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale)
 197             CALL block_4_1_1_4(kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale)
 198             CALL block_4_1_1(md_max,kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale)
 199             CALL block_4_1_4(md_max,kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale)
 200             CALL block_4_1_4(md_max,kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale)
 201             CALL block_4_1_4(md_max,kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale)
 202             CALL block_4_1_4(md_max,kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale)
 203             CALL block_4_1_4(md_max,kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale)
 204             CALL block_4_1_4(md_max,kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale)
 205             CALL block_4_1_4(md_max,kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale)
 206           END SELECT
 207         END SELECT
 208         SELECT CASE(mc_max)
 209         CASE(1)
 210           SELECT CASE(md_max)
 211           CASE(1)
 212             CALL block_4_2_1_2(kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale)
 213             CALL block_4_2_2(md_max,kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale)
 214             CALL block_4_2_2(md_max,kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale)
 215             CALL block_4_2_2(md_max,kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale)
 216             CALL block_4_2_2(md_max,kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale)
 217             CALL block_4_2_2(md_max,kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale)
 218             CALL block_4_2_2(md_max,kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale)
 219             CALL block_4_2_2(md_max,kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale)
 220             CALL block_4_2_2(md_max,kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale)
 221             CALL block_4_2_2(md_max,kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale)
 222             CALL block_4_2_2(md_max,kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale)
 223           END SELECT
 224           SELECT CASE(md_max)
 225           CASE(1)
 226             CALL block_4_3_1_1(kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale)
 227           END SELECT
 228           CALL block_4_3(mc_max,md_max,kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale)
 229           CALL block_4_3(mc_max,md_max,kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale)
 230           CALL block_4_3(mc_max,md_max,kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale)
 231           CALL block_4_3(mc_max,md_max,kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale)
 232           CALL block_4_3(mc_max,md_max,kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale)
 233           CALL block_4_3(mc_max,md_max,kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale)
 234           CALL block_4_3(mc_max,md_max,kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale)
 235           CALL block_4_3(mc_max,md_max,kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale)
 236           CALL block_4_3(mc_max,md_max,kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale)
 237           CALL block_4_3(mc_max,md_max,kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale)
 238           SELECT CASE(md_max)
 239           CASE(1)
 240             CALL block_4_4_1_1(kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale)
 241           END SELECT
 242         END SELECT
 243         SELECT CASE(mc_max)
 244         CASE(1)
 245           SELECT CASE(md_max)
 246           END SELECT
 247         END SELECT
 248       END SELECT
 249       SELECT CASE(mb_max)
 250       CASE(1)
 251         CALL block_15_15(mc_max,md_max,kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale)
 252       END SELECT
 253     END SELECT
 254   END SUBROUTINE contract_block
 255   SUBROUTINE block_1_1_1_1(kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale)
 256     REAL(KIND=dp) :: kbd(1*1), kbc(1*1), kad(1*1), kac(1*1), pbd(1*1), &
 257       pbc(1*1), pad(1*1), pac(1*1), prim(1*1*1*1), scale
 258       DO md = 1,1
 259         DO mc = 1,1
 260           DO mb = 1,1
 261             DO ma = 1,1
 262               kad((md-1)*1+ma) =  kad((md-1)*1+ma)-tmp*p_bc
 263             END DO
 264           END DO
 265         END DO
 266       END DO
 267   END SUBROUTINE block_1_1_1_1
 268   SUBROUTINE block_1_1_1_2(kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale)
 269     REAL(KIND=dp) :: kbd(1*2), kbc(1*1), kad(1*2), kac(1*1), pbd(1*2), &
 270       pbc(1*1), pad(1*2), pac(1*1), prim(1*1*1*2), scale
 271       DO md = 1,2
 272         DO mc = 1,1
 273           DO mb = 1,1
 274             DO ma = 1,1
 275               kac((mc-1)*1+ma) = kac((mc-1)*1+ma)-tmp*p_bd
 276             END DO
 277           END DO
 278         END DO
 279       END DO
 280   END SUBROUTINE block_1_1_1_2
 281   SUBROUTINE block_1_1_11(md_max,kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale)
 282     REAL(KIND=dp) :: kbd(1*md_max), kbc(1*11), kad(1*md_max), kac(1*11), &
 283       pbd(1*md_max), pbc(1*11), pad(1*md_max), pac(1*11), &
 284       prim(1*1*11*md_max), scale
 285       DO md = 1,md_max
 286         DO mc = 1,11
 287           DO mb = 1,1
 288             kbc((mc-1)*1+mb) = kbc((mc-1)*1+mb) - ks_bc
 289           END DO
 290         END DO
 291       END DO
 292   END SUBROUTINE block_1_1_11
 293   SUBROUTINE block_1_2_1_2(kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale)
 294     REAL(KIND=dp) :: kbd(2*2), kbc(2*1), kad(1*2), kac(1*1), pbd(2*2), &
 295       pbc(2*1), pad(1*2), pac(1*1), prim(1*2*1*2), scale
 296       DO md = 1,2
 297         DO mc = 1,1
 298           DO mb = 1,2
 299             kbc((mc-1)*2+mb) = kbc((mc-1)*2+mb) - ks_bc
 300           END DO
 301         END DO
 302       END DO
 303   END SUBROUTINE block_1_2_1_2
 304   SUBROUTINE block_1_2_1_3(kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale)
 305     REAL(KIND=dp) :: kbd(2*3), kbc(2*1), kad(1*3), kac(1*1), pbd(2*3), &
 306       pbc(2*1), pad(1*3), pac(1*1), prim(1*2*1*3), scale
 307       DO md = 1,3
 308         DO mc = 1,1
 309           DO mb = 1,2
 310             kbc((mc-1)*2+mb) = kbc((mc-1)*2+mb) - ks_bc
 311           END DO
 312         END DO
 313       END DO
 314   END SUBROUTINE block_1_2_1_3
 315   SUBROUTINE block_1_2_1_4(kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale)
 316     REAL(KIND=dp) :: kbd(2*4), kbc(2*1), kad(1*4), kac(1*1), pbd(2*4), &
 317       pbc(2*1), pad(1*4), pac(1*1), prim(1*2*1*4), scale
 318       DO md = 1,4
 319         DO mc = 1,1
 320           DO mb = 1,2
 321             kbc((mc-1)*2+mb) = kbc((mc-1)*2+mb) - ks_bc
 322           END DO
 323         END DO
 324       END DO
 325   END SUBROUTINE block_1_2_1_4
 326   SUBROUTINE block_1_2_1_5(kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale)
 327     REAL(KIND=dp) :: kbd(2*5), kbc(2*1), kad(1*5), kac(1*1), pbd(2*5), &
 328       pbc(2*1), pad(1*5), pac(1*1), prim(1*2*1*5), scale
 329       DO md = 1,5
 330         DO mc = 1,1
 331           DO mb = 1,2
 332             kbc((mc-1)*2+mb) = kbc((mc-1)*2+mb) - ks_bc
 333           END DO
 334         END DO
 335       END DO
 336   END SUBROUTINE block_1_2_1_5
 337   SUBROUTINE block_1_2_1_6(kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale)
 338     REAL(KIND=dp) :: kbd(2*6), kbc(2*1), kad(1*6), kac(1*1), pbd(2*6), &
 339       pbc(2*1), pad(1*6), pac(1*1), prim(1*2*1*6), scale
 340       DO md = 1,6
 341         DO mc = 1,1
 342           DO mb = 1,2
 343             DO ma = 1,1
 344               kac((mc-1)*1+ma) = kac((mc-1)*1+ma)-tmp*p_bd
 345             END DO
 346           END DO
 347         END DO
 348       END DO
 349   END SUBROUTINE block_1_2_1_6
 350   SUBROUTINE block_1_2_1_7(kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale)
 351     REAL(KIND=dp) :: kbd(2*7), kbc(2*1), kad(1*7), kac(1*1), pbd(2*7), &
 352       pbc(2*1), pad(1*7), pac(1*1), prim(1*2*1*7), scale
 353       DO md = 1,7
 354         DO mc = 1,1
 355           DO mb = 1,2
 356             DO ma = 1,1
 357               kad((md-1)*1+ma) =  kad((md-1)*1+ma)-tmp*p_bc
 358             END DO
 359           END DO
 360         END DO
 361       END DO
 362   END SUBROUTINE block_1_2_1_7
 363   SUBROUTINE block_1_2_2_2(kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale)
 364     REAL(KIND=dp) :: kbd(2*2), kbc(2*2), kad(1*2), kac(1*2), pbd(2*2), &
 365       pbc(2*2), pad(1*2), pac(1*2), prim(1*2*2*2), scale
 366       DO md = 1,2
 367         DO mc = 1,2
 368           DO mb = 1,2
 369             kbc((mc-1)*2+mb) = kbc((mc-1)*2+mb) - ks_bc
 370           END DO
 371         END DO
 372       END DO
 373   END SUBROUTINE block_1_2_2_2
 374   SUBROUTINE block_1_2_2_4(kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale)
 375     REAL(KIND=dp) :: kbd(2*4), kbc(2*2), kad(1*4), kac(1*2), pbd(2*4), &
 376       pbc(2*2), pad(1*4), pac(1*2), prim(1*2*2*4), scale
 377       DO md = 1,4
 378         DO mc = 1,2
 379           DO mb = 1,2
 380             kbd((md-1)*2+mb) = kbd((md-1)*2+mb) - ks_bd
 381           END DO
 382         END DO
 383       END DO
 384   END SUBROUTINE block_1_2_2_4
 385   SUBROUTINE block_1_2_4_1(kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale)
 386     REAL(KIND=dp) :: kbd(2*1), kbc(2*4), kad(1*1), kac(1*4), pbd(2*1), &
 387       pbc(2*4), pad(1*1), pac(1*4), prim(1*2*4*1), scale
 388       DO md = 1,1
 389         DO mc = 1,4
 390           DO mb = 1,2
 391             kbd((md-1)*2+mb) = kbd((md-1)*2+mb) - ks_bd
 392           END DO
 393         END DO
 394       END DO
 395   END SUBROUTINE block_1_2_4_1
 396   SUBROUTINE block_1_2_6_1(kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale)
 397     REAL(KIND=dp) :: kbd(2*1), kbc(2*6), kad(1*1), kac(1*6), pbd(2*1), &
 398       pbc(2*6), pad(1*1), pac(1*6), prim(1*2*6*1), scale
 399       DO md = 1,1
 400         DO mc = 1,6
 401           DO mb = 1,2
 402             DO ma = 1,1
 403               kad((md-1)*1+ma) =  kad((md-1)*1+ma)-tmp*p_bc
 404             END DO
 405           END DO
 406         END DO
 407       END DO
 408   END SUBROUTINE block_1_2_6_1
 409   SUBROUTINE block_1_2_7_1(kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale)
 410     REAL(KIND=dp) :: kbd(2*1), kbc(2*7), kad(1*1), kac(1*7), pbd(2*1), &
 411       pbc(2*7), pad(1*1), pac(1*7), prim(1*2*7*1), scale
 412       DO md = 1,1
 413         DO mc = 1,7
 414           DO mb = 1,2
 415             DO ma = 1,1
 416               kac((mc-1)*1+ma) = kac((mc-1)*1+ma)-tmp*p_bd
 417             END DO
 418           END DO
 419         END DO
 420       END DO
 421   END SUBROUTINE block_1_2_7_1
 422   SUBROUTINE block_1_3_1_1(kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale)
 423     REAL(KIND=dp) :: kbd(3*1), kbc(3*1), kad(1*1), kac(1*1), pbd(3*1), &
 424       pbc(3*1), pad(1*1), pac(1*1), prim(1*3*1*1), scale
 425       DO md = 1,1
 426         DO mc = 1,1
 427           DO mb = 1,3
 428             kbc((mc-1)*3+mb) = kbc((mc-1)*3+mb) - ks_bc
 429           END DO
 430         END DO
 431       END DO
 432   END SUBROUTINE block_1_3_1_1
 433   SUBROUTINE block_1_3_1_3(kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale)
 434     REAL(KIND=dp) :: kbd(3*3), kbc(3*1), kad(1*3), kac(1*1), pbd(3*3), &
 435       pbc(3*1), pad(1*3), pac(1*1), prim(1*3*1*3), scale
 436       DO md = 1,3
 437         DO mc = 1,1
 438           DO mb = 1,3
 439             DO ma = 1,1
 440               kac((mc-1)*1+ma) = kac((mc-1)*1+ma)-tmp*p_bd
 441             END DO
 442           END DO
 443         END DO
 444       END DO
 445   END SUBROUTINE block_1_3_1_3
 446   SUBROUTINE block_1_3_1_4(kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale)
 447     REAL(KIND=dp) :: kbd(3*4), kbc(3*1), kad(1*4), kac(1*1), pbd(3*4), &
 448       pbc(3*1), pad(1*4), pac(1*1), prim(1*3*1*4), scale
 449       DO md = 1,4
 450         DO mc = 1,1
 451           DO mb = 1,3
 452             kbc((mc-1)*3+mb) = kbc((mc-1)*3+mb) - ks_bc
 453           END DO
 454         END DO
 455       END DO
 456   END SUBROUTINE block_1_3_1_4
 457   SUBROUTINE block_1_3_1_5(kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale)
 458     REAL(KIND=dp) :: kbd(3*5), kbc(3*1), kad(1*5), kac(1*1), pbd(3*5), &
 459       pbc(3*1), pad(1*5), pac(1*1), prim(1*3*1*5), scale
 460       DO md = 1,5
 461         DO mc = 1,1
 462           DO mb = 1,3
 463             DO ma = 1,1
 464               kac((mc-1)*1+ma) = kac((mc-1)*1+ma)-tmp*p_bd
 465             END DO
 466           END DO
 467         END DO
 468       END DO
 469   END SUBROUTINE block_1_3_1_5
 470   SUBROUTINE block_1_3_1_6(kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale)
 471     REAL(KIND=dp) :: kbd(3*6), kbc(3*1), kad(1*6), kac(1*1), pbd(3*6), &
 472       pbc(3*1), pad(1*6), pac(1*1), prim(1*3*1*6), scale
 473       DO md = 1,6
 474         DO mc = 1,1
 475           DO mb = 1,3
 476             DO ma = 1,1
 477               kac((mc-1)*1+ma) = kac((mc-1)*1+ma)-tmp*p_bd
 478             END DO
 479           END DO
 480         END DO
 481       END DO
 482   END SUBROUTINE block_1_3_1_6
 483   SUBROUTINE block_1_3_1(md_max,kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale)
 484     REAL(KIND=dp) :: kbd(3*md_max), kbc(3*1), kad(1*md_max), kac(1*1), &
 485       pbd(3*md_max), pbc(3*1), pad(1*md_max), pac(1*1), prim(1*3*1*md_max), &
 486       scale
 487       DO md = 1,md_max
 488         DO mc = 1,1
 489           DO mb = 1,3
 490             DO ma = 1,1
 491               kad((md-1)*1+ma) =  kad((md-1)*1+ma)-tmp*p_bc
 492             END DO
 493           END DO
 494         END DO
 495       END DO
 496   END SUBROUTINE block_1_3_1
 497   SUBROUTINE block_1_3_2_1(kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale)
 498     REAL(KIND=dp) :: kbd(3*1), kbc(3*2), kad(1*1), kac(1*2), pbd(3*1), &
 499       pbc(3*2), pad(1*1), pac(1*2), prim(1*3*2*1), scale
 500       DO md = 1,1
 501         DO mc = 1,2
 502           DO mb = 1,3
 503             kbc((mc-1)*3+mb) = kbc((mc-1)*3+mb) - ks_bc
 504           END DO
 505         END DO
 506       END DO
 507   END SUBROUTINE block_1_3_2_1
 508   SUBROUTINE block_1_3_2_2(kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale)
 509     REAL(KIND=dp) :: kbd(3*2), kbc(3*2), kad(1*2), kac(1*2), pbd(3*2), &
 510       pbc(3*2), pad(1*2), pac(1*2), prim(1*3*2*2), scale
 511       DO md = 1,2
 512         DO mc = 1,2
 513           DO mb = 1,3
 514             DO ma = 1,1
 515               kad((md-1)*1+ma) =  kad((md-1)*1+ma)-tmp*p_bc
 516             END DO
 517           END DO
 518         END DO
 519       END DO
 520   END SUBROUTINE block_1_3_2_2
 521   SUBROUTINE block_1_3_2_3(kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale)
 522     REAL(KIND=dp) :: kbd(3*3), kbc(3*2), kad(1*3), kac(1*2), pbd(3*3), &
 523       pbc(3*2), pad(1*3), pac(1*2), prim(1*3*2*3), scale
 524       kbc(1:3*2) = 0.0_dp
 525       DO md = 1,3
 526         DO mc = 1,2
 527           DO mb = 1,3
 528             kbc((mc-1)*3+mb) = kbc((mc-1)*3+mb) - ks_bc
 529           END DO
 530         END DO
 531       END DO
 532   END SUBROUTINE block_1_3_2_3
 533   SUBROUTINE block_1_3_3_1(kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale)
 534     REAL(KIND=dp) :: kbd(3*1), kbc(3*3), kad(1*1), kac(1*3), pbd(3*1), &
 535       pbc(3*3), pad(1*1), pac(1*3), prim(1*3*3*1), scale
 536       DO md = 1,1
 537         DO mc = 1,3
 538           DO mb = 1,3
 539             kbd((md-1)*3+mb) = kbd((md-1)*3+mb) - ks_bd
 540           END DO
 541         END DO
 542       END DO
 543   END SUBROUTINE block_1_3_3_1
 544   SUBROUTINE block_1_3_3_2(kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale)
 545     REAL(KIND=dp) :: kbd(3*2), kbc(3*3), kad(1*2), kac(1*3), pbd(3*2), &
 546       pbc(3*3), pad(1*2), pac(1*3), prim(1*3*3*2), scale
 547       DO md = 1,2
 548         DO mc = 1,3
 549           DO mb = 1,3
 550             kbc((mc-1)*3+mb) = kbc((mc-1)*3+mb) - ks_bc
 551           END DO
 552         END DO
 553       END DO
 554   END SUBROUTINE block_1_3_3_2
 555   SUBROUTINE block_1_3_5(md_max,kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale)
 556     REAL(KIND=dp) :: kbd(3*md_max), kbc(3*5), kad(1*md_max), kac(1*5), &
 557       pbd(3*md_max), pbc(3*5), pad(1*md_max), pac(1*5), prim(1*3*5*md_max), &
 558       scale
 559       kbd(1:3*md_max) = 0.0_dp
 560       DO md = 1,md_max
 561       END DO
 562   END SUBROUTINE block_1_3_5
 563   SUBROUTINE block_1_3_6(md_max,kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale)
 564       DO md = 1,md_max
 565       END DO
 566   END SUBROUTINE block_1_3_6
 567   SUBROUTINE block_1_4_1_1(kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale)
 568     REAL(KIND=dp) :: kbd(4*1), kbc(4*1), kad(1*1), kac(1*1), pbd(4*1), &
 569       pbc(4*1), pad(1*1), pac(1*1), prim(1*4*1*1), scale
 570       DO md = 1,1
 571         DO mc = 1,1
 572           DO mb = 1,4
 573             DO ma = 1,1
 574               kac((mc-1)*1+ma) = kac((mc-1)*1+ma)-tmp*p_bd
 575             END DO
 576           END DO
 577         END DO
 578       END DO
 579   END SUBROUTINE block_1_4_1_1
 580   SUBROUTINE block_1_4_1_2(kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale)
 581     REAL(KIND=dp) :: kbd(4*2), kbc(4*1), kad(1*2), kac(1*1), pbd(4*2), &
 582       pbc(4*1), pad(1*2), pac(1*1), prim(1*4*1*2), scale
 583       DO md = 1,2
 584         DO mc = 1,1
 585           DO mb = 1,4
 586             kbc((mc-1)*4+mb) = kbc((mc-1)*4+mb) - ks_bc
 587           END DO
 588         END DO
 589       END DO
 590   END SUBROUTINE block_1_4_1_2
 591   SUBROUTINE block_1_4_1_3(kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale)
 592     REAL(KIND=dp) :: kbd(4*3), kbc(4*1), kad(1*3), kac(1*1), pbd(4*3), &
 593       pbc(4*1), pad(1*3), pac(1*1), prim(1*4*1*3), scale
 594       DO md = 1,3
 595         DO mc = 1,1
 596           DO mb = 1,4
 597             kbc((mc-1)*4+mb) = kbc((mc-1)*4+mb) - ks_bc
 598           END DO
 599         END DO
 600       END DO
 601   END SUBROUTINE block_1_4_1_3
 602   SUBROUTINE block_1_4_2_1(kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale)
 603     REAL(KIND=dp) :: kbd(4*1), kbc(4*2), kad(1*1), kac(1*2), pbd(4*1), &
 604       pbc(4*2), pad(1*1), pac(1*2), prim(1*4*2*1), scale
 605       DO md = 1,1
 606         DO mc = 1,2
 607           DO mb = 1,4
 608             kbc((mc-1)*4+mb) = kbc((mc-1)*4+mb) - ks_bc
 609           END DO
 610         END DO
 611       END DO
 612   END SUBROUTINE block_1_4_2_1
 613   SUBROUTINE block_1_4_2_2(kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale)
 614     REAL(KIND=dp) :: kbd(4*2), kbc(4*2), kad(1*2), kac(1*2), pbd(4*2), &
 615       pbc(4*2), pad(1*2), pac(1*2), prim(1*4*2*2), scale
 616       DO md = 1,2
 617         DO mc = 1,2
 618           DO mb = 1,4
 619             DO ma = 1,1
 620               kad((md-1)*1+ma) =  kad((md-1)*1+ma)-tmp*p_bc
 621             END DO
 622           END DO
 623         END DO
 624       END DO
 625   END SUBROUTINE block_1_4_2_2
 626   SUBROUTINE block_1_4_3_1(kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale)
 627     REAL(KIND=dp) :: kbd(4*1), kbc(4*3), kad(1*1), kac(1*3), pbd(4*1), &
 628       pbc(4*3), pad(1*1), pac(1*3), prim(1*4*3*1), scale
 629       DO md = 1,1
 630         DO mc = 1,3
 631           DO mb = 1,4
 632             kbc((mc-1)*4+mb) = kbc((mc-1)*4+mb) - ks_bc
 633           END DO
 634         END DO
 635       END DO
 636   END SUBROUTINE block_1_4_3_1
 637   SUBROUTINE block_1_4_3(md_max,kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale)
 638     REAL(KIND=dp) :: kbd(4*md_max), kbc(4*3), kad(1*md_max), kac(1*3), &
 639       pbd(4*md_max), pbc(4*3), pad(1*md_max), pac(1*3), prim(1*4*3*md_max), &
 640       scale
 641       DO md = 1,md_max
 642         DO mc = 1,3
 643           DO mb = 1,4
 644             kbc((mc-1)*4+mb) = kbc((mc-1)*4+mb) - ks_bc
 645           END DO
 646         END DO
 647       END DO
 648   END SUBROUTINE block_1_4_3
 649   SUBROUTINE block_1_4_4_1(kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale)
 650     REAL(KIND=dp) :: kbd(4*1), kbc(4*4), kad(1*1), kac(1*4), pbd(4*1), &
 651       pbc(4*4), pad(1*1), pac(1*4), prim(1*4*4*1), scale
 652       DO md = 1,1
 653         DO mc = 1,4
 654           DO mb = 1,4
 655             kbc((mc-1)*4+mb) = kbc((mc-1)*4+mb) - ks_bc
 656           END DO
 657         END DO
 658       END DO
 659   END SUBROUTINE block_1_4_4_1
 660   SUBROUTINE block_1_4_4(md_max,kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale)
 661     REAL(KIND=dp) :: kbd(4*md_max), kbc(4*4), kad(1*md_max), kac(1*4), &
 662       pbd(4*md_max), pbc(4*4), pad(1*md_max), pac(1*4), prim(1*4*4*md_max), &
 663       scale
 664       DO md = 1,md_max
 665         DO mc = 1,4
 666           DO mb = 1,4
 667             DO ma = 1,1
 668               kac((mc-1)*1+ma) = kac((mc-1)*1+ma)-tmp*p_bd
 669             END DO
 670           END DO
 671         END DO
 672       END DO
 673   END SUBROUTINE block_1_4_4
 674   SUBROUTINE block_1_5_1_3(kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale)
 675     REAL(KIND=dp) :: kbd(5*3), kbc(5*1), kad(1*3), kac(1*1), pbd(5*3), &
 676       pbc(5*1), pad(1*3), pac(1*1), prim(1*5*1*3), scale
 677       DO md = 1,3
 678         DO mc = 1,1
 679           DO mb = 1,5
 680             DO ma = 1,1
 681               kac((mc-1)*1+ma) = kac((mc-1)*1+ma)-tmp*p_bd
 682             END DO
 683           END DO
 684         END DO
 685       END DO
 686   END SUBROUTINE block_1_5_1_3
 687   SUBROUTINE block_1_5_1(md_max,kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale)
 688     REAL(KIND=dp) :: kbd(5*md_max), kbc(5*1), kad(1*md_max), kac(1*1), &
 689       pbd(5*md_max), pbc(5*1), pad(1*md_max), pac(1*1), prim(1*5*1*md_max), &
 690       scale
 691       DO md = 1,md_max
 692         DO mc = 1,1
 693           DO mb = 1,5
 694             kbc((mc-1)*5+mb) = kbc((mc-1)*5+mb) - ks_bc
 695           END DO
 696         END DO
 697       END DO
 698   END SUBROUTINE block_1_5_1
 699   SUBROUTINE block_1_6_1_1(kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale)
 700     REAL(KIND=dp) :: kbd(6*1), kbc(6*1), kad(1*1), kac(1*1), pbd(6*1), &
 701       pbc(6*1), pad(1*1), pac(1*1), prim(1*6*1*1), scale
 702       DO md = 1,1
 703         DO mc = 1,1
 704           DO mb = 1,6
 705             DO ma = 1,1
 706               kac((mc-1)*1+ma) = kac((mc-1)*1+ma)-tmp*p_bd
 707             END DO
 708           END DO
 709         END DO
 710       END DO
 711   END SUBROUTINE block_1_6_1_1
 712   SUBROUTINE block_1_6_1_2(kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale)
 713     REAL(KIND=dp) :: kbd(6*2), kbc(6*1), kad(1*2), kac(1*1), pbd(6*2), &
 714       pbc(6*1), pad(1*2), pac(1*1), prim(1*6*1*2), scale
 715       DO md = 1,2
 716         DO mc = 1,1
 717           DO mb = 1,6
 718             DO ma = 1,1
 719               kad((md-1)*1+ma) =  kad((md-1)*1+ma)-tmp*p_bc
 720             END DO
 721           END DO
 722         END DO
 723       END DO
 724   END SUBROUTINE block_1_6_1_2
 725   SUBROUTINE block_1_6_1_3(kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale)
 726     REAL(KIND=dp) :: kbd(6*3), kbc(6*1), kad(1*3), kac(1*1), pbd(6*3), &
 727       pbc(6*1), pad(1*3), pac(1*1), prim(1*6*1*3), scale
 728       DO md = 1,3
 729         DO mc = 1,1
 730           DO mb = 1,6
 731             kbc((mc-1)*6+mb) = kbc((mc-1)*6+mb) - ks_bc
 732           END DO
 733         END DO
 734       END DO
 735   END SUBROUTINE block_1_6_1_3
 736   SUBROUTINE block_1_6_2_1(kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale)
 737     REAL(KIND=dp) :: kbd(6*1), kbc(6*2), kad(1*1), kac(1*2), pbd(6*1), &
 738       pbc(6*2), pad(1*1), pac(1*2), prim(1*6*2*1), scale
 739       DO md = 1,1
 740         DO mc = 1,2
 741           DO mb = 1,6
 742             kbc((mc-1)*6+mb) = kbc((mc-1)*6+mb) - ks_bc
 743           END DO
 744         END DO
 745       END DO
 746   END SUBROUTINE block_1_6_2_1
 747   SUBROUTINE block_2_1_1_3(kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale)
 748     REAL(KIND=dp) :: kbd(1*3), kbc(1*1), kad(2*3), kac(2*1), pbd(1*3), &
 749       pbc(1*1), pad(2*3), pac(2*1), prim(2*1*1*3), scale
 750       DO md = 1,3
 751         DO mc = 1,1
 752           DO mb = 1,1
 753             DO ma = 1,2
 754               kac((mc-1)*2+ma) = kac((mc-1)*2+ma)-tmp*p_bd
 755             END DO
 756           END DO
 757         END DO
 758       END DO
 759   END SUBROUTINE block_2_1_1_3
 760   SUBROUTINE block_2_1_1_4(kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale)
 761     REAL(KIND=dp) :: kbd(1*4), kbc(1*1), kad(2*4), kac(2*1), pbd(1*4), &
 762       pbc(1*1), pad(2*4), pac(2*1), prim(2*1*1*4), scale
 763       DO md = 1,4
 764         DO mc = 1,1
 765           DO mb = 1,1
 766             kbc((mc-1)*1+mb) = kbc((mc-1)*1+mb) - ks_bc
 767           END DO
 768         END DO
 769       END DO
 770   END SUBROUTINE block_2_1_1_4
 771   SUBROUTINE block_2_1_1_5(kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale)
 772     REAL(KIND=dp) :: kbd(1*5), kbc(1*1), kad(2*5), kac(2*1), pbd(1*5), &
 773       pbc(1*1), pad(2*5), pac(2*1), prim(2*1*1*5), scale
 774       DO md = 1,5
 775         DO mc = 1,1
 776           DO mb = 1,1
 777             kbc((mc-1)*1+mb) = kbc((mc-1)*1+mb) - ks_bc
 778           END DO
 779         END DO
 780       END DO
 781   END SUBROUTINE block_2_1_1_5
 782   SUBROUTINE block_2_1_1_6(kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale)
 783     REAL(KIND=dp) :: kbd(1*6), kbc(1*1), kad(2*6), kac(2*1), pbd(1*6), &
 784       pbc(1*1), pad(2*6), pac(2*1), prim(2*1*1*6), scale
 785       DO md = 1,6
 786         DO mc = 1,1
 787           DO mb = 1,1
 788             DO ma = 1,2
 789               kad((md-1)*2+ma) =  kad((md-1)*2+ma)-tmp*p_bc
 790             END DO
 791           END DO
 792         END DO
 793       END DO
 794   END SUBROUTINE block_2_1_1_6
 795   SUBROUTINE block_2_1_2_1(kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale)
 796     REAL(KIND=dp) :: kbd(1*1), kbc(1*2), kad(2*1), kac(2*2), pbd(1*1), &
 797       pbc(1*2), pad(2*1), pac(2*2), prim(2*1*2*1), scale
 798       DO md = 1,1
 799         DO mc = 1,2
 800           DO mb = 1,1
 801             DO ma = 1,2
 802               kac((mc-1)*2+ma) = kac((mc-1)*2+ma)-tmp*p_bd
 803             END DO
 804           END DO
 805         END DO
 806       END DO
 807   END SUBROUTINE block_2_1_2_1
 808   SUBROUTINE block_2_1_2_2(kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale)
 809     REAL(KIND=dp) :: kbd(1*2), kbc(1*2), kad(2*2), kac(2*2), pbd(1*2), &
 810       pbc(1*2), pad(2*2), pac(2*2), prim(2*1*2*2), scale
 811       DO md = 1,2
 812         DO mc = 1,2
 813           DO mb = 1,1
 814             kbc((mc-1)*1+mb) = kbc((mc-1)*1+mb) - ks_bc
 815           END DO
 816         END DO
 817       END DO
 818   END SUBROUTINE block_2_1_2_2
 819   SUBROUTINE block_2_1_2_4(kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale)
 820     REAL(KIND=dp) :: kbd(1*4), kbc(1*2), kad(2*4), kac(2*2), pbd(1*4), &
 821       pbc(1*2), pad(2*4), pac(2*2), prim(2*1*2*4), scale
 822       DO md = 1,4
 823         DO mc = 1,2
 824           DO mb = 1,1
 825             kbc((mc-1)*1+mb) = kbc((mc-1)*1+mb) - ks_bc
 826           END DO
 827         END DO
 828       END DO
 829   END SUBROUTINE block_2_1_2_4
 830   SUBROUTINE block_2_2_1_1(kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale)
 831     REAL(KIND=dp) :: kbd(2*1), kbc(2*1), kad(2*1), kac(2*1), pbd(2*1), &
 832       pbc(2*1), pad(2*1), pac(2*1), prim(2*2*1*1), scale
 833       DO md = 1,1
 834         DO mc = 1,1
 835           DO mb = 1,2
 836             kbc((mc-1)*2+mb) = kbc((mc-1)*2+mb) - ks_bc
 837           END DO
 838         END DO
 839       END DO
 840   END SUBROUTINE block_2_2_1_1
 841   SUBROUTINE block_2_2_2_1(kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale)
 842     REAL(KIND=dp) :: kbd(2*1), kbc(2*2), kad(2*1), kac(2*2), pbd(2*1), &
 843       pbc(2*2), pad(2*1), pac(2*2), prim(2*2*2*1), scale
 844       DO md = 1,1
 845         DO mc = 1,2
 846           DO mb = 1,2
 847             kbd((md-1)*2+mb) = kbd((md-1)*2+mb) - ks_bd
 848           END DO
 849         END DO
 850       END DO
 851   END SUBROUTINE block_2_2_2_1
 852   SUBROUTINE block_2_2_3_1(kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale)
 853     REAL(KIND=dp) :: kbd(2*1), kbc(2*3), kad(2*1), kac(2*3), pbd(2*1), &
 854       pbc(2*3), pad(2*1), pac(2*3), prim(2*2*3*1), scale
 855       DO md = 1,1
 856         DO mc = 1,3
 857           DO mb = 1,2
 858             kbc((mc-1)*2+mb) = kbc((mc-1)*2+mb) - ks_bc
 859           END DO
 860         END DO
 861       END DO
 862   END SUBROUTINE block_2_2_3_1
 863   SUBROUTINE block_3_2_1(md_max,kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale)
 864     REAL(KIND=dp) :: kbd(2*md_max), kbc(2*1), kad(3*md_max), kac(3*1), &
 865       pbd(2*md_max), pbc(2*1), pad(3*md_max), pac(3*1), prim(3*2*1*md_max), &
 866       scale
 867       DO md = 1,md_max
 868         DO mc = 1,1
 869           DO mb = 1,2
 870             kbc((mc-1)*2+mb) = kbc((mc-1)*2+mb) - ks_bc
 871           END DO
 872         END DO
 873       END DO
 874   END SUBROUTINE block_3_2_1
 875   SUBROUTINE block_3_5_1_1(kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale)
 876     REAL(KIND=dp) :: kbd(5*1), kbc(5*1), kad(3*1), kac(3*1), pbd(5*1), &
 877       pbc(5*1), pad(3*1), pac(3*1), prim(3*5*1*1), scale
 878       DO md = 1,1
 879         DO mc = 1,1
 880           DO mb = 1,5
 881             DO ma = 1,3
 882               kad((md-1)*3+ma) =  kad((md-1)*3+ma)-tmp*p_bc
 883             END DO
 884           END DO
 885         END DO
 886       END DO
 887   END SUBROUTINE block_3_5_1_1
 888   SUBROUTINE block_3_5_1(md_max,kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale)
 889     REAL(KIND=dp) :: kbd(5*md_max), kbc(5*1), kad(3*md_max), kac(3*1), &
 890       pbd(5*md_max), pbc(5*1), pad(3*md_max), pac(3*1), prim(3*5*1*md_max), &
 891       scale
 892       DO md = 1,md_max
 893         DO mc = 1,1
 894           DO mb = 1,5
 895             kbc((mc-1)*5+mb) = kbc((mc-1)*5+mb) - ks_bc
 896           END DO
 897         END DO
 898       END DO
 899   END SUBROUTINE block_3_5_1
 900   SUBROUTINE block_3_6(mc_max,md_max,kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale)
 901     REAL(KIND=dp) :: kbd(6*md_max), kbc(6*mc_max), kad(3*md_max), &
 902       kac(3*mc_max), pbd(6*md_max), pbc(6*mc_max), pad(3*md_max), &
 903       pac(3*mc_max), prim(3*6*mc_max*md_max), scale
 904       kbd(1:6*md_max) = 0.0_dp
 905   END SUBROUTINE block_3_6
 906   SUBROUTINE block_3_9(mc_max,md_max,kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale)
 907     REAL(KIND=dp) :: kbd(9*md_max), kbc(9*mc_max), kad(3*md_max), &
 908       kac(3*mc_max), pbd(9*md_max), pbc(9*mc_max), pad(3*md_max), &
 909       pac(3*mc_max), prim(3*9*mc_max*md_max), scale
 910       DO md = 1,md_max
 911         DO mc = 1,mc_max
 912           DO mb = 1,9
 913             DO ma = 1,3
 914               kac((mc-1)*3+ma) = kac((mc-1)*3+ma)-tmp*p_bd
 915             END DO
 916           END DO
 917         END DO
 918       END DO
 919   END SUBROUTINE block_3_9
 920   SUBROUTINE block_4_1_1_2(kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale)
 921     REAL(KIND=dp) :: kbd(1*2), kbc(1*1), kad(4*2), kac(4*1), pbd(1*2), &
 922       pbc(1*1), pad(4*2), pac(4*1), prim(4*1*1*2), scale
 923       DO md = 1,2
 924         DO mc = 1,1
 925           DO mb = 1,1
 926             DO ma = 1,4
 927               kac((mc-1)*4+ma) = kac((mc-1)*4+ma)-tmp*p_bd
 928             END DO
 929           END DO
 930         END DO
 931       END DO
 932   END SUBROUTINE block_4_1_1_2
 933   SUBROUTINE block_4_1_1_3(kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale)
 934     REAL(KIND=dp) :: kbd(1*3), kbc(1*1), kad(4*3), kac(4*1), pbd(1*3), &
 935       pbc(1*1), pad(4*3), pac(4*1), prim(4*1*1*3), scale
 936       DO md = 1,3
 937         DO mc = 1,1
 938           DO mb = 1,1
 939             kbd((md-1)*1+mb) = kbd((md-1)*1+mb) - ks_bd
 940           END DO
 941         END DO
 942       END DO
 943   END SUBROUTINE block_4_1_1_3
 944   SUBROUTINE block_4_1_1_4(kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale)
 945     REAL(KIND=dp) :: kbd(1*4), kbc(1*1), kad(4*4), kac(4*1), pbd(1*4), &
 946       pbc(1*1), pad(4*4), pac(4*1), prim(4*1*1*4), scale
 947       DO md = 1,4
 948         DO mc = 1,1
 949           DO mb = 1,1
 950             kbc((mc-1)*1+mb) = kbc((mc-1)*1+mb) - ks_bc
 951           END DO
 952         END DO
 953       END DO
 954   END SUBROUTINE block_4_1_1_4
 955   SUBROUTINE block_4_1_1(md_max,kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale)
 956     REAL(KIND=dp) :: kbd(1*md_max), kbc(1*1), kad(4*md_max), kac(4*1), &
 957       pbd(1*md_max), pbc(1*1), pad(4*md_max), pac(4*1), prim(4*1*1*md_max), &
 958       scale
 959       DO md = 1,md_max
 960         DO mc = 1,1
 961           DO mb = 1,1
 962             kbc((mc-1)*1+mb) = kbc((mc-1)*1+mb) - ks_bc
 963           END DO
 964         END DO
 965       END DO
 966   END SUBROUTINE block_4_1_1
 967   SUBROUTINE block_4_1_4(md_max,kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale)
 968     REAL(KIND=dp) :: kbd(1*md_max), kbc(1*4), kad(4*md_max), kac(4*4), &
 969       pbd(1*md_max), pbc(1*4), pad(4*md_max), pac(4*4), prim(4*1*4*md_max), &
 970       scale
 971       kbd(1:1*md_max) = 0.0_dp
 972   END SUBROUTINE block_4_1_4
 973   SUBROUTINE block_4_2_1_2(kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale)
 974     REAL(KIND=dp) :: kbd(2*2), kbc(2*1), kad(4*2), kac(4*1), pbd(2*2), &
 975       pbc(2*1), pad(4*2), pac(4*1), prim(4*2*1*2), scale
 976       DO md = 1,2
 977         DO mc = 1,1
 978           DO mb = 1,2
 979             DO ma = 1,4
 980               kac((mc-1)*4+ma) = kac((mc-1)*4+ma)-tmp*p_bd
 981             END DO
 982           END DO
 983         END DO
 984       END DO
 985   END SUBROUTINE block_4_2_1_2
 986   SUBROUTINE block_4_2_2(md_max,kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale)
 987     REAL(KIND=dp) :: kbd(2*md_max), kbc(2*2), kad(4*md_max), kac(4*2), &
 988       pbd(2*md_max), pbc(2*2), pad(4*md_max), pac(4*2), prim(4*2*2*md_max), &
 989       scale
 990       DO md = 1,md_max
 991         DO mc = 1,2
 992           DO mb = 1,2
 993             kbc((mc-1)*2+mb) = kbc((mc-1)*2+mb) - ks_bc
 994           END DO
 995         END DO
 996       END DO
 997   END SUBROUTINE block_4_2_2
 998   SUBROUTINE block_4_3_1_1(kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale)
 999     REAL(KIND=dp) :: kbd(3*1), kbc(3*1), kad(4*1), kac(4*1), pbd(3*1), &
1000       pbc(3*1), pad(4*1), pac(4*1), prim(4*3*1*1), scale
1001       DO md = 1,1
1002         DO mc = 1,1
1003           DO mb = 1,3
1004             DO ma = 1,4
1005               kac((mc-1)*4+ma) = kac((mc-1)*4+ma)-tmp*p_bd
1006             END DO
1007           END DO
1008         END DO
1009       END DO
1010   END SUBROUTINE block_4_3_1_1
1011   SUBROUTINE block_4_3(mc_max,md_max,kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale)
1012     REAL(KIND=dp) :: kbd(3*md_max), kbc(3*mc_max), kad(4*md_max), &
1013       kac(4*mc_max), pbd(3*md_max), pbc(3*mc_max), pad(4*md_max), &
1014       pac(4*mc_max), prim(4*3*mc_max*md_max), scale
1015       DO md = 1,md_max
1016         DO mc = 1,mc_max
1017           DO mb = 1,3
1018             kbc((mc-1)*3+mb) = kbc((mc-1)*3+mb) - ks_bc
1019           END DO
1020         END DO
1021       END DO
1022   END SUBROUTINE block_4_3
1023   SUBROUTINE block_4_4_1_1(kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale)
1024     REAL(KIND=dp) :: kbd(4*1), kbc(4*1), kad(4*1), kac(4*1), pbd(4*1), &
1025       pbc(4*1), pad(4*1), pac(4*1), prim(4*4*1*1), scale
1026       DO md = 1,1
1027         DO mc = 1,1
1028           DO mb = 1,4
1029             DO ma = 1,4
1030               kad((md-1)*4+ma) =  kad((md-1)*4+ma)-tmp*p_bc
1031             END DO
1032           END DO
1033         END DO
1034       END DO
1035   END SUBROUTINE block_4_4_1_1
1036   SUBROUTINE block_15_15(mc_max,md_max,kbd,kbc,kad,kac,pbd,pbc,pad,pac,prim,scale)
1037     REAL(KIND=dp) :: kbd(15*md_max), kbc(15*mc_max), kad(15*md_max), &
1038       kac(15*mc_max), pbd(15*md_max), pbc(15*mc_max), pad(15*md_max), &
1039       pac(15*mc_max), prim(15*15*mc_max*md_max), scale
1040       DO md = 1,md_max
1041         DO mc = 1,mc_max
1042           DO mb = 1,15
1043             kbc((mc-1)*15+mb) = kbc((mc-1)*15+mb) - ks_bc
1044           END DO
1045         END DO
1046       END DO
1047   END SUBROUTINE block_15_15
1048 END MODULE hfx_contract_block