utils.f90 5.12 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

91 92 93 94 95 96 97 98 99 100 101 102
  FUNCTION find_first_true(v) result(res)
    ! returns index of first element in v that is true
    logical :: v(:)
    integer :: i, res
    do i = 1, size(v)
      if(v(i)) then
        res = i
        return
      end if
    end do
  END FUNCTION find_first_true

Luca's avatar
Luca committed
103 104 105 106 107
  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
108
    minimum = 1e15
Luca's avatar
Luca committed
109
    do i = 1,size(v)
Luca's avatar
Luca committed
110
      if(v(i) < minimum .and. v(i) > zero) then
Luca's avatar
Luca committed
111 112 113 114 115 116
        minimum = v(i)
        min_index = i
      end if
    end do
  END FUNCTION min_index

Luca's avatar
Luca committed
117
  FUNCTION zeroes(n) result(res)
118
    integer :: n
ulrich_y's avatar
ulrich_y committed
119 120
    type(inum) :: res(n)
    res = izero
Luca's avatar
Luca committed
121
  END FUNCTION zeroes
Luca's avatar
minor  
Luca committed
122

Luca's avatar
Luca committed
123 124 125 126 127
  RECURSIVE FUNCTION factorial(n) result(res)
    integer, intent(in) :: n
    integer :: res
    res = merge(1,n*factorial(n-1),n==0)
  END FUNCTION factorial
128

Luca's avatar
Luca committed
129 130 131 132 133 134 135 136 137 138 139 140
  FUNCTION add_ieps(x) result(res)
    ! adds small imaginary part to x
    complex(kind=prec) :: x, res
    res = x + (0.0,epsilon)
  END FUNCTION add_ieps

  FUNCTION sub_ieps(x) result(res)
    ! subtracts small imaginary part to x
    complex(kind=prec) :: x, res
    res = x - (0.0,epsilon)
  END FUNCTION sub_ieps

141 142
  FUNCTION shuffle_with_zero(a) result(res)
    ! rows of result are shuffles of a with 0
ulrich_y's avatar
ulrich_y committed
143 144
    type(inum) :: a(:)
    type(inum) :: res(size(a)+1,size(a)+1)
145 146 147 148 149 150
    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
151
      res(i,j) = izero
152 153 154 155 156
      res(i,1:j-1) = a(1:j-1)
      res(i,j+1:N) = a(j:)
    end do
  END FUNCTION shuffle_with_zero

Luca's avatar
Luca committed
157 158 159 160 161 162 163 164 165
  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

166 167 168 169 170 171 172 173 174
  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

175 176 177 178 179 180 181 182 183 184 185 186 187
  ! 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
188 189 190

END MODULE utils

191

192
! PROGRAM test
Luca's avatar
minor  
Luca committed
193
!   use globals
194 195
!   use  utils
!   implicit none
196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211
  
!   complex(kind=prec) :: z(4)
!   integer :: m_prime(4), condensed_size
!   z = cmplx((/0.0,1.7,0.0,0.0/))

!   ! transform to condensed notation
!   m_prime = get_condensed_m(z)
!   print*, abs(z)
!   m_prime = get_condensed_m(z)
!   print*, abs(z)
!   if(find_first_zero(m_prime) == -1) then
!     condensed_size = size(m_prime)
!   else
!     condensed_size = find_first_zero(m_prime)-1 
!   end if
!   print*, condensed_size
Luca's avatar
Luca committed
212 213


214
! END  PROGRAM test
Luca's avatar
Luca committed
215 216 217 218 219 220 221 222



! Contains some functions that might be useful later

! Write your own print function with ability to suppress print
! Muss immer alle prints und warnings ausschalten können
! Test Programm schreiben mit exit codes -> gfortran 'test.f90' und dann 'echo $?'