Assumed Shape arrays require explicit interface in Fortran [duplicate] - fortran

This question already has an answer here:
Procedure with assumed-shape dummy argument must have an explicit interface [duplicate]
(1 answer)
Closed 4 years ago.
Im trying to write the code for a simple program that first asks for a number n, then creates an nxn matrix with 3s on its main diagonal, 1s over it and 0s under it and a vector (n) with 3 in the uneven positions and 2 in the even positions. It must then include a subroutine that multiplies both of them not using matmul()
program P13
implicit none
integer(4) :: n, i, j
integer, dimension(:), allocatable:: v
integer, dimension(:,:), allocatable :: m
integer, dimension(:), allocatable :: r
write(*,*) "Insert n"
read(*,*) n
allocate (v(1:n))
allocate (m(1:n,1:n))
v(1:n:2) = 3
v(2:n:2) = 2
m = 0
DO i=1,n,1
m (i,i:n)=1
END DO
Do i=1,n,1
m (i,i)=3
End do
call matrmul(n, m, v)
end program
subroutine matrmul(n, b, o, t)
implicit none
integer(4), intent(in) :: n
integer(4) :: i, j
integer, dimension(:), intent(in) :: b
integer, dimension(:,:),intent(in) :: o
integer, dimension(:), intent(out) :: t
DO i=1,n,1
t(i) = sum(b*o(:,i))
END DO
write(*,'(I2)') t
end subroutine
I get the error message Explicit interface required for ‘matrmul’ at (1): assumed-shape argument
How do I fix this?? Thanks

There are plenty examples here at stack overflow that will show you how to create explicit interfaces. However, since you allocate memory for all your arrays in the main program and you pass the size into the subroutine, just declare all your arrays in the subroutine with n.
subroutine matrmul(n, b, o, t)
implicit none
integer(4), intent(in) :: n
integer(4) :: i, j
integer, dimension(n), intent(in) :: b
integer, dimension(n,n),intent(in) :: o
integer, dimension(n), intent(out) :: t

Related

Using Minpack to solve S-curve

