I have some allocatable arrays which I need to share between some subroutines. I usually would just pass them as arguments or maybe write everything in a Module, but I'm afraid this isn't possible in my situation.
I only write some own subroutines and use subroutines provided and described by an FEM-Solver. So i cannot alter the arguments of this subroutines or wrap them in a Module.
As far as i know it also isn't possible to Build common blocks with array of unknown size at compile time.
Is there something else to pass my arrays?
Update:
At the moment my program environment looks like this:
I have a subroutine, provided by the FEM-program, which is called after each increment, this calls several of my subroutines where I compute some values for each node or for a subset of those.
To display these values in the post-Simulation, i have to pass them to another subroutine. This subroutine is called by the FEM-solver for each node at the end of the increment. So shifting my code to this Subroutine would produce a lot of overhead.
My idea is to compute the values once, store the Values in an array and pass this array to the second subroutine where they will be written to the database of the computation.
Update
Some Pseudo-code:
Assumed from program behaviour:
Program FEM-solver
*magic*
call ENDINC(ar1,ar2)
*something*
do NodeID=1,Sum_Of_Nodes
do valueID=1,Sum_Of_User_Computed_Values !(defined in preprocessing)
call nodeval(NodeID,valueID,Value,ar3,...,arN)
end do
end do
*voodoo*
end program FEM-solver
Written and working:
Subroutine ENDINC(ar1,ar2)
*Computation of some node values*
*Calling of own Subroutines, which compute more values*
*Writing an array with results values for some/each node(s)*
nodersltArr(NodeID,rslt)=*some Value*
end Subroutine ENDINC
Needed, writng the computed Values to the Node solution database:
Subroutine nodeval(NodeID,valueID,Value,ar3,...,arN)
*called for each NodeID and valueID*
value=noderslArr(NodeID,valueID)
end subroutine nodeval
You can pass an allocatable array to procedure that isn't declared to use allocatable arrays, as long as the array is allocated before the call. (Of course, you can't use the array as an allocatable array in the procedure in which it is declared without that property.) Perhaps that will solve your problem. Allocate the array in the code that you write, than pass it as an argument to the FEM solver.
Example code: (I'd normally put the function into a module but you say that you can't do that, so I write an example showing the case of not using a module.)
function MySum ( RegArray )
real :: MySum
real, dimension (:), intent (in) :: RegArray
MySum = sum (RegArray)
end function MySum
program TestArray
implicit none
interface AFunc
function MySum ( SomeArray )
real :: MySum
real, dimension (:), intent (in) :: SomeArray
end function MySum
end interface AFunc
real, dimension (:), allocatable :: AllocArray
integer :: N
real :: answer
write (*, '("Input array size: ")', advance="no")
read (*, *) N
allocate ( AllocArray (1:N) )
AllocArray = 1.0
answer = MySum ( AllocArray )
write (*, *) answer
end program TestArray
---------- EDIT: Second Concept ---------
Sharing an allocatable array between two subroutines, without the calling routine being "aware" of the array.
module MySubs
real, allocatable, dimension (:,:) :: array
contains
subroutine One ( x, y, ... N, M )
integer, intent (in) :: N, M
if ( .NOT. allocated (array) ) allocate ( array (N, M) )
end subroutine One
subroutine Two ( .... )
end subroutine Two
end module MySubs
UPDATE: note: This approach can be used to pass information between the two routines without the main program having access the module ... for the question, without modifying the original main prpgram. Part of the example is how to allocate the arrays: the example does that by having the subroutine that would first use the array test whether the array is allocated -- if not, it allocates the array.
The three examples below all work with gfortran. The second may fail on some compilers as it uses a F2003 feature (allocatable dummy arguments), and not all compilers are 100% F2003 compliant. However, most implement ISO TR 15581 (which includes this feature).
First version, you can use a common pointer to allocatable array.
program hip
implicit none
double precision, dimension(:, :), pointer :: p
common /hiphop/ p
double precision, allocatable, dimension(:, :), target :: a
allocate(a(100, 100))
a(1, 1) = 3.1416d0
p => a
call hop
deallocate(a)
end program
subroutine hop
implicit none
double precision, dimension(:, :), pointer :: p
common /hiphop/ p
print *, size(p, 1), size(p, 2), p(1, 1)
end subroutine
Second version, allocating in a subroutine then calling another. One still needs to declare the array in main program.
program hip
implicit none
interface
subroutine hip_alloc(arr)
double precision, allocatable, dimension(:, :) :: arr
end subroutine
end interface
double precision, dimension(:, :), pointer :: p
common /hiphop/ p
double precision, allocatable, dimension(:, :) :: a
p => null()
print *, "a:", allocated(a)
print *, "p:", associated(p)
call hip_alloc(a)
print *, "a:", allocated(a)
print *, "p:", associated(p)
call hop
deallocate(a)
end program
subroutine hip_alloc(arr)
implicit none
double precision, dimension(:, :), pointer :: p
common /hiphop/ p
double precision, allocatable, dimension(:, :), target :: arr
allocate(arr(100, 100))
arr(1, 1) = 3.1416d0
p => arr
end subroutine
subroutine hop
implicit none
double precision, dimension(:, :), pointer :: p
common /hiphop/ p
print *, size(p, 1), size(p, 2), p(1, 1)
end subroutine
Third version, here we first call a function returning a pointer, then pass this pointer to a subroutine through a common. The function does the allocation, as in second example. The pointer is deallocated in main program, but could be elsewhere.
program hip
implicit none
interface
function hip_alloc(n)
integer :: n
double precision, dimension(:, :), pointer :: hip_alloc
end function
end interface
double precision, dimension(:, :), pointer :: p
common /hiphop/ p
p => null()
print *, "p:", associated(p)
p => hip_alloc(100)
print *, "p:", associated(p)
call hop
deallocate(p)
end program
function hip_alloc(n)
implicit none
integer :: n
double precision, dimension(:, :), pointer :: hip_alloc
allocate(hip_alloc(n, n))
hip_alloc(1, 1) = 3.1416d0
end function
subroutine hop
implicit none
double precision, dimension(:, :), pointer :: p
common /hiphop/ p
print *, size(p, 1), size(p, 2), p(1, 1)
end subroutine
I do not understand why writing a MODULE would not work, but have you considered CONTAINS? Everything above the CONTAINS declaration is visible to the subroutines below the CONTAINS:
PROGRAM call_both
INTEGER,DIMENSION(2) :: a, b
a = 1
b = 2
PRINT *,"main sees", a, b
CALL subA
CALL subB
CONTAINS
SUBROUTINE subA
PRINT *,"subA sees",a,b
END SUBROUTINE subA
SUBROUTINE subB
PRINT *,"subB sees",a,b
END SUBROUTINE subB
END PROGRAM call_both
The output would be
main sees 1 1 2 2
subA sees 1 1 2 2
subB sees 1 1 2 2
This works with ALLOCATABLE arrays as well.
I create a program to solve two-body problem by runge-kutt method. I was faced with the problem: when I call the function which return the ELEMENT of two-dimension array from expression, which must give the ELEMENT of two-dimension array too (sorry for confusion with terms), I get this message:
error #6366: The shapes of the array expressions do not conform.
[X1]
X1(DIM,i)=X1(DIM,i-1)+0.5D0*ABS(i/2)*H*K1(DIM,i-1,X1(DIM,i-1),X2(DIM,i-1),V1(DIM,i-1),V2(DIM,i-1),NDIM,ORD,2,maxnu)
I have a external interface for this function and it's apparently that compiler consider this as a function.
I must clarify some things:
Yes, it's not quite Fortran, it's preprocessor Trefor, which is used by astronomers in Moscow University (I'm just a student). This language is very similar to fortran, but a bit closer to C (Semi-colons for example), which is studied by many students.
Runge-Kutta method can be briefly written as:
We have initial value problem
dy/dt=f(t,y), y(t0)=y0
y is unknown vector, which contains 12 components in my case (3 coordinates and 3 velocities for each body)
next step is
y(n+1)=y(n)+1/6*h*(k1+2k2+2k3+k4), t(n+1)=t(n)+h
where
k1=f(tn,yn),
k2=f(tn+1/2h,yn+h/2*k1)
k3=f(tn+1/2h,yn+h/2*k2)
k4=f(tn+1/2h,yn+k3)
I.e. in my code X1,2 and V1,2 and K_1,2 should be vectors, because each of them must be have 3 spatial components and 4 components for each 'order' of method.
The full code:
FUNCTION K1(DIM,i,X1,X2,V1,V2,NDIM,ORD,nu,maxnu)RESULT (K_1);
integer,intent(in) :: i,DIM,nu;
real(8) :: K_1;
real(8) :: B1;
real(8) :: R;
real(8),intent(in) :: X1,X2,V1,V2;
COMMON/A/M1,M2,Fgauss,H;
integer,intent(in) :: NDIM,ORD,maxnu;
Dimension :: B1(NDIM, ORD);
Dimension :: X1(NDIM,ORD),X2(NDIM,ORD),V1(NDIM,ORD),V2(NDIM,ORD);
Dimension :: K_1(NDIM,ORD);
IF (nu>=2) THEN;
B1(DIM,i)=V1(DIM,i);
ELSE;
R=((X1(1,i)-X2(1,i))**2.D0+(X1(2,i)-X2(2,i))**2.D0+(X1(3,i)-X2(3,i))**2.D0)**0.5D0;
B1(DIM,i)=Fgauss*M2*(X2(DIM,i)-X1(DIM,i))/((R)**3.D0);
END IF;
K_1(DIM,i)=B1(DIM,i);
RETURN;
END FUNCTION K1;
FUNCTION K2(DIM,i,X1,X2,V1,V2,NDIM,ORD,nu,maxnu)RESULT (K_2);
integer,intent(in) :: i,DIM,nu;
real(8) :: K_2;
real(8) :: B2;
real(8) :: R;
real(8),intent(in) :: X1,X2,V1,V2;
COMMON/A/M1,M2,Fgauss,H;
integer,intent(in) :: NDIM,ORD,maxnu;
Dimension :: B2(NDIM,ORD);
Dimension :: X1(NDIM,ORD),X2(NDIM,ORD),V1(NDIM,ORD),V2(NDIM,ORD);
Dimension :: K_2(NDIM,ORD);
IF (nu>=2) THEN;
B2(DIM, i)=V2(DIM,i);
ELSE;
R=((X1(1,i)-X2(1,i))**2.D0+(X1(2,i)-X2(2,i))**2.D0+(X1(3,i)-X2(3,i))**2.D0)**0.5D0;
B2(DIM, i)=Fgauss*M1*(X2(DIM,i)-X1(DIM,i))/((R)**3.D0);
END IF;
K_2(DIM,i)=B2(DIM, i);
RETURN;
END FUNCTION K2;
PROGRAM RUNGEKUTT;
IMPLICIT NONE;
Character*80 STRING;
real(8) :: M1,M2,Fgauss,H;
real(8) :: R,X1,X2,V1,V2;
integer :: N,i,DIM,NDIM,maxnu,ORD;
integer :: nu;
PARAMETER(NDIM=3,ORD=4,maxnu=2);
Dimension :: X1(NDIM,ORD),X2(NDIM,ORD);
Dimension :: V1(NDIM,ORD),V2(NDIM,ORD);
INTERFACE;
FUNCTION K1(DIM,i,X1,X2,V1,V2,NDIM,ORD,nu,maxnu)RESULT (K_1);
integer,intent(in) :: i,DIM,nu;
real(8) :: K_1;
real(8) :: R;
real(8) :: B1;
real(8),intent(in) :: X1,X2,V1,V2;
COMMON/A/M1,M2,Fgauss,H;
integer,intent(in) :: NDIM,ORD,maxnu;
Dimension :: B1(NDIM, ORD);
Dimension :: X1(NDIM,ORD),X2(NDIM,ORD),V1(NDIM,ORD),V2(NDIM,ORD);
Dimension :: K_1(NDIM,ORD);
END FUNCTION K1;
FUNCTION K2(DIM,i,X1,X2,V1,V2,NDIM,ORD,nu,maxnu)RESULT (K_2);
integer,intent(in) :: i,DIM,nu;
real(8) :: K_2;
real(8) :: R;
real(8) :: B2;
real(8),intent(in) :: X1,X2,V1,V2;
COMMON/A/M1,M2,Fgauss,H;
integer,intent(in) :: NDIM,ORD,maxnu;
Dimension :: B2(NDIM,ORD);
Dimension :: X1(NDIM,ORD),X2(NDIM,ORD),V1(NDIM,ORD),V2(NDIM,ORD);
Dimension :: K_2(NDIM,ORD);
END FUNCTION K2;
END INTERFACE;
open(1,file='input.dat');
open(2,file='result.res');
open(3,file='mid.dat');
READ(1,'(A)') STRING;
READ(1,*) Fgauss,H;
READ(1,*) M1,M2;
READ(1,*) X1(1,1),X1(2,1),X1(3,1),V1(1,1),V1(2,1),V1(3,1);
READ(1,*) X2(1,1),X2(2,1),X2(3,1),V2(1,1),V2(2,1),V2(3,1);
WRITE(*,'(A)') STRING;
WRITE(3,'(A)') STRING;
WRITE(3,'(A,2G14.6)')' Fgauss,H:',Fgauss,H;
WRITE(3,'(A,2G14.6)')' M1,M2:',M1,M2;
WRITE(3,'(A,6G17.10)')' X1(1,1),X1(2,1),X1(3,1),V1(1,1),V1(2,1),V1(3,1):',X1(1,1),X1(2,1),X1(3,1),V1(1,1),V1(2,1),V1(3,1);
WRITE(3,'(A,6G17.10)')' X2(1,1),X2(2,1),X2(3,1),V2(1,1),V2(2,1),V2(3,1):',X2(1,1),X2(2,1),X2(3,1),V2(1,1),V2(2,1),V2(3,1);
R=((X1(1,1)-X2(1,1))**2.D0+(X1(2,1)-X2(2,1))**2.D0+(X1(3,1)-X2(3,1))**2.D0)**0.5D0;
N=0;
_WHILE N<=100 _DO;
i=2;
_WHILE i<=ORD _DO;
DIM=1;
_WHILE DIM<=NDIM _DO;
X1(DIM,i)=X1(DIM,i-1)+0.5D0*ABS(i/2)*H*K1(DIM,i-1,X1(DIM,i-1),X2(DIM,i-1),V1(DIM,i-1),V2(DIM,i-1),NDIM,ORD,2,maxnu);
X2(DIM,i)=X2(DIM,i-1)+0.5D0*H*ABS(i/2)*K2(DIM,i-1,X1(DIM,i-1),X2(DIM,i-1),V1(DIM,i-1),V2(DIM,i-1),NDIM,ORD,2,maxnu);
V1(DIM,i)=V1(DIM,i-1)+0.5D0*H*ABS(i/2)*K1(DIM,i-1,X1(DIM,i-1),X2(DIM,i-1),V1(DIM,i-1),V2(DIM,i-1),NDIM,ORD,1,maxnu);
V2(DIM,i)=V2(DIM,i-1)+0.5D0*H*ABS(i/2)*K2(DIM,i-1,X1(DIM,i-1),X2(DIM,i-1),V1(DIM,i-1),V2(DIM,i-1),NDIM,ORD,1,maxnu);
DIM=DIM+1;
_OD;
i=i+1;
_OD;
_WHILE DIM<=NDIM _DO;
X1(DIM,1)=X1(DIM,1)+1.D0/6.D0*H*(K1(DIM,1,X1(DIM,1),X2(DIM,1),V1(DIM,1),V2(DIM,1),NDIM,ORD,2,maxnu)+2.D0*K1(DIM,2,X1(DIM,2),X2(DIM,2),V1(DIM,2),V2(DIM,2),NDIM,ORD,2,maxnu)+2.D0*K1(DIM,3,X1(DIM,3),X2(DIM,3),V1(DIM,3),V2(DIM,3),NDIM,ORD,2,maxnu)+K1(DIM,4,X1(DIM,4),X2(DIM,4),V1(DIM,4),V2(DIM,4),NDIM,ORD,2,maxnu));
X2(DIM,1)=X2(DIM,1)+1.D0/6.D0*H*(K2(DIM,1,X1(DIM,1),X2(DIM,1),V1(DIM,1),V2(DIM,1),NDIM,ORD,2,maxnu)+2.D0*K2(DIM,2,X1(DIM,2),X2(DIM,2),V1(DIM,2),V2(DIM,2),NDIM,ORD,2,maxnu)+2.D0*K2(DIM,3,X1(DIM,3),X2(DIM,3),V1(DIM,3),V2(DIM,3),NDIM,ORD,2,maxnu)+K2(DIM,4,X1(DIM,4),X2(DIM,4),V1(DIM,4),V2(DIM,4),NDIM,ORD,2,maxnu));
V1(DIM,1)=V1(DIM,1)+1.D0/6.D0*H*(K1(DIM,1,X1(DIM,1),X2(DIM,1),V1(DIM,1),V2(DIM,1),NDIM,ORD,1,maxnu)+2.D0*K1(DIM,2,X1(DIM,2),X2(DIM,2),V1(DIM,2),V2(DIM,2),NDIM,ORD,2,maxnu)+2.D0*K2(DIM,3,X1(DIM,3),X2(DIM,3),V1(DIM,3),V2(DIM,3),NDIM,ORD,2,maxnu)+K2(DIM,4,X1(DIM,4),X2(DIM,4),V1(DIM,4),V2(DIM,4),NDIM,ORD,2,maxnu));
V2(DIM,1)=V2(DIM,1)+1.D0/6.D0*H*(K2(DIM,1,X1(DIM,1),X2(DIM,1),V1(DIM,1),V2(DIM,1),NDIM,ORD,1,maxnu)+2.D0*K2(DIM,2,X1(DIM,2),X2(DIM,2),V1(DIM,2),V2(DIM,2),NDIM,ORD,1,maxnu)+2.D0*K2(DIM,3,X1(DIM,3),X2(DIM,3),V1(DIM,3),V2(DIM,3),NDIM,ORD,1,maxnu)+K2(DIM,4,X1(DIM,4),X2(DIM,4),V1(DIM,4),V2(DIM,4),NDIM,ORD,1,maxnu));
_OD;
R=((X1(1,5)-X2(1,5))**2.D0+(X1(2,5)-X2(2,5))**2.D0+(X1(3,5)-X2(3,5))**2.D0)**0.5D0;
N=N+1;
write(2,'(A,1i5,6g12.5)')' N,X1(1,1),X1(2,1),X1(3,1),X2(1,1),X2(2,1),X2(3,1):',N,X1(1,1),X1(2,1),X1(3,1),X2(1,1),X2(2,1),X2(1,1),X2(2,1),X2(3,1);
_OD;
END PROGRAM RUNGEKUTT;
Please, help, it seems, I don't understand something in using functions!
M.S.B. is on the right track, but I think there's enough here to figure out the problem. As noted, function K1 returns a two-dimension array. But all of the other operands in the expression are scalars (well, I don't know what H is, but it likely doesn't matter.) What ends up happening is that the expression evaluates to an array, the scalars getting expanded as needed to match up. You then end up with assigning an array to a scalar, and that's the cause of the error.
I am not familiar enough with Runge-Kutta to be able to suggest what you want instead. But it is likely that you want the function to return a scalar, not an array.
Are you calculating a scaler? If I understand what you are trying to do, the function returns a 2D array, but you only assign to one element of it. Why not have the function return a scaler value instead of an array?
The array message is about an inconsistency between the shapes of arrays in the expression. You haven't shown all of the declarations so we can't figure that out.
Coding style tips: 0) Is there a typo? Should it be Function K1? 1) Semi-colons aren't necessary on the end of each line. Fortran isn't C. 2) At least to me, your code would be more readable if you put all of the declarations pertaining to each variable on one line, instead of separate lines for type, intent and dimension. For example:
real, dimension (NDIM,ORD), intent (in) :: X1
EDIT after the edit of the question:
The machine written code is ugly.
It is clear that you need to do the calculation for all the dimensions. The question is where. The code shows the loops containing the function call rather than the function containing the loops. With this overall design it would make sense that you calculate a single element of the output array (i.e., a scaler variable) and have that be the function return instead of having the function return an array. For this design, it makes little sense to return a 2D array containing only a single used element. And since your statement in the main program expects a scaler, you are getting the error message from the compiler. So redesign your function to return a scaler.
And it looks that you are calling K1 with the actual argument being single elements when arrays are expected. For example, you have X1(DIM,i-1) as a third argument when the function expects an array of size X1(NDIM,ORD). This also a problem, as an inconsistency in actual (i.e., call) and dummy arguments (i.e., function). If function K1 is to do the work of selecting the appropriate array elements, you need to pass it the entire array. If the call is to select the appropriate array elements, then rewrite K1 to have scalers instead of arrays as input arguments. You need a consistent design.