utils.f90 3.82 KB
Newer Older
Luca's avatar
init  
Luca committed
1

2

Luca's avatar
init  
Luca committed
3
MODULE utils
4
  use globals
ulrich_y's avatar
ulrich_y committed
5
  use ieps
Luca's avatar
init  
Luca committed
6
  implicit none
Luca's avatar
Luca committed
7

8 9
  ! logical :: print_enabled = .true.
  ! logical :: warnings_enabled = .true.
10

Luca's avatar
init  
Luca committed
11
CONTAINS
Luca's avatar
Luca committed
12
  
13
  FUNCTION  get_condensed_m(z) result(m)
Luca's avatar
Luca committed
14
    ! returns condensed m where the ones not needed are filled with 0 (returns same size as z)
ulrich_y's avatar
ulrich_y committed
15
    type(inum), intent(in) :: z(:)
16
    integer :: m(size(z)), pos, i 
17
    m = 1
18
    pos = 1
19
    do i = 1,size(z)
20
      if(abs(z(i)) < zero) then
21 22 23 24 25 26 27 28 29 30 31 32
        if(i == size(z)) then
          pos = pos + 1
        else 
          m(pos) = m(pos) + 1
        end if
      else 
        pos = pos + 1
      end if
    end do
    m(pos:) = 0
  END FUNCTION get_condensed_m

33
  FUNCTION get_condensed_z(m, z_in) result(z_out)
34 35
    ! returns condensed z vector
    integer :: m(:), i, pos
ulrich_y's avatar
ulrich_y committed
36
    type(inum) :: z_in(:), z_out(size(m))
37 38 39 40 41
    pos = 0
    do i=1,size(m)
      pos = pos + m(i)
      z_out(i) = z_in(pos)
    end do
42
  END FUNCTION get_condensed_z
43 44 45 46

  FUNCTION  get_flattened_z(m,z_in) result(z_out)
    ! returns flattened version of z based on m and z
    integer :: m(:), i, pos
ulrich_y's avatar
ulrich_y committed
47 48
    type(inum) :: z_in(:), z_out(sum(m))
    z_out = izero
49 50 51 52 53 54 55
    pos = 0
    do i=1,size(m)
      pos = pos + m(i)
      z_out(pos) = z_in(i)
    end do
  END FUNCTION get_flattened_z

56
  FUNCTION find_amount_trailing_zeros(z) result(res)
ulrich_y's avatar
ulrich_y committed
57
    type(inum) :: z(:)
58 59 60
    integer :: res, i
    res = 0
    do i = size(z), 1, -1
61
      if( abs(z(i)) < zero ) then
62 63 64 65 66 67 68
        res = res + 1
      else
        exit
      end if
    end do
  END FUNCTION find_amount_trailing_zeros

ulrich_y's avatar
ulrich_y committed
69 70 71 72 73 74 75 76 77 78
  FUNCTION find_marker(v) result(res)
    type(inum) :: v(:)
    integer res
    do res=1,size(v)
      if(v(res)%i0 == marker%i0) then
        return
      endif
    enddo
  END FUNCTION find_marker

79 80 81 82 83 84 85 86 87 88 89 90
  FUNCTION find_first_zero(v) result(res)
    ! returns index of first zero, or -1 if there is no zero
    integer :: v(:), i, res
    res = -1
    do i = 1,size(v)
      if(v(i) == 0) then
        res = i
        return
      end if
    end do
  END FUNCTION find_first_zero

Luca's avatar
Luca committed
91 92 93 94 95
  FUNCTION min_index(v)
    ! returns the index of the smallest element in v
    real(kind=prec) :: v(:), minimum
    integer :: min_index, i
    min_index = 1
Luca's avatar
Luca committed
96
    minimum = 1e15
Luca's avatar
Luca committed
97
    do i = 1,size(v)
Luca's avatar
Luca committed
98
      if(v(i) < minimum .and. v(i) > zero) then
Luca's avatar
Luca committed
99 100 101 102 103 104
        minimum = v(i)
        min_index = i
      end if
    end do
  END FUNCTION min_index

Luca's avatar
Luca committed
105
  FUNCTION zeroes(n) result(res)
106
    integer :: n
ulrich_y's avatar
ulrich_y committed
107 108
    type(inum) :: res(n)
    res = izero
Luca's avatar
Luca committed
109
  END FUNCTION zeroes
Luca's avatar
minor  
Luca committed
110

Luca's avatar
Luca committed
111 112
  RECURSIVE FUNCTION factorial(n) result(res)
    integer, intent(in) :: n
ulrich_y's avatar
ulrich_y committed
113 114 115 116 117
    integer :: res, i
    res = 1
    do i=n,1,-1
      res = res*i
    enddo
Luca's avatar
Luca committed
118
  END FUNCTION factorial
119

120 121
  FUNCTION shuffle_with_zero(a) result(res)
    ! rows of result are shuffles of a with 0
ulrich_y's avatar
ulrich_y committed
122 123
    type(inum) :: a(:)
    type(inum) :: res(size(a)+1,size(a)+1)
124 125 126 127 128 129
    integer :: i,j, N
    N = size(a)+1
    do i = 1,N
      ! i is the index of the row
      ! j is the index of the zero
      j  = N+1-i
ulrich_y's avatar
ulrich_y committed
130
      res(i,j) = izero
131 132 133 134 135
      res(i,1:j-1) = a(1:j-1)
      res(i,j+1:N) = a(j:)
    end do
  END FUNCTION shuffle_with_zero

ulrich_y's avatar
ulrich_y committed
136
#ifdef DEBUG
Luca's avatar
Luca committed
137 138 139 140 141 142 143 144 145
  SUBROUTINE print_matrix(m) 
    complex(kind=prec) :: m(:,:)
    integer :: s(2), i
    s = shape(m)
    do i = 1,s(1)
      print*, abs(m(i,:))
    end do
  END SUBROUTINE print_matrix

146 147 148 149 150 151 152 153
  SUBROUTINE print_logical_matrix(m) 
    logical :: m(:,:)
    integer :: s(2), i
    s = shape(m)
    do i = 1,s(1)
      print*, m(i,:)
    end do
  END SUBROUTINE print_logical_matrix
ulrich_y's avatar
ulrich_y committed
154
#endif
155

156 157 158 159 160 161 162 163 164 165 166 167 168
  ! subroutine print(s1,s2,s3,s4,s5)
  !   character(len = *), intent(in), optional :: s1, s2, s3, s4, s5
  !   if(print_enabled) then
  !     print*, s1, s2, s3, s4, s5
  !   end if
  ! end subroutine print

  ! subroutine warn(s1,s2,s3,s4,s5)
  !   character(len = *), intent(in), optional :: s1, s2, s3, s4, s5
  !   if(warnings_enabled) then
  !     print*, 'Warning: ', s1, s2, s3, s4, s5
  !   end if
  ! end subroutine warn
Luca's avatar
init  
Luca committed
169 170

END MODULE utils