I'd like to use Minpack (fortran) to estimate the D parameter in the following generalized form of the S-curve: y = (A - D) / (1 + (x**B/C)) + D
The idea is that in this application, the user provides A [which is always 0 to force passage through (0,0)], B, and C, and from there Minpack will find a value for D that forces passage through (1,y), where y is also supplied by the user but must be <= 1. I was able to accomplish this task with the code below, however, minpack is claiming it hasn't converged when in fact it appears that it has. For example, when running this code and entering the values 1 (at the first prompt) and 0 4 0.1 (at the second prompting), minpack returns info = 2, which according to the comments in lmdif means:
relative error between two consecutive iterates is at most xtol.
I'm tempted to comment out line 63, but am worried that's playing with fire...are there any seasoned minpack users out there who could comment on this? Line 63 is the one that reads:
if (info /= 1) stop "failed to converge"
Am I mis-using Minpack even though it appears to converge (based on my verifying the value in pars)?
module types
implicit none
private
public dp
integer, parameter :: dp=kind(0d0)
end module
module f_vals
DOUBLE PRECISION, SAVE, DIMENSION(:), POINTER:: fixed_vals
end module
module find_fit_module
! This module contains a general function find_fit() for a nonlinear least
! squares fitting. The function can fit any nonlinear expression to any data.
use minpack, only: lmdif1
use types, only: dp
implicit none
private
public find_fit
contains
subroutine find_fit(data_x, data_y, expr, pars)
! Fits the (data_x, data_y) arrays with the function expr(x, pars).
! The user can provide any nonlinear function 'expr' depending on any number of
! parameters 'pars' and it must return the evaluated expression on the
! array 'x'. The arrays 'data_x' and 'data_y' must have the same
! length.
real(dp), intent(in) :: data_x(:), data_y(:)
interface
function expr(x, pars) result(y)
use types, only: dp
implicit none
real(dp), intent(in) :: x(:), pars(:)
real(dp) :: y(size(x))
end function
end interface
real(dp), intent(inout) :: pars(:)
real(dp) :: tol, fvec(size(data_x))
integer :: iwa(size(pars)), info, m, n
real(dp), allocatable :: wa(:)
tol = sqrt(epsilon(1._dp))
!tol = 0.001
m = size(fvec)
n = size(pars)
allocate(wa(m*n + 5*n + m))
call lmdif1(fcn, m, n, pars, fvec, tol, info, iwa, wa, size(wa))
open(222, FILE='D_Value.txt')
write(222,4) pars(1)
4 format(E20.12)
close(222)
if (info /= 1) stop "failed to converge"
contains
subroutine fcn(m, n, x, fvec, iflag)
integer, intent(in) :: m, n, iflag
real(dp), intent(in) :: x(n)
real(dp), intent(out) :: fvec(m)
! Suppress compiler warning:
fvec(1) = iflag
fvec = data_y - expr(data_x, x)
end subroutine
end subroutine
end module
program snwdeplcrv
! Find a nonlinear fit of the form y = (A - D) / (1 + (x**B/C)) + D.
use find_fit_module, only: find_fit
use types, only: dp
use f_vals
implicit none
real(dp) :: pars(1), y_int_at_1
real(dp) :: y(1) = 1.0 ! Initialization of value to be reset by user (y: value of S-curve # x=1)
real(dp) :: A, B, C
integer :: i
allocate(fixed_vals(3)) ! A, B, C parameters
pars = [1._dp] ! D parameter in S-curve function
! Read PEST-specified parameters
write(*,*) ' Enter value that S-curve should equal when SWE=1 (must be <= 1)'
read(*,*) y_int_at_1
if(y_int_at_1 > 1.0) y_int_at_1 = 1
y = y_int_at_1
! Read PEST-specified parameters
write(*,*) ' Enter S-curve parameters: A, B, & C. D parameter to be estimated '
read(*,*) A, B, C
fixed_vals(1) = A
fixed_vals(2) = B
fixed_vals(3) = C
call find_fit([(real(i, dp), i=1,size(y))], y, expression, pars)
print *, pars
contains
function expression(x, pars) result(y)
use f_vals
real(dp), intent(in) :: x(:), pars(:)
real(dp) :: y(size(x))
real(dp) :: A, B, C, D
A = fixed_vals(1)
B = fixed_vals(2)
C = fixed_vals(3)
D = pars(1)
y = (A - D) / (1 + (x**B / C)) + D
end function
end program

Using MKL to solve a non-linear system of equations with an objective function stored in another module

I'm trying to use the MKL trust region algorithm to solve a nonlinear system of equations in a Fortran program. I started from the example provided online (ex_nlsqp_f90_x.f90 https://software.intel.com/en-us/node/501498) and everything works correctly. Now, because I have to use this in a much bigger program, I need the user defined objective function to be loaded from a separate module. Hence, I split the example into 2 separate files, but I'm not able to make it compile correctly.
So here is the code for module which contains user defined data structure and the objective function
module modFun
implicit none
private
public my_data, extended_powell
type :: my_data
integer a
integer sum
end type my_data
contains
subroutine extended_powell (m, n, x, f, user_data)
implicit none
integer, intent(in) :: m, n
real*8 , intent(in) :: x(n)
real*8, intent(out) :: f(m)
type(my_data) :: user_data
integer i
user_data%sum = user_data%sum + user_data%a
do i = 1, n/4
f(4*(i-1)+1) = x(4*(i-1)+1) + 10.0 * x(4*(i-1)+2)
f(4*(i-1)+2) = 2.2360679774998 * (x(4*(i-1)+3) - x(4*(i-1)+4))
f(4*(i-1)+3) = ( x(4*(i-1)+2) - 2.0 * x(4*(i-1)+3) )**2
f(4*(i-1)+4) = 3.1622776601684 * (x(4*(i-1)+1) - x(4*(i-1)+4))**2
end do
end subroutine extended_powell
end module modFun
and here the portion of the main program calling it
include 'mkl_rci.f90'
program EXAMPLE_EX_NLSQP_F90_X
use MKL_RCI
use MKL_RCI_type
use modFun
! user's objective function
! n - number of function variables
! m - dimension of function value
integer n, m
parameter (n = 4)
parameter (m = 4)
! precisions for stop-criteria (see manual for more details)
real*8 eps(6)
real*8 x(n)
real*8 fjac(m*n)
! number of iterations
integer fun
! Additional users data
type(my_data) :: m_data
m_data%a = 1
m_data%sum = 0
rs = 0.0
fun = djacobix(extended_powell,n,m,fjac,x,eps(1),%val(loc(m_data)))
end program EXAMPLE_EX_NLSQP_F90_X
Also djacobix code
INTERFACE
INTEGER FUNCTION DJACOBIX(fcn, n, m, fjac, x, eps, user_data)
USE, INTRINSIC :: ISO_C_BINDING
INTEGER, INTENT(IN) :: n
INTEGER, INTENT(IN) :: m
DOUBLE PRECISION, INTENT(IN) :: eps
DOUBLE PRECISION, INTENT(IN), DIMENSION(*) :: x
DOUBLE PRECISION, INTENT(OUT), DIMENSION(m, *) :: fjac
INTEGER(C_INTPTR_T) :: user_data
INTERFACE
SUBROUTINE fcn(m, n, x, f, user_data)
USE, INTRINSIC :: ISO_C_BINDING
INTEGER, INTENT(IN) :: n
INTEGER, INTENT(IN) :: m
DOUBLE PRECISION, INTENT(IN), DIMENSION(*) :: x
DOUBLE PRECISION, INTENT(OUT), DIMENSION(*) :: f
INTEGER(C_INTPTR_T), INTENT(IN) :: user_data
END SUBROUTINE
END INTERFACE
END FUNCTION
END INTERFACE
When i compile the following errors are generated:
mpiifort -g -t -mkl -I/apps/rhel6/intel/composer_xe_2015.3.187/mkl/include/intel64/lp64 -c modFun.f90
mpiifort -g -t -mkl -I/apps/rhel6/intel/composer_xe_2015.3.187/mkl/include/intel64/lp64 -c main.f90
main.f90(30): error #7065: The characteristics of dummy argument 5 of the associated actual procedure differ from the characteristics of dummy argument 5 of the dummy procedure. [EXTENDED_POWELL]
fun = djacobix(extended_powell,n,m,fjac,x,eps(1),%val(loc(m_data)))
-------------------^
I have the feeling I have to create an interface to override the check on the m_data, but I can't figure out where and how. Can anyone help me with this problem providing a working example?
I guess the reason is that the function djacobix passes the pointer instead of the true value of variable user_data.
You can check the manual at https://software.intel.com/content/www/us/en/develop/documentation/onemkl-developer-reference-c/top/nonlinear-optimization-problem-solvers/jacobian-matrix-calculation-routines/jacobix.html where a sentence shows that "You need to declare fcn as extern in the calling program."

Functions Passing Arrays In/Out Program Fortran 90

I'm working on trying to pass an array into a function to be able to calculate new values that will replace the original values in that array. However, I keep getting zeroes to be returned and I'm not sure why. My code is below:
program HW10
implicit none
integer :: i
integer, parameter :: &
p=38 !lines to read
real, parameter :: &
g=9.81 !Value of gravity acceleration
integer , dimension(p) :: direction, speed, rh, speedconv
real, dimension (p) :: pressure, height, temp, dewpt, mixr
real :: average, knots
open(1,file='HW10input.txt', status='old', action='read')
10 format (F6.1, T9, F6.1, T16, F5.1, T23, F5.1, T33, I2, T38, F4.2, T46, I3, T53, I3)
do i=1,p
read(1,10)pressure(i), height(i), temp(i), dewpt(i), rh(i), mixr(i), direction(i), speed(i)
end do
close (1)
open(2, file='outputfilehw10.txt', status='new', action='write')
do i=1,p
write (*, 20) pressure(i), height(i), temp(i), dewpt(i), rh(i), mixr(i), direction(i), speed(i)
20 format (F6.1, T9, F6.1, T16, F5.1, T23, F5.1, T33, I2, T38, F4.2, T46, I3, T53, I3)
end do
write (*,*) 'Average= ', average(temp, p)
do i=1,p
write (*,*) 'Wind Speeds: ', knots(speed, p)
end do
end program HW10
The issue comes when I get to the function "knots" at the bottom. This is what the function looks like:
real function knots (x, n)
integer, intent(in) :: n
real, dimension(n), intent(inout) :: x
integer :: i
do i = 1, n
x(i) = (x(i) * 0.514444 )
end do
return x
end function knots
The code will read in the data fine, as I have the code displaying it properly. However when I want to see the changed data within the wind speed array, all of the data points are zeroes. I'm new to Fortran so I'm not quite sure what to do. Thanks in advance!
If I try to compile the code given in the question (put all in the same file) with gfortran 4.8.3 I get the following two errors:
First error:
return x
1
Error: Alternate RETURN statement at (1) is only allowed within a SUBROUTINE
Second error:
write (*,*) 'Wind Speeds: ', knots(speed, p)
1
Warning: Type mismatch in argument 'x' at (1); passed INTEGER(4) to REAL(4)
Let's deal with the first of these - unlike many other programming languages it is not used to set the return value.
So, why did the compiler just complain that you've done this in a function rather than a subroutine instead of the compiler complaining that you've put a value here? There's a historic feature known as alternate return that is a bit like using a goto -- these are only allowed in subroutines.
So let's replace return x with just return -- this avoids the compiler error, but how does the code know what value to return? When defining functions in fortran you can explicitly specify a name for the result, but if you don't do this then it assumes your result is a variable with the same name as the function, so in your case knots. So in your code the variable to be returned is called knots but it never gets set to anything. By "coincidence" it looks like the bit of memory being used to store the result, which is never explicitly set to anything, is either being initialised to zero by the compiler or you're just accessing uninitialised memory that happens to be full of zeros.
So how do we fix this? Let's define the result explicitly
function knots (x, n) result(y)
implicit none
integer, intent(in) :: n
real, dimension(n), intent(inout) :: x
real, dimension(n) :: y
integer :: i
do i = 1, n
y(i) = (x(i) * 0.514444 )
end do
return
end function knots
If we try to compile we now get a new error!
write (*,*) 'Wind Speeds: ', knots(speed, p)
1
Error: The reference to function 'knots' at (1) either needs an explicit INTERFACE or the rank is incorrect
Functions/subroutines with arguments/return values typically need to have an interface defined . There are many ways to achieve this, I'm going to do it by putting the function in a module:
module myknots
implicit none
public :: knots
contains
function knots (x, n) result(y)
implicit none
integer, intent(in) :: n
real, dimension(n), intent(inout) :: x
real, dimension(n) :: y
integer :: i
do i = 1, n
y(i) = (x(i) * 0.514444 )
end do
return
end function knots
end module myknots
We then need to add use myknots, only: knots to the top of the main program. This now leaves us with just the second error.
What this is telling us is that you've passed an integer array to a function that expects a real value. This is because speed is declared as integer but x in knots is declared as real. To fix this let us create a new knots function in which x is declared as integer. I'll also use an explicit interface to allow us to refer to either version of knots using the name knots. Doing this the myknots module looks like
module myknots
implicit none
private
public :: knots
interface knots
module procedure knots_r
module procedure knots_i
end interface knots
contains
function knots_r (x, n) result(y)
implicit none
integer, intent(in) :: n
real, dimension(n), intent(inout) :: x
real, dimension(n) :: y
integer :: i
do i = 1, n
y(i) = (x(i) * 0.514444 )
end do
return
end function knots_r
function knots_i (x, n) result(y)
implicit none
integer, intent(in) :: n
integer, dimension(n), intent(inout) :: x
real, dimension(n) :: y
integer :: i
do i = 1, n
y(i) = (x(i) * 0.514444 )
end do
return
end function knots_i
end module myknots
The main program looks like
Program HW10
use myknots, only: knots
implicit none
integer :: i
integer, parameter :: &
p=38 !lines to read
real, parameter :: &
g=9.81 !Value of gravity acceleration
integer , dimension(p) :: direction, speed, rh, speedconv
real, dimension (p) :: pressure, height, temp, dewpt, mixr
real :: average
open(1,file='HW10input.txt', status='old', action='read')
10 format (F6.1, T9, F6.1, T16, F5.1, T23, F5.1, T33, I2, T38, F4.2, T46, I3, T53, I3)
do i=1,p
read(1,10)pressure(i), height(i), temp(i), dewpt(i), rh(i), mixr(i), direction(i), speed(i)
end do
close (1)
open(2, file='outputfilehw10.txt', status='new', action='write')
do i=1,p
write (*, 20) pressure(i), height(i), temp(i), dewpt(i), rh(i), mixr(i), direction(i), speed(i)
20 format (F6.1, T9, F6.1, T16, F5.1, T23, F5.1, T33, I2, T38, F4.2, T46, I3, T53, I3)
end do
write (*,*) 'Average= ', average(temp, p)
do i=1,p
write (*,*) 'Wind Speeds: ', knots(speed, p)
end do
end program HW10
This has fixed all the immediate issues, but you still won't be able to produce an executable as you haven't yet defined the average function. Hopefully the steps above should be enough to allow you to implement this yourself.
You have a function knots which has a real result. Look at the line
write (*,*) 'Wind Speeds: ', knots(speed, p)
The function reference knots(speed, p) is evaluated to return that real result, and that result is then printed.
There are two problems, based on the same misunderstanding: in the function knots the result of the function has the name knots. This isn't the same thing as the intent(inout) dummy argument x.
Problem 1: you don't defined the value of knots in the function.
Problem 2: the value of knots isn't the value you want. You want the value (on return) of speed.
You could either define the result knots to be the output array, or you can use a subroutine instead. I won't go into the details of those two approaches (as there are plenty of resources available there), but I will clearly note: if knots becomes a function with result array there will need to be an explicit interface available when it is referenced.

System of linear equations in fortran using DGESV [duplicate]

I'm struggling with LAPACK's dgetrf and dgetri routines. Below is a subroutine I've created (the variable fit_coeffs is defined externally and is allocatable, it's not the problem). When I run I get memory allocation errors, that appear when I assign fit_coeffs, due to the matmul(ATA,AT) line. I know this from inserting a bunch of print statements. Also, both error checking statements after calls to LAPACK subroutines are printed, suggesting an error.
Does anyone understand where this comes from? I'm compiling using the command:
gfortran -Wall -cpp -std=f2003 -ffree-form -L/home/binningtont/lapack-3.4.0/ read_grib.f -llapack -lrefblas.
Thanks in advance!
subroutine polynomial_fit(x_array, y_array, D)
integer, intent(in) :: D
real, intent(in), dimension(:) :: x_array, y_array
real, allocatable, dimension(:,:) :: A, AT, ATA
real, allocatable, dimension(:) :: work
integer, dimension(:), allocatable :: pivot
integer :: l, m, n, lda, lwork, ok
l = D + 1
lda = l
lwork = l
allocate(fit_coeffs(l))
allocate(pivot(l))
allocate(work(l))
allocate(A(size(x_array),l))
allocate(AT(l,size(x_array)))
allocate(ATA(l,l))
do m = 1,size(x_array),1
do n = 1,l,1
A(m,n) = x_array(m)**(n-1)
end do
end do
AT = transpose(A)
ATA = matmul(AT,A)
call dgetrf(l, l, ATA, lda, pivot, ok)
! ATA is now represented as PLU (permutation, lower, upper)
if (ok /= 0) then
write(6,*) "HERE"
end if
call dgetri(l, ATA, lda, pivot, work, lwork, ok)
! ATA now contains the inverse of the matrix ATA
if (ok /= 0) then
write(6,*) "HERE"
end if
fit_coeffs = matmul(matmul(ATA,AT),y_array)
deallocate(pivot)
deallocate(fit_coeffs)
deallocate(work)
deallocate(A)
deallocate(AT)
deallocate(ATA)
end subroutine polynomial_fit
1) Where is fit_coeffs declared? I can't see how the above can even compile
1b) Implicit None is your friend!
2) You do have an interface in scope at the calling point, don't you?
3) dgertf and dgetri want "double precision" while you have single. So you need sgetrf and sgetri
"Fixing" all these and completeing the program I get
Program testit
Implicit None
Real, Dimension( 1:100 ) :: x, y
Integer :: D
Interface
subroutine polynomial_fit(x_array, y_array, D)
Implicit None ! Always use this!!
integer, intent(in) :: D
real, intent(in), dimension(:) :: x_array, y_array
End subroutine polynomial_fit
End Interface
Call Random_number( x )
Call Random_number( y )
D = 6
Call polynomial_fit( x, y, D )
End Program testit
subroutine polynomial_fit(x_array, y_array, D)
Implicit None ! Always use this!!
integer, intent(in) :: D
real, intent(in), dimension(:) :: x_array, y_array
real, allocatable, dimension(:,:) :: A, AT, ATA
real, allocatable, dimension(:) :: work, fit_coeffs
integer, dimension(:), allocatable :: pivot
integer :: l, m, n, lda, lwork, ok
l = D + 1
lda = l
lwork = l
allocate(fit_coeffs(l))
allocate(pivot(l))
allocate(work(l))
allocate(A(size(x_array),l))
allocate(AT(l,size(x_array)))
allocate(ATA(l,l))
do m = 1,size(x_array),1
do n = 1,l,1
A(m,n) = x_array(m)**(n-1)
end do
end do
AT = transpose(A)
ATA = matmul(AT,A)
call sgetrf(l, l, ATA, lda, pivot, ok)
! ATA is now represented as PLU (permutation, lower, upper)
if (ok /= 0) then
write(6,*) "HERE"
end if
call sgetri(l, ATA, lda, pivot, work, lwork, ok)
! ATA now contains the inverse of the matrix ATA
if (ok /= 0) then
write(6,*) "HERE"
end if
fit_coeffs = matmul(matmul(ATA,AT),y_array)
deallocate(pivot)
deallocate(fit_coeffs)
deallocate(work)
deallocate(A)
deallocate(AT)
deallocate(ATA)
end subroutine polynomial_fit
This runs to completion. If I omit the interface I get "HERE" printed twice. If I use the d versions I get seg faults.
Does this answer your question?

