Added hi-weight test

checks/test.f90

@@ -30,6 +30,7 @@ PROGRAM TEST
   call do_ginac_tests
 #ifndef NOSPEED
   call do_timing_tests(5)
+  call do_high_weight_tests
 #endif
 #endif
 #endif
@@ -491,6 +492,99 @@ CONTAINS
     close(unit=9)
 
   end subroutine
+
+  subroutine fyshuffle(list, seed)
+    real(kind=prec) :: list(:), tmp
+    integer j,i, seed
+
+    do i=size(list),2,-1
+      j = int(ran2(seed) * i) + 1
+      tmp = list(j)
+      list(j) = list(i)
+      list(i) = tmp
+    enddo
+  end subroutine
+
+  function test_one_high_weight(length, fzero, funiq, alphabet, seed, what) result(res)
+    integer length,seed, i, what
+    integer nzero, nuniq, nsmall, c
+    real(kind=prec) :: fzero, funiq, fsmall
+    real(kind=prec) :: arguments(length), alphabet(10)
+    complex(kind=prec) :: Geval, res
+    nzero  = nint(fzero*length)
+    nuniq  = nint(       funiq*length)
+    nsmall = nint(fsmall*funiq*length)
+
+    if (nzero+nuniq > length) nuniq = length - nzero
+
+    !do i=1,nsmall
+    !  alphabet(i) = 0.8_prec * ran2(seed)
+    !enddo
+    !do i=nsmall+1,nuniq
+    !  alphabet(i) = 1.5_prec/(0.15_prec + ran2(seed))
+    !enddo
+
+    arguments(1:nzero) = 0._prec
+    do i=1,nuniq
+      arguments(nzero+i) = alphabet(i)
+    enddo
+    do i=nzero+nuniq,length
+      c = int(ran2(seed)*nuniq)+1
+      arguments(i) = alphabet(c)
+    enddo
+
+    call fyshuffle(arguments, seed)
+    do while(arguments(length)<zero)
+      call fyshuffle(arguments, seed)
+    enddo
+    write(9,*)"args",arguments
+    if (what.eq.1) then
+      res = G(arguments, 1._prec)
+    elseif (what.eq.2) then
+      res = Geval(cmplx([arguments, 1._prec],kind=prec),length+1)
+    endif
+  end function
+
+
+  subroutine do_high_weight_tests
+    integer, parameter :: ntests=10
+    real(kind=prec), parameter :: fzero = 0.28
+    real(kind=prec), parameter :: funiq = 0.63
+    real(kind=prec), parameter :: fsmal = 0.42
+    integer(kind=8) cstart, cend, count_rate
+    complex(kind=prec) :: res(ntests,2)
+    real(kind=prec) :: alphabet(10)
+
+    integer i,j
+    integer seed, seedold
+    seed = 123123
+
+    open(unit=9, file="stats-hi.txt")
+    alphabet = (/ 0.3, 0.6, 1.8, 5.3, 3.6, 8.3, 0.1, 0.4, 0.2, 10.2 /)
+    do i=2,7
+      seedold=seed
+      do j=1,ntests
+        call system_clock(cstart, count_rate=count_rate)
+        res(j,1) = test_one_high_weight(i, fzero, funiq, alphabet, seed,1)
+        call system_clock(cend, count_rate=count_rate)
+        write(9,*) "time",i,j,real(cend-cstart)/real(count_rate,kind=prec)!/ntests
+      enddo
+
+      seed=seedold
+      do j=1,ntests
+        call system_clock(cstart, count_rate=count_rate)
+        res(j,2) = test_one_high_weight(i, fzero, funiq, alphabet, seed,2)
+        call system_clock(cend, count_rate=count_rate)
+        write(9,*)"ginac",i,j,real(cend-cstart)/real(count_rate,kind=prec)!/ntests
+      enddo
+
+      write(9,*)"del",abs(res(:,1)-res(:,2)) / tol
+      write(9,*)
+      write(9,*)
+    enddo
+    close(unit=9)
+  end subroutine
+
 #endif
 
       FUNCTION RAN2(randy)