Skip to content

Commit

Permalink
interface program to original test suite
Browse files Browse the repository at this point in the history
  • Loading branch information
perazz committed Oct 22, 2022
1 parent 0f3e5b2 commit 91b014d
Show file tree
Hide file tree
Showing 3 changed files with 89 additions and 2 deletions.
6 changes: 6 additions & 0 deletions README.md
Original file line number Diff line number Diff line change
Expand Up @@ -13,6 +13,12 @@ An automated build is not available yet.
- `fitpack.f90` contains the object-oriented interface
- `fitpack_tests.f90` contains the original test programs, refactored as subroutines.

A simple command line build script is:

```
gfortran src/fitpack_core.f90 src/fitpack_tests.f90 src/fitpack.f90 test/test.f90 -o fitpack_test.exe
```


References
----------
Expand Down
42 changes: 40 additions & 2 deletions src/fitpack.f90
Original file line number Diff line number Diff line change
Expand Up @@ -131,7 +131,7 @@ subroutine new_points(this,x,y,w)
m = size(x)

! Ensure x are sorted
isort = argsort(x)
isort = RKIND_argsort(x)
allocate(this%x,source=x(isort))
allocate(this%y,source=y(isort))

Expand Down Expand Up @@ -268,7 +268,7 @@ pure function RKIND_argsort(list) result(ilist)
forall(i=1:size(list,kind=RSIZE)) ilist(i) = i

! Perform sort
call sort(copy,ilist)
call RKIND_quicksort_andlist(copy,ilist)

deallocate(copy)

Expand Down Expand Up @@ -354,4 +354,42 @@ end function toBeSwapped

end subroutine RKIND_quicksort_andlist

elemental subroutine swap_data(a,b)
real(RKIND), intent(inout) :: a, b
real(RKIND) :: tmp
tmp = a
a = b
b = tmp
return
end subroutine swap_data

elemental subroutine swap_size(a,b)
integer(RSIZE), intent(inout) :: a, b
integer(RSIZE) :: tmp
tmp = a
a = b
b = tmp
return
end subroutine swap_size

elemental logical function is_before(a,b)
real(RKIND), intent(in) :: a,b
is_before = a<b
end function is_before

elemental logical function is_after(a,b)
real(RKIND), intent(in) :: a,b
is_after = a>b
end function is_after

elemental logical function is_ge(a,b)
real(RKIND), intent(in) :: a,b
is_ge = a>=b
end function is_ge

elemental logical function is_le(a,b)
real(RKIND), intent(in) :: a,b
is_le = a<=b
end function is_le

end module fitpack
43 changes: 43 additions & 0 deletions test/test.f90
Original file line number Diff line number Diff line change
@@ -0,0 +1,43 @@
program test
use fitpack_tests

! Get test ID from the useri
write(*,'(A)',advance='no') 'Enter fitpack test ID [1:29] > '
read *, itest

select case (itest)
case (1); call mnbisp
case (2); call mncloc
case (3); call mncoco
case (4); call mnconc
case (5); call mncosp
case (6); call mncual
case (7); call mncurf
case (8); call mnfour
case (9); call mnist
case (10); call mnpade
case (11); call mnparc
case (12); call mnperc
case (13); call mnpogr
case (14); call mnpola
case (15); call mnprof
case (16); call mnregr
case (17); call mnspal
case (18); call mnspde
case (19); call mnspev
case (20); call mnsphe
case (21); call mnspin
case (22); call mnspro
case (23); call mnsuev
case (24); call mnsurf
case (25); call mncuev
case (26); call mndbin
case (27); call mnevpo
case (28); call mnpasu
case (29); call mnspgr
case default; stop 'invalid test ID'
end select



end program test

0 comments on commit 91b014d

Please sign in to comment.