I want to compute the eigenvalues and eigenvectors of a matrix. I'm using sgeev of MKL lapack.
I have this very simple test code:
integer :: i,n, info
real, allocatable:: A(:,:), B(:,:), C(:,:)
real, allocatable:: wr(:), wi(:), vl(:, :), vr(:, :), work(:)
n=3
allocate(vr(n,n), vl(n,n), wr(n), wi(n), work(4*n))
allocate(A(n,n),B(n,n), C(n,n))
A(1,:)=(/-1.0,3.0,-1.0/)
A(2,:)=(/-3.0,5.0,-1.0/)
A(3,:)=(/-3.0,3.0,1.0/)
call sgeev('V','V',n,A,n,wr,wi,vl,n,vr,n,work,size(work,1),info)
print*,info
do i=1,n
print*,i,wr(i),wi(i)
enddo
print*,'vr'
do i=1, n
print*, vr(i,:)
enddo
print*,'vl'
do i=1, n
print*, vl(i,:)
enddo
It gives the right eigenvalues (2, 2, 1) but the wrong eigenvectors.
I have:
vr
-0.577350259 0.557844639 -0.539340019
-0.577350557 0.704232574 -0.273908198
-0.577349961 0.439164847 0.796295524
vl
-0.688247085 -0.617912114 -0.815013587
0.688247383 0.771166325 0.364909053
-0.229415640 -0.153254643 0.450104564
when vr should be
-1 1 1
0 1 1
3 0 1
What am I doing the wrong way?
Your matrix is degenerate (has two eigenvalues which are the same as one another), so the corresponding eigenvectors can be an arbitrary linear combination of the two degenerate eigenvectors.
Also, the output of sgeev normalises the eigenvectors, whereas the eigenvectors you have given are not normalised.
The first eigenvalue given is 1, and the corresponding eigenvector is the first column of vr, l1=(-0.57..., -0.57..., -0.57...). This is proportional to the third eigenvector you have given, (1, 1, 1).
The second and third eigenvalues are both 2. The corresponding eigenvectors are the second and third columns of vr, l2=(0.55..., 0.70..., 0.43...) and l3=(-0.53..., -0.27..., 0.79...). Taking 0.27...*l2+0.70...*l3 gives (-0.22..., 0, 0.66...), proportional to (-1, 0, 3), and taking 0.79...*l2-0.43...*l3 gives (0.66..., 0.66..., 0), proportional to (1, 1, 0).
Related
I want to diagonalize a matrix and then be able to do basis changes. The aim in the end is to do matrix exponentiation, with exp(A) = P.exp(D).P^{-1}.
I use sgeev to diagonalize A. If I am not mistaken (and I probably am since it's not working), sgeev gives me P in the vr matrix and P^{-1} is transpose(vl). The diagonal matrix can be reconstitute from the eigenvalues wr.
The problem is that when I try to verify the matrix transformation by computing P * D * P^{-1} it's not giving A back.
Here's my code:
integer :: i,n, info
real::norm
real, allocatable:: A(:,:), B(:,:), C(:,:),D(:,:)
real, allocatable:: wr(:), wi(:), vl(:, :), vr(:, :), work(:)
n=3
allocate(vr(n,n), vl(n,n), wr(n), wi(n), work(4*n))
allocate(A(n,n),B(n,n), C(n,n),D(n,n))
A(1,:)=(/1,0,1/)
A(2,:)=(/0,2,1/)
A(3,:)=(/0,3,1/)
call sgeev('V','V',n,A,n,wr,wi,vl,n,vr,n,work,size(work,1),info)
print*,'eigenvalues'
do i=1,n
print*,i,wr(i),wi(i)
enddo
D=0.0
D(1,1)=wr(1)
D(2,2)=wr(2)
D(3,3)=wr(3)
C = matmul(D,transpose(vl))
B = matmul(vr,C)
print*,'A'
do i=1, n
print*, B(i,:)
enddo
The printed result is:
eigenvalues
1 1.00000000 0.00000000
2 3.30277562 0.00000000
3 -0.302775621 0.00000000
A
0.688247263 0.160159975 0.764021933
0.00000000 1.66581571 0.817408621
0.00000000 2.45222616 0.848407149
A is not the original A, not even considering an eventual factor.
I guess I am somehow mistaken since I checked the eigenvectors by computing matmul(A,vr) = matmul(vr,D) and matmul(transpose(vl),A) = matmul(D, transpose(vl)), and it worked.
Where am I wrong?
The problem is that transpose(vl) is not the inverse of vr. The normalisation given by sgeev is that each eigenvector (each column of vl or vr) is individually normalised. This means that dot_product(vl(:,i), vr(:,j)) is zero if i/=j, but is in general <1 if i==j.
If you want to get P^{-1}, you need to scale each column of vl by a factor of 1/dot_product(vl(:,i),vr(:,i) before transposing it.
I have a 3D matrix (dimension nx,nz,ny) which corresponds to a physical domain. This matrix contains a continuous field from -1 (phase 1) to +1 (phase 2); the interface between the two phases is the level 0 of this field.
Now, I want to calculate efficiently the signed distance function from the interface for every point in the domain.
I tried two possibilities (sgn is the sign of my field, with values +1,0,-1, xyz contains the grid as triplets of x,y,z at each point and dist is the signed distance function I want to calculate).
double precision, dimension(nx,nz,ny) :: dist,sgn,eudist
integer :: i,j,k
double precision :: seed,posit,tmp(nx)
do j=1,ny
do k=1,nz
do i=1,nx
seed=sgn(i,k,j)
! look for interface
eudist=(xyz(:,:,:,1)-x(i))**2+(xyz(:,:,:,2)-z(k))**2+(xyz(:,:,:,3)-y(j))**2
! find min within mask
posit=minval(eudist,seed*sgn.le.0)
! tmp fits in cache, small speed-up
tmp(i)=-seed*dsqrt(posit)
enddo
dist(:,k,j)=tmp
enddo
enddo
I also tried a second version, which is quite similar to the above one but it calculates the Euclidean distance only in a subset of the whole matrix. With this second version there is some speed up, but it is still too slow. I would like to know whether there is a more efficient way to calculate the distance function.
Second version:
double precision, dimension(nx,nz,ny) :: dist,sgn
double precision, allocatable, dimension(:,:,:) :: eudist
integer :: i,j,k , ii,jj,kk
integer :: il,iu,jl,ju,kl,ku
double precision :: seed, deltax,deltay,deltaz,tmp(nx)
deltax=max(int(nx/4),1)
deltay=max(int(ny/4),1)
deltaz=max(int(nz/2),1)
allocate(eudist(2*deltax+1,2*deltaz+1,2*deltay+1))
do j=1,ny
do k=1,nz
do i=1,nx
! look for closest point in box 2*deltax+1,2*deltaz+1,2*deltay+1
il=max(1,i-deltax)
iu=min(nx,i+deltax)
jl=max(1,j-deltay)
ju=min(ny,j+deltay)
kl=max(1,k-deltaz)
ku=min(nz,k+deltaz)
eudist(:,1:ku-kl+1,:)=(xyz(il:iu,kl:ku,jl:ju,1)-x(i))**2 &
& +(xyz(il:iu,kl:ku,jl:ju,2)-z(k))**2 &
& +(xyz(il:iu,kl:ku,jl:ju,3)-y(j))**2
seed=sgn(i,k,j)
tmp(i)=minval(eudist(:,1:ku-kl+1,:),seed*sgn(il:iu,kl:ku,jl:ju).le.0)
tmp(i)=-seed*dsqrt(tmp(i))
enddo
dist(:,k,j)=tmp
enddo
enddo
eudist: Euclidean distance between the point i,k,j and any other point in a box 2*deltax+1,2*deltaz+1,2*deltay+1 centered in i,k,j. This reduces computational cost, as the distance is calculated only in a subset of the whole grid (here I am assuming that the subset is large enough to contain an interfacial point).
After Vladimir suggestion (x,y,z are the axes determining grid position, xyz(i,k,j)=(x(i),z(k),y(j)) ):
double precision, dimension(nx,nz,ny) :: dist,sgn
double precision :: x(nx), y(ny), z(nz)
double precision, allocatable, dimension(:,:,:) :: eudist
double precision, allocatable, dimension(:) :: xd,yd,zd
integer :: i,j,k , ii,jj,kk
integer :: il,iu,jl,ju,kl,ku
double precision :: seed, deltax,deltay,deltaz,tmp(nx)
deltax=max(int(nx/4),1)
deltay=max(int(ny/4),1)
deltaz=max(int(nz/2),1)
allocate(eudist(2*deltax+1,2*deltaz+1,2*deltay+1))
allocate(xd(2*deltax+1))
allocate(yd(2*deltay+1))
allocate(zd(2*deltaz+1))
do j=1,ny
do k=1,nz
do i=1,nx
! look for closest point in box 2*deltax+1,2*deltaz+1,2*deltay+1
il=max(1,i-deltax)
iu=min(nx,i+deltax)
jl=max(1,j-deltay)
ju=min(ny,j+deltay)
kl=max(1,k-deltaz)
ku=min(nz,k+deltaz)
do ii=1,iu-il+1
xd(ii)=(xyz(il+ii-1)-x(i))**2
end do
do jj=1,ju-jl+1
yd(jj)=(y(jj+jl-1)-y(j))**2
end do
do kk=1,ku-kl+1
zd(kk)=(z(kk+kl-1)-z(k))**2
end do
do jj=1,ju-jl+1
do kk=1,ku-kl+1
do ii=1,iu-il+1
eudist(ii,kk,jj)=xd(ii)+yd(jj)+zd(kk)
enddo
enddo
enddo
seed=sgn(i,k,j)
tmp(i)=minval(eudist(:,1:ku-kl+1,:),seed*sgn(il:iu,kl:ku,jl:ju).le.0)
tmp(i)=-seed*dsqrt(tmp(i))
enddo
dist(:,k,j)=tmp
enddo
enddo
EDIT: more information on the problem at hand.
The grid is an orthogonal grid mapped to a matrix. The number of points of this grid is of the order of 1000 in each direction (in total about 1 billion points).
My goal is switching from a sign function (+1,0,-1) to a signed distance function in the entire grid in an efficient way.
I would still do what I suggested, no matter if you do that on a subset or across the whole plane. Take advantage of the orthogonal grid, it is a great thing to have
do j=1,ny
do k=1,nz
do i=1,nx
! look for closest point in box 2*deltax+1,2*deltaz+1,2*deltay+1
il=max(1,i-deltax)
iu=min(nx,i+deltax)
jl=max(1,j-deltay)
ju=min(ny,j+deltay)
kl=max(1,k-deltaz)
ku=min(nz,k+deltaz)
do ii = il,iu
xd(i) = (xyz(ii,kl:ku,jl:ju,1)-x(i))**2
end do
do jj = jl,ju
yd(i) = (xyz(il:iu,kl:ku,jj,2)-y(j))**2
end do
do kk = kl,ku
zd(k) = (xyz(il:iu,kk,jl:ju,3)-z(k))**2
end do
do jj = jl,ju
do kk = kl,ku
do ii = il,iu
eudist(il:iu,kl:ku,jl:ju) = xd(ii) + yd(jj) + zd(kk)
end do
end do
end do
....
enddo
dist(:,k,j)=tmp
enddo
enddo
Consider separating the whole thing that is inside the outer triple loop into a subroutine or a function. It would not be faster, but it would be much more readable. Especially for us here, It would be enough for us here to only deal with that function, the outer loop is just a confusing extra layer.
I try to diagonalize a matrix using zgeev and it giving correct eigenvalues but the eigenvectors are not orthogonal.
program complex_diagonalization
implicit none
integer,parameter :: N=3
integer::i,j
integer,parameter :: LDA=N,LDVL=N,LDVR=N
real(kind=8),parameter::q=dsqrt(2.0d0),q1=1.0d0/q
integer,parameter :: LWMAX=1000
integer :: INFO,LWORK
real(kind=8) :: RWORK(2*N)
complex(kind=8) :: B(LDA,N),VL(LDVL,N),VR(LDVR,N),W(N),WORK(LWMAX)
external::zgeev
!matrix defining
B(1,1)=0.0d0;B(1,2)=-q1;B(1,3)=-q1
B(2,1)=-q1;B(2,2)=0.50d0;B(2,3)=-0.50d0
B(3,1)=-q1;B(3,2)=-0.5d0;B(3,3)=0.50d0
LWORK=-1
CALL ZGEEV('Vectors','Vectors',N,B,LDA,W,VL,LDVL,VR,LDVR,WORK,LWORK,RWORK,INFO)
LWORK=MIN(LWMAX,INT(WORK(1)))
CALL ZGEEV('Vectors','Vectors',N,B,LDA,W,VL,LDVL,VR,LDVR,WORK,LWORK,RWORK,INFO)
IF( INFO.GT.0 ) THEN
WRITE(*,*)'The algorithm failed to compute eigenvalues.'
STOP
END IF
!eigenvalues
do i=1,N
WRITE(*,*)W(i)
enddo
!eigenvectors
do i=1,N
WRITE(*,*)(VR(i,j),j=1,N)
ENDDO
end
and the result I am getting are this:
eigenvalues:
( 0.99999999999999978,0.0000000000000000)
(-0.99999999999999978,0.0000000000000000)
( 0.99999999999999978,0.0000000000000000)
eigenvectors
(0.70710678118654746,0.0000000000000000)
(-0.50000000000000000,0.0000000000000000)
(-0.50000000000000000,0.0000000000000000)
(0.70710678118654746,0.0000000000000000)
(0.50000000000000000,0.0000000000000000)
(0.50000000000000000,0.0000000000000000)
(-0.11982367636731203,0.0000000000000000)
( 0.78160853028734012,0.0000000000000000)
(-0.61215226207528295,0.0000000000000000)
you can see that the third eigenvector is not orthogonal with one of the two eigenvectors. What I am expecting is that in the third eigenvector first entry should be zero and second entry will be minus of third entry and because it's a unit vector it will be 0.707.
A real symmetric matrix has three orthogonal eigenvectors if the three eigenvalues are unique. Only the eigenvectors corresponding to distinct eigenvalues have tobe orthogonal. https://math.stackexchange.com/a/1368948/134138
The Hermitian specialized routine ZHEEV should guarantee orthogonality of the eigenvectors as suggested by Ian Bush. Or in your case you can also consider DSYEV (because your matrix is real).
The situation is well described in this post from LAPACK Forum http://icl.cs.utk.edu/lapack-forum/archives/lapack/msg01352.html
From the documentation:
DSYEV:
* On exit, if JOBZ = 'V', then if INFO = 0, A contains the
* orthonormal eigenvectors of the matrix A.
ZHEEV:
* On exit, if JOBZ = 'V', then if INFO = 0, A contains the
* orthonormal eigenvectors of the matrix A.
I'm doing a fortran homework and i have to program the LU method, i have wrote some lines but i'm stuck because it's not working fine.
My program is doing well the array 1 and 2 and for U, and the col 1 and 2 for L but the 3 and 4 are wrong(L and U).
can you help me please?
this is the program:
program lu
implicit none
real*8 A(4,4),L(4,4),U(4,4)
integer i,j,n,k
open(unit=21,file='mat2.dat')
open(unit=22,file='L.dat')
open(unit=23,file='U.dat')
A=0.0d0
L=0.0d0
U=0.0d0
do i=1,4
read(21,*) (A(i,j),j=1,4) !read A matrix
end do
do i=1,4
L(i,1)=A(i,1) !creating array L(i,1)
U(1,i)=A(1,i)/L(1,1) !creating row U(1,i)
end do
do i=2,4
do j=2,4
if(i.eq.j) then
U(i,j)=1 !creating U diagonal=1, since U(1,1) is already created it can start from 2
end if
do n=1,j-1
if (i>=j) then
L(i,j)=A(i,j)-L(i,n)*U(n,j) !creating the L missing part, i think here is an error, but i can't find it
end if
end do
do n=1,i-1
if (i<j) then
U(i,j)=A(i,j)*1/L(i,i)-L(i,n)*U(n,j)*1/L(i,i) !creating the U missing part
end if
end do
end do
end do
do i=1,4
write(22,*) (L(i,j),j=1,4) !write to check if it's working fine
write(23,*) (U(i,j),j=1,4)
end do
end program
and this is the A matrix
3 -1 4 -1
-1 -1 3 1
2 3 -1 -1
7 1 1 2
L and U should looks like this picture
http://i.cubeupload.com/J6u1VN.png
sorry for my bad english :(
Usually, one stores L and U within a unique matrix, and, usually again, one just modifies the initial matrix which is used as input and output.
The algorithm is rather simple; Here is a variant without pivot search :
SUBROUTINE matrix_lu(matrix)
! decomposing a matrix as a product of two triangular matrices (lower and upper)
! the diagonal belongs to the upper triangular matrix (the diagonal of the lower
! triangular matrix is assumed to be equal to the identity matrix)
! Take care : the diagonal of U is already inversed
DOUBLE PRECISION, INTENT(inout) :: matrix(:,:)
INTEGER :: n,i,k,l
n=SIZE(matrix,1)
DO k = 1, n
matrix(k, k) = 1.d0/matrix(k, k)
DO i = k+1, n
matrix(i, k) = matrix(i, k)*matrix(k, k)
ENDDO
DO l = k+1, n
DO i = k+1, n
matrix(i, l) = matrix(i, l)-matrix(i, k)*matrix(k, l)
END DO
END DO
END DO
END SUBROUTINE
So I don't understand several things in your algorithm :
the second loop over j should be from i to n (or i+1 to n) :
there is no test within the loops
the global complexity (number of multiplications) is n^3/3. Your algorithm is in n^3
I have never done programming in my life and this is my very first code for a uni assignment, I get no errors in the compiling stage but myh program does not run saying that I have the error in the title, guess the problem is when I call the subroutine. Can anyone help me? It is my first code and it is really frustrating. Thank you.
!NUMERICAL COMPUTATION OF INCOMPRESSIBLE COUETTE FLOW USING FINITE DIFFERENCE METHOD
!IMPLICIT APPROACH
!MODEL EQUATION
!PARTIAL(U)/PARTIAL(T)=1/RE*(PARTIAL(U) SQUARE/PARTIAL(Y) SQUARE)
!DEFINE VARIABLES
IMPLICIT NONE
!VELOCITY U AT TIME T, VELOCITY UNEW AT TIME T+1, TIME T
!MAXIMUM 1000 POINTS
REAL V(1000)
REAL VNEW(1000)
REAL T
!GRID SPACING DY, GRID POINTS N+1
REAL DY
INTEGER N
!TIME STEP
REAL DT
!FLOW REYNOLDS NUMBER IN THE MODEL EQUATION
REAL ALPHA
!TOTAL SIMULATION TIME - LOOP NUMBER
INTEGER REP, I, J
!COEFFICIENTS IN LINEAR EQUATION MATRIX, SOURCE TERM K, DIAGONAL B, NON-DIAGONAL A
REAL S(1000), B, A
!INITIALIZATION OF DATA
DATA ALPHA/5000.0/
DATA N/100/
DATA REP/3000/
!CALCULATION OF GRID SPACING
DY=1.0/N
!CALCULATION OF TIME STEP DELTA T, CAN BE LARGER THAN THAT IN AN EXPLICIT METHOD
DT=0.5*RE*DY*DY
DT=ALPHA*DY*DY
!INITIAL CONDITIONS OF VELOCITY PROFILE
!BOTTOM AND INNER POINTS
DO I=1,N
V(I)=0.0
ENDDO
!POINT AT MOVING PLATE
V(N+1)=1.0
!BOUNDARY CONDITIONS AT LOWER AND UPPER POINTS ON PLATE
V(1)=0.0
V(N+1)=1.0
!CALCULATION OF DIAGONAL B AND NON-DIAGONAL A IN LINEAR EQUATION MATRIX
B=1.0+DT/DY/DY/ALPHA
A=-(DT)/2.0/DY/DY/ALPHA
!INITIAL COMPUTATION TIME
T=0.0
!ENTER MAIN LOOP TO MARCH IN TIME DIRECTION
DO I=1,REP
!SIMULATION TIME INCREASE BY DELTA T EACH STEP
T=T+DT
!USE IMPLICIT METHOD TO UPDATE GRID POINT VALUES FOR ALL INTERNAL GRIDS ONLY
!TWO BOUNDARY GRID POINTS VALUES ARE CONSTANT WITHIN THE WHOLE SIMULATION
!CALCULATION OF SOURCE TERM IN LINEAR EQUATION
DO J=2,N
S(J)=(1.0-DT/DY/DY/ALPHA)*V(J)+DT/2.0/DY/DY/ALPHA*V(J+1)+V(J-1)
ENDDO
!INCLUDE BOUNDARY CONDITIONS FOR TWO POINTS NEAR BOUDNARY
S(2)=S(2)-A*V(1)
S(N)=S(N)-A*V(N+1)
!USE SOURCE TERM K, DIAGONAL B, NON-DIAGONAL A, ORDER OF MATRIX N, TO SOLVE LINEAR EQUATION TO GET UPDATED VELOCITY
!CHECK ON INTERNET HOW TO SOLVE THIS BECUASE THIS COMPILER
!DOES NOT SOLVE IT, SOLVE LINEAR EQUATIONS BY A LINEAR SOLVER, FIND AND DOWNLOAD THE MATH LIBRARY FOR THIS COMPILER
CALL SR1(A,B,N,S,VNEW)
!REPLACE OLD VELOCITY VALUES WITH NEW VALUES.
!SINCE UNEW IS FROM UNEW(1), UNEW(2)......., UNEW(N-1), WE SHOULD RE-ARRANGE NUMBERS AS FOLLOWS
DO J=1,N-1
V(J+1)=VNEW(J)
ENDDO
!RETURN TO MAIN LOOP HERE
ENDDO
PRINT*,'HERE'
!OUTPUT VELOCITY PROFILES AT THE END OF COMPUTATION
!CREATE OUPUT FILE NAME
OPEN(15,FILE='PLEASEWORK')
!WRITE GRID POINTS AND VELOCITY VALUES
DO I=1,N+1
WRITE(15,10) V(I),(I-1)*DY
10 FORMAT(2F12.3)
ENDDO
CLOSE(15)
!DISPLAY INFORMATION ON SCREEN
!WRITE(*,*) 'THE OUTPUT VELOCITY IS AFTER', ITER, ' TIME STEPS'
!TERMINATION OF COMPUTER PROGRAM
STOP
END
!!!!!!!!
!!!!!!!!!!!!
!!!!!!!!!
SUBROUTINE SR1(A,B,N,S,VNEW)
REAL DIAGM(N), DIAGU(N), DIAGL(N)
REAL SS(N)
DO J=1,N-1
SS(J)=S(J+1)
ENDDO
DO I=1,N
DIAGM(i)=B
!Sets main diagonal as B for every value of i
IF (I==0) then
DIAGU(I)=A
DIAGL(I)=0
! No lower diagonal coefficient when i = 0
ELSE IF (I==N) THEN
DIAGU(I)=0
! No upper diagonal coefficient when i = Num
DIAGL(I)=A
ELSE
DIAGU(I)=A
! For all other points there is an upper diagonal coefficient
DIAGL(I)=A
! For all other points there is a lower diagonal coefficient
ENDIF
ENDDO
!CALL STANDARD FORTRAN MATH LIBRARY TO SOLVE LINEAR EQUATION AND GET SOLUTION VECTOR X(N-1)
CALL SR2 (DIAGL,DIAGM,DIAGU,SS,VNEW,N-2)
!RETURN TO MAIN PROGRAM AND X(N-1) IS FEEDED INTO UNEW(N-1)
RETURN
END SUBROUTINE
!!!!!!!!!!!!!!!
!!!!!!!!!!!
!!!!!!!!!!!
SUBROUTINE SR2 (A,B,C,D,Z,N)
!a - sub-diagonal (means it is the diagonal below the main diagonal)
!b - the main diagonal
!c - sup-diagonal (means it is the diagonal above the main diagonal)
!K - right part
!UNEW - the answer
!E - number of equations
INTEGER N
REAL A(N), B(N), C(N), D(N)
REAL CP(N), DP(N), Z(N)
REAL M
INTEGER I
DATA M/1/
!initialize c-prime and d-prime
CP(1) = C(1)/B(1)
DP(1) = D(1)/B(1)
!solve for vectors c-prime and d-prime
DO I=2,N
M=b(i)-CP(I-1)*(A(I))
CP(I)=C(I)/M
DP(I)=(D(I)-DP(I-1)*A(I))/M
ENDDO
!initialize UNEW
Z(N)=DP(N)
!solve for x from the vectors c-prime and d-prime
DO I=N-1, 1, -1
Z(I)=DP(I)-CP(I)*Z(I+1)
ENDDO
END SUBROUTINE
As george says in a comment, the problem is with the subroutine SR1. So that this isn't just a CW-stealing-a-comment answer I'll also expand a bit.
The way things are structured SR1 is a different scope from the main program. The IMPLICIT NONE in the main program doesn't apply to the subroutine, so A, B, N, S and VNEW are all implicitly typed. Apart from N,which is an integer, they are (scalar) reals.
The reference to S(J+1), as george says, means that S is not only a scalar real, but also a function. Remember that SR1 is a different scope and no information is passed from the caller to the callee about types, shapes, etc.. Further, that the dummy argument in SR1 called A happens to be same name as the actual argument in the call doesn't mean that the callee "knows" things. Your call to SR2 with the VNEW is also a problem for the same reason.
The question is tagged as "fortran77" so there isn't too much you can do to ensure there is a lot of checking going on, but there may well be compiler options and as you can use IMPLICIT NONE (not Fortran 77) that would detect your problems.
But, the question is also tagged "fortran" and "fortran95" so I'll point out that there are far better ways to detect the issues, using more modern features. Look at interfaces, modules and internal procedures.