Dynamic memory allocation error in Fortran2003 using LAPACK

I'm struggling with LAPACK's dgetrf and dgetri routines. Below is a subroutine I've created (the variable fit_coeffs is defined externally and is allocatable, it's not the problem). When I run I get memory allocation errors, that appear when I assign fit_coeffs, due to the matmul(ATA,AT) line. I know this from inserting a bunch of print statements. Also, both error checking statements after calls to LAPACK subroutines are printed, suggesting an error.
Does anyone understand where this comes from? I'm compiling using the command:
gfortran -Wall -cpp -std=f2003 -ffree-form -L/home/binningtont/lapack-3.4.0/ read_grib.f -llapack -lrefblas.
Thanks in advance!
subroutine polynomial_fit(x_array, y_array, D)
integer, intent(in) :: D
real, intent(in), dimension(:) :: x_array, y_array
real, allocatable, dimension(:,:) :: A, AT, ATA
real, allocatable, dimension(:) :: work
integer, dimension(:), allocatable :: pivot
integer :: l, m, n, lda, lwork, ok
l = D + 1
lda = l
lwork = l
allocate(fit_coeffs(l))
allocate(pivot(l))
allocate(work(l))
allocate(A(size(x_array),l))
allocate(AT(l,size(x_array)))
allocate(ATA(l,l))
do m = 1,size(x_array),1
do n = 1,l,1
A(m,n) = x_array(m)**(n-1)
end do
end do
AT = transpose(A)
ATA = matmul(AT,A)
call dgetrf(l, l, ATA, lda, pivot, ok)
! ATA is now represented as PLU (permutation, lower, upper)
if (ok /= 0) then
write(6,*) "HERE"
end if
call dgetri(l, ATA, lda, pivot, work, lwork, ok)
! ATA now contains the inverse of the matrix ATA
if (ok /= 0) then
write(6,*) "HERE"
end if
fit_coeffs = matmul(matmul(ATA,AT),y_array)
deallocate(pivot)
deallocate(fit_coeffs)
deallocate(work)
deallocate(A)
deallocate(AT)
deallocate(ATA)
end subroutine polynomial_fit
1) Where is fit_coeffs declared? I can't see how the above can even compile
1b) Implicit None is your friend!
2) You do have an interface in scope at the calling point, don't you?
3) dgertf and dgetri want "double precision" while you have single. So you need sgetrf and sgetri
"Fixing" all these and completeing the program I get
Program testit
Implicit None
Real, Dimension( 1:100 ) :: x, y
Integer :: D
Interface
subroutine polynomial_fit(x_array, y_array, D)
Implicit None ! Always use this!!
integer, intent(in) :: D
real, intent(in), dimension(:) :: x_array, y_array
End subroutine polynomial_fit
End Interface
Call Random_number( x )
Call Random_number( y )
D = 6
Call polynomial_fit( x, y, D )
End Program testit
subroutine polynomial_fit(x_array, y_array, D)
Implicit None ! Always use this!!
integer, intent(in) :: D
real, intent(in), dimension(:) :: x_array, y_array
real, allocatable, dimension(:,:) :: A, AT, ATA
real, allocatable, dimension(:) :: work, fit_coeffs
integer, dimension(:), allocatable :: pivot
integer :: l, m, n, lda, lwork, ok
l = D + 1
lda = l
lwork = l
allocate(fit_coeffs(l))
allocate(pivot(l))
allocate(work(l))
allocate(A(size(x_array),l))
allocate(AT(l,size(x_array)))
allocate(ATA(l,l))
do m = 1,size(x_array),1
do n = 1,l,1
A(m,n) = x_array(m)**(n-1)
end do
end do
AT = transpose(A)
ATA = matmul(AT,A)
call sgetrf(l, l, ATA, lda, pivot, ok)
! ATA is now represented as PLU (permutation, lower, upper)
if (ok /= 0) then
write(6,*) "HERE"
end if
call sgetri(l, ATA, lda, pivot, work, lwork, ok)
! ATA now contains the inverse of the matrix ATA
if (ok /= 0) then
write(6,*) "HERE"
end if
fit_coeffs = matmul(matmul(ATA,AT),y_array)
deallocate(pivot)
deallocate(fit_coeffs)
deallocate(work)
deallocate(A)
deallocate(AT)
deallocate(ATA)
end subroutine polynomial_fit
This runs to completion. If I omit the interface I get "HERE" printed twice. If I use the d versions I get seg faults.
Does this answer your question?