issues with Fortran function reshape - fortran

I'm using codeblocks and gnu compiler to run Fortran code but I noticed something very strange.
Once I have an array (1,2,3,...,16) if I want to reshape to a 4x4 matrix I use the built-in reshape function, which should in theory use a column-major order for the numbers and so give (1 5 9 13; 2 6 10 14; 3 7 11 15; 4 8 12 16);
instead I get (1 2 3 4; 5 6 7 8; 9 10 11 12; 13 14 15 16).
This is a major inconsistency, I wonder if it is related to using codeblocks or what.
Anyone else with this problem and/or an idea about the reason and a solution.

I could not replicate the issue with Intel Fortran oneAPI HPC
and code for reference
program FortranConsole1
use, intrinsic :: iso_fortran_env
implicit none
interface show
procedure show_matrix_i, show_matrix_r, show_matrix_d
end interface
integer :: row(16), matrix(4,4)
real(real64) :: A(4,4)
row = [1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16]
matrix = reshape( row, [4, 4])
call show(matrix)
A = dble(matrix)
A = sqrt( matmul( transpose(A), A) )
call show(A, 8)
call show(A, 12)
call show(A, 16)
contains
subroutine show_matrix_i(A, w)
! Display the matrix 'A' in columns
! A : the array of integers
! w : the column width. Default = 5
integer, intent(in) :: A(:,:)
integer, intent(in), optional :: w
integer :: i,j,n,m, wt
character(len=16) :: fmt
if(present(w)) then
wt = w
else
wt = 5
end if
n = size(A,1)
m = size(A,2)
write( fmt, "(a,g0,a)") "(*(g",wt,".0))"
write( * , fmt ) ( (A(i,j),j=1,m), new_line("A"), i=1,n )
end subroutine
subroutine show_matrix_r(A, w)
! Display the matrix 'A' in columns
! A : the array of real numbers
! w : the column width. deafult = 12
! s : sig. figures w-5 (calculated)
real(real32), intent(in) :: A(:,:)
integer, intent(in), optional :: w
integer :: i,j,n,m,dg,wt
character(len=16) :: fmt
if(present(w)) then
wt = w
else
wt = 12
end if
dg = wt-5
n = size(A,1)
m = size(A,2)
write( fmt, "(a,g0,a,g0,a)") "(*(g",wt,".",dg,"))"
write( * , fmt ) ( (A(i,j),j=1,m), new_line("A"), i=1,n )
end subroutine
subroutine show_matrix_d(A,w)
! Display the matrix 'A' in columns
! A : the array of dble numbers
! w : the column width. default = 12
! Converts 'A' into single precision and calls `show_matrix_r`
real(real64), intent(in) :: A(:,:)
integer, intent(in), optional :: w
call show_matrix_r(real(A),w)
end subroutine
end program FortranConsole1
with results

Related

Fortran Subroutines/Functions: Returned Value Changes If Subroutines/Functions Is Called More Often?

I am currently implementing integrals in Fortran as subroutines. The subroutines on their own return the correct values. If i now call the e.g. same subroutine twice after each other, with the same input values, their returned value differs significantly?
The main program only calls the function like this:
program main
use types
use constants
use integrals
use basis
real(dp), dimension(2,3) :: molecule_coords
real(dp), dimension(2) :: z
type(primitive_gaussian), allocatable :: molecule(:,:)
molecule_coords(1,:) = (/0.,0.,0./)
molecule_coords(2,:) = (/0.,0.,1.6/)
molecule = def_molecule(molecule_coords)
z = (/1.0, 1.0/)
call overlap(molecule) ! Correct Value returned
call overlap(molecule) ! Wrong Value returned
end program main
My function for the overlap looks like this:
module integrals
use types
use constants
use basis
use stdlib_specialfunctions_gamma!, only: lig => lower_incomplete_gamma
contains
subroutine overlap(molecule)
implicit none
type(primitive_gaussian), intent(in) :: molecule(:,:)
integer :: nbasis, i, j, k, l
real(dp) :: norm, p, q, coeff, Kab
real(dp), dimension(3) :: Q_xyz
real(dp), dimension(INT(size(molecule,1)),INT(size(molecule,1))) :: S
nbasis = size(molecule,1)
do i = 1, nbasis
do j = 1, nbasis
! Iterate over l and m primitives in basis
do k = 1, size(molecule(i,:))
do l = 1, size(molecule(j,:))
norm = molecule(i, k)%norm() * molecule(j, l)%norm()
! Eq. 63
Q_xyz = (molecule(i, k)%coords - molecule(j, l)%coords)
! Eq. 64, 65
p = (molecule(i, k)%alpha + molecule(j, l)%alpha)
q = (molecule(i, k)%alpha * molecule(j, l)%alpha) / p
! Eq. 66
Kab = exp(-q * dot_product(Q_xyz,Q_xyz))
coeff = molecule(i, k)%coeff * molecule(j, l)%coeff
S(i,j) = S(i,j) + norm * coeff * Kab * (pi / p) ** (1.5)
end do
end do
end do
end do
print *, S
end subroutine overlap
end module integrals
I am a bit lost, why this would be the case, but I am also rather new to Fortran.
Any help is appreciated! Thanks!

Why does segmentation fault arise in fortran under calling subroutine nested gradually in two functions with double precision?

I try to call subroutine SPLEV of FITPACK library through two functions ('wer' and 'qwe') nested one into another (the code is below).
The following message appears under execution of compiled program:
QWE
Program received signal SIGSEGV: Segmentation fault - invalid memory reference.
Backtrace for this error:
0 0x7F3EE4BF3E08
1 0x7F3EE4BF2F90
2 0x7F3EE453A4AF
3 0x4041B6 in splev_
4 0x400BD0 in value.3386 at pr.f90:?
5 0x400A6B in MAIN__ at pr.f90:?
Ошибка сегментирования (сделан дамп памяти)
If I compile my program with flags -g -fbacktrace -fsanitize=address,zero,undefined the follow output message appears:
QWE
0.37051690837706980
Program received signal SIGSEGV: Segmentation fault - invalid memory reference.
Backtrace for this error:
0 0x7FAB5F45CE08
1 0x7FAB5F45BF90
2 0x7FAB5EDA34AF
3 0x4075F0 in splev_ at splev.f:73 (discriminator 2)
4 0x400DDE in value.3386 at pr.f90:87
5 0x400FFA in qwe.3406 at pr.f90:43
6 0x400F88 in wer.3403 at pr.f90:48
7 0x400D08 in MAIN__ at pr.f90:38
Ошибка сегментирования (сделан дамп памяти)
If I compile my program with flags -g -fbacktrace -Wall -fcheck=all the follow output message appears:
QWE
Program received signal SIGSEGV: Segmentation fault - invalid memory reference.
Backtrace for this error:
0 0x7F2BE6F0FE08
1 0x7F2BE6F0EF90
2 0x7F2BE68564AF
3 0x4075F0 in splev_ at splev.f:73 (discriminator 2)
4 0x400DDE in value.3386 at pr.f90:87
5 0x400C46 in MAIN__ at pr.f90:35
Ошибка сегментирования (сделан дамп памяти)
If I compile my program with flags -g -fbacktrace -fsanitize=address the follow output message appears:
QWE
ASAN:SIGSEGV
=================================================================
==4796==ERROR: AddressSanitizer: SEGV on unknown address 0x000000000000 (pc 0x000000408f67 bp 0x7ffe7a134440 sp 0x7ffe7a1341e0 T0)
0 0x408f66 in splev_ /home/yurchvlad/Science/Coll_Int/F90/f90DP/1/splev.f:73
1 0x40145d in value.3386 (/home/yurchvlad/Science/Coll_Int/F90/f90DP/1/curfit+0x40145d)
2 0x4011a3 in intcoll /home/yurchvlad/Science/Coll_Int/F90/f90DP/1/pr.f90:35
3 0x401849 in main /home/yurchvlad/Science/Coll_Int/F90/f90DP/1/pr.f90:2
4 0x7fcad9b3282f in __libc_start_main (/lib/x86_64-linux-gnu/libc.so.6+0x2082f)
5 0x400d38 in _start (/home/yurchvlad/Science/Coll_Int/F90/f90DP/1/curfit+0x400d38)
AddressSanitizer can not provide additional info.
SUMMARY: AddressSanitizer: SEGV /home/yurchvlad/Science/Coll_Int/F90/f90DP/1/splev.f:73 splev_
==4796==ABORTING
Firstly I will show the code and then I will give some information about subroutines CURFIT and SPLEV of library FITPACK which are playing there a principal role.
Here is my code. This is just a test program, i.e. it is not confusion, that I interpolate there array of values of analytical function.
PROGRAM IntColl
USE Constants
IMPLICIT NONE
INTEGER :: i, nen ! i = counter
! nen, nmn, ne is sirvice variables, which
! appear on exit of CURFIT and needed on entry
! of SPLEV and SPLINT
REAL(DP) :: foo
REAL(DP) :: MOM1 ! dimensionless neutrino momentum
REAL(DP) :: dmg ( 1 : 2 * NG) ! dimensionless momentum grid
REAL(DP) :: endf( 1 : 2 * NG) ! electron neutrino distribution function
! muon neutrino distribution function
! electron and positron distribution function
REAL(DP) :: ten ( 1 : 2 * NG + k + 1) ! service arrays:
! ten is array arising on exit of working of CURFIT
! and contain knots of the spline (for endf, mndf and edf correspondingly).
REAL(DP) :: cen ( 1 : 2 * NG + k + 1) ! needed on entry of SPLEV and SPLINT
! cen appear on exit of CURFIT, contain coefficients of spline
! (for endf, mndf and edf correspondingly) and needed on entry of SPLEV and SPLINT.
REAL(DP) :: w ( 1 : 2 * NG + k + 1) ! w is array of weights for points on entry of CURFIT.
DO i = 1, 2 * NG
dmg(i) = i / 10.D+00 ! filling arrays to give their
endf(i) = eq_nu_di_fu(dmg(i)) ! on entry into subroutine
w(i) = 1.d+00 ! CURFIT
END DO
MOM1 = .53D+00
PRINT *, 'QWE'
CALL spline(dmg, endf, nen, ten, cen)
foo = value(MOM1, ten, nen, cen)
PRINT *, foo
PRINT *, wer(MOM1)
CONTAINS
REAL(DP) FUNCTION qwe(q) ! qwe and wer is "wrappers" for using
REAL(DP) :: q ! of subroutines spline > curfit
qwe = value(q, ten, nen, cen) ! in main program
END FUNCTION qwe
REAL(DP) FUNCTION wer(q)
REAL(DP) :: q
wer = qwe(q)
END FUNCTION wer
SUBROUTINE spline(x, y, n, t, c) ! spline is "hand-made wrapper" for
IMPLICIT NONE ! more convenient using of subroutine
! CURFIT in main program
INTEGER :: m, nest, n, lwrk, ier
INTEGER, PARAMETER :: iopt = 0
INTEGER :: iwrk( 1 : 10 * NG )
REAL(DP) :: xb, xe, fp
REAL(DP) :: wrk( 1 : 2 * NG * (k + 1) + (2 * NG + k + 1) * (7 + 3 * k) )
REAL(DP) :: x( 1 : 2 * NG), y(1: 2 * NG )
REAL(DP) :: t( 1 : 2 * NG + k + 1 )
REAL(DP) :: c( 1 : 2 * NG + k + 1 )
xb = 0.d+00
xe = x(2 * NG)
m = 2 * NG
nest = m + k + 1
lwrk = 2 * NG * (k + 1) + nest * (7 + 3 * k)
CALL curfit(iopt, m, x, y, w, xb, xe, k, s, nest, n, t, c, fp, wrk, lwrk, iwrk, ier)
END SUBROUTINE spline
REAL(DP) FUNCTION value(q, t, n, c) ! value is "hand-made wrapper" for
IMPLICIT NONE ! more convenient using of subroutine
! SPLEV in main program
INTEGER :: n, ier ! SPLEV should work only after
INTEGER, PARAMETER :: m = 1 ! CURFIT edned its working
REAL(DP) :: q
REAL(DP) :: t( 1 : 2 * NG + k + 1 )
REAL(DP) :: c( 1 : 2 * NG + k + 1 )
REAL(DP) :: ddmg(1), sddmg(1)
ddmg(1) = q
CALL splev(t, n, c, k, ddmg, sddmg, m, ier)
value = sddmg(1)
END FUNCTION value
REAL(DP) FUNCTION eq_nu_di_fu(y) ! eq_nu_di_fy givev values for array
IMPLICIT NONE ! to interpolate
REAL(DP) :: y
eq_nu_di_fu = 1 / (EXP(y) + 1)
END FUNCTION eq_nu_di_fu
END PROGRAM IntColl
The module Constants is there:
MODULE CONSTANTS
INTEGER, PARAMETER :: DP = SELECTED_REAL_KIND(15, 307)
INTEGER, PARAMETER :: NG = 200 ! NUMBER OF KNOTS OF GRID
INTEGER , PARAMETER :: K = 3 ! THE ORDER OF SPLINE
REAL(DP), PARAMETER :: S = 0.D+00 ! CUBIC SPLINE SMOOTHING FACTOR
END MODULE
Now, subroutines CURFIT and SPLEV appearing in above code with all their dependensies are in follow sources:
https://github.com/jbaayen/fitpackpp/tree/master/fitpack
where these subroutines are in double precision
and
http://www.netlib.org/dierckx/
where these subroutines are in single precision.
It is very important to mention that with single precision above scheme works!
Of course, if I use subroutines of single precision I modify all the types of all variables in corrisponding way.
What else have I observed:
straightforward using of FUNCTION value works.
If the line
PRINT *, 'QWE'
of the main program is commented, the value 'foo' also is not printed.

Storing a Variable with a Multi-Dimensional Index in Fortran

Question
Consider the following code:
program example
implicit none
integer, parameter :: n_coeffs = 1000
integer, parameter :: n_indices = 5
integer :: i
real(8), dimension(n_coeffs) :: coeff
integer, dimension(n_coeffs,n_indices) :: index
do i = 1, n_coeffs
coeff(i) = real(i*3,8)
index(i,:) = [2,4,8,16,32]*i
end do
end
For any 5 dimensional index I need to obtain the associated coefficient, without knowing or calculating i. For instance, given [2,4,8,16,32] I need to obtain 3.0 without computing i.
Is there a reasonable solution, perhaps using sparse matrices, that would work for n_indices in the order of 100 (though n_coeffs still in the order of 1000)?
A Bad Solution
One solution would be to define a 5 dimensional array as in
real(8), dimension(2000,4000,8000,16000,32000) :: coeff2
do i = 1, ncoeffs
coeff2(index(i,1),index(i,2),index(i,3),index(i,4),index(i,5)) = coeff(i)
end do
then, to get the coefficient associated with [2,4,8,16,32], call
coeff2(2,4,8,16,32)
However, besides being very wasteful of memory, this solution would not allow n_indices to be set to a number higher than 7 given the limit of 7 dimensions to an array.
OBS: This question is a spin-off of this one. I have tried to ask the question more precisely having failed in the first attempt, an effort that greatly benefited from the answer of #Rodrigo_Rodrigues.
Actual Code
In case it helps here is the code for the actual problem I am trying to solve. It is an adaptive sparse grid method for approximating a function. The main goal is to make the interpolation at the and as fast as possible:
MODULE MOD_PARAMETERS
IMPLICIT NONE
SAVE
INTEGER, PARAMETER :: d = 2 ! number of dimensions
INTEGER, PARAMETER :: L_0 = 4 ! after this adaptive grid kicks in, for L <= L_0 usual sparse grid
INTEGER, PARAMETER :: L_max = 9 ! maximum level
INTEGER, PARAMETER :: bound = 0 ! 0 -> for f = 0 at boundary
! 1 -> adding grid points at boundary
! 2 -> extrapolating close to boundary
INTEGER, PARAMETER :: max_error = 1
INTEGER, PARAMETER :: L2_error = 1
INTEGER, PARAMETER :: testing_sample = 1000000
REAL(8), PARAMETER :: eps = 0.01D0 ! epsilon for adaptive grid
END MODULE MOD_PARAMETERS
PROGRAM MAIN
USE MOD_PARAMETERS
IMPLICIT NONE
INTEGER, DIMENSION(d,d) :: ident
REAL(8), DIMENSION(d) :: xd
INTEGER, DIMENSION(2*d) :: temp
INTEGER, DIMENSION(:,:), ALLOCATABLE :: grid_index, temp_grid_index, grid_index_new, J_index
REAL(8), DIMENSION(:), ALLOCATABLE :: coeff, temp_coeff, J_coeff
REAL(8) :: temp_min, temp_max, V, T, B, F, x1
INTEGER :: k, k_1, k_2, h, i, j, L, n, dd, L1, L2, dsize, count, first, repeated, add, ind
INTEGER :: time1, time2, clock_rate, clock_max
REAL(8), DIMENSION(L_max,L_max,2**(L_max),2**(L_max)) :: coeff_grid
INTEGER, DIMENSION(d) :: level, LL, ii
REAL(8), DIMENSION(testing_sample,d) :: x_rand
REAL(8), DIMENSION(testing_sample) :: interp1, interp2
! ============================================================================
! EXECUTABLE
! ============================================================================
ident = 0
DO i = 1,d
ident(i,i) = 1
ENDDO
! Initial grid point
dsize = 1
ALLOCATE(grid_index(dsize,2*d),grid_index_new(dsize,2*d))
grid_index(1,:) = 1
grid_index_new = grid_index
ALLOCATE(coeff(dsize))
xd = (/ 0.5D0, 0.5D0 /)
CALL FF(xd,coeff(1))
CALL FF(xd,coeff_grid(1,1,1,1))
L = 1
n = SIZE(grid_index_new,1)
ALLOCATE(J_index(n*2*d,2*d))
ALLOCATE(J_coeff(n*2*d))
CALL SYSTEM_CLOCK (time1,clock_rate,clock_max)
DO WHILE (L .LT. L_max)
L = L+1
n = SIZE(grid_index_new,1)
count = 0
first = 1
DEALLOCATE(J_index,J_coeff)
ALLOCATE(J_index(n*2*d,2*d))
ALLOCATE(J_coeff(n*2*d))
J_index = 0
J_coeff = 0.0D0
DO k = 1,n
DO i = 1,d
DO j = 1,2
IF ((bound .EQ. 0) .OR. (bound .EQ. 2)) THEN
temp = grid_index_new(k,:)+(/ident(i,:),ident(i,:)*(grid_index_new(k,d+i)-(-1)**j)/)
ELSEIF (bound .EQ. 1) THEN
IF (grid_index_new(k,i) .EQ. 1) THEN
temp = grid_index_new(k,:)+(/ident(i,:),ident(i,:)*(-(-1)**j)/)
ELSE
temp = grid_index_new(k,:)+(/ident(i,:),ident(i,:)*(grid_index_new(k,d+i)-(-1)**j)/)
ENDIF
ENDIF
CALL XX(d,temp(1:d),temp(d+1:2*d),xd)
temp_min = MINVAL(xd)
temp_max = MAXVAL(xd)
IF ((temp_min .GE. 0.0D0) .AND. (temp_max .LE. 1.0D0)) THEN
IF (first .EQ. 1) THEN
first = 0
count = count+1
J_index(count,:) = temp
V = 0.0D0
DO k_1 = 1,SIZE(grid_index,1)
T = 1.0D0
DO k_2 = 1,d
CALL XX(1,temp(k_2),temp(d+k_2),x1)
CALL BASE(x1,grid_index(k_1,k_2),grid_index(k_1,k_2+d),B)
T = T*B
ENDDO
V = V+coeff(k_1)*T
ENDDO
CALL FF(xd,F)
J_coeff(count) = F-V
ELSE
repeated = 0
DO h = 1,count
IF (SUM(ABS(J_index(h,:)-temp)) .EQ. 0) THEN
repeated = 1
ENDIF
ENDDO
IF (repeated .EQ. 0) THEN
count = count+1
J_index(count,:) = temp
V = 0.0D0
DO k_1 = 1,SIZE(grid_index,1)
T = 1.0D0
DO k_2 = 1,d
CALL XX(1,temp(k_2),temp(d+k_2),x1)
CALL BASE(x1,grid_index(k_1,k_2),grid_index(k_1,k_2+d),B)
T = T*B
ENDDO
V = V+coeff(k_1)*T
ENDDO
CALL FF(xd,F)
J_coeff(count) = F-V
ENDIF
ENDIF
ENDIF
ENDDO
ENDDO
ENDDO
ALLOCATE(temp_grid_index(dsize,2*d))
ALLOCATE(temp_coeff(dsize))
temp_grid_index = grid_index
temp_coeff = coeff
DEALLOCATE(grid_index,coeff)
ALLOCATE(grid_index(dsize+count,2*d))
ALLOCATE(coeff(dsize+count))
grid_index(1:dsize,:) = temp_grid_index
coeff(1:dsize) = temp_coeff
DEALLOCATE(temp_grid_index,temp_coeff)
grid_index(dsize+1:dsize+count,:) = J_index(1:count,:)
coeff(dsize+1:dsize+count) = J_coeff(1:count)
dsize = dsize + count
DO i = 1,count
coeff_grid(J_index(i,1),J_index(i,2),J_index(i,3),J_index(i,4)) = J_coeff(i)
ENDDO
IF (L .LE. L_0) THEN
DEALLOCATE(grid_index_new)
ALLOCATE(grid_index_new(count,2*d))
grid_index_new = J_index(1:count,:)
ELSE
add = 0
DO h = 1,count
IF (ABS(J_coeff(h)) .GT. eps) THEN
add = add + 1
J_index(add,:) = J_index(h,:)
ENDIF
ENDDO
DEALLOCATE(grid_index_new)
ALLOCATE(grid_index_new(add,2*d))
grid_index_new = J_index(1:add,:)
ENDIF
ENDDO
CALL SYSTEM_CLOCK (time2,clock_rate,clock_max)
PRINT *, 'Elapsed real time1 = ', DBLE(time2-time1)/DBLE(clock_rate)
PRINT *, 'Grid Points = ', SIZE(grid_index,1)
! ============================================================================
! Compute interpolated values:
! ============================================================================
CALL RANDOM_NUMBER(x_rand)
CALL SYSTEM_CLOCK (time1,clock_rate,clock_max)
DO i = 1,testing_sample
V = 0.0D0
DO L1=1,L_max
DO L2=1,L_max
IF (L1+L2 .LE. L_max+1) THEN
level = (/L1,L2/)
T = 1.0D0
DO dd = 1,d
T = T*(1.0D0-ABS(x_rand(i,dd)/2.0D0**(-DBLE(level(dd)))-DBLE(2*FLOOR(x_rand(i,dd)*2.0D0**DBLE(level(dd)-1))+1)))
ENDDO
V = V + coeff_grid(L1,L2,2*FLOOR(x_rand(i,1)*2.0D0**DBLE(L1-1))+1,2*FLOOR(x_rand(i,2)*2.0D0**DBLE(L2-1))+1)*T
ENDIF
ENDDO
ENDDO
interp2(i) = V
ENDDO
CALL SYSTEM_CLOCK (time2,clock_rate,clock_max)
PRINT *, 'Elapsed real time2 = ', DBLE(time2-time1)/DBLE(clock_rate)
END PROGRAM
For any 5 dimensional index I need to obtain the associated
coefficient, without knowing or calculating i. For instance, given
[2,4,8,16,32] I need to obtain 3.0 without computing i.
function findloc_vector(matrix, vector) result(out)
integer, intent(in) :: matrix(:, :)
integer, intent(in) :: vector(size(matrix, dim=2))
integer :: out, i
do i = 1, size(matrix, dim=1)
if (all(matrix(i, :) == vector)) then
out = i
return
end if
end do
stop "No match for this vector"
end
And that's how you use it:
print*, coeff(findloc_vector(index, [2,4,8,16,32])) ! outputs 3.0
I must confess I was reluctant to post this code because, even though this answers your question, I honestly think this is not what you really want/need, but you dind't provide enough information for me to know what you really do want/need.
Edit (After actual code from OP):
If I decrypted your code correctly (and considering what you said in your previous question), you are declaring:
REAL(8), DIMENSION(L_max,L_max,2**(L_max),2**(L_max)) :: coeff_grid
(where L_max = 9, so size(coeff_grid) = 21233664 =~160MB) and then populating it with:
DO i = 1,count
coeff_grid(J_index(i,1),J_index(i,2),J_index(i,3),J_index(i,4)) = J_coeff(i)
ENDDO
(where count is of the order of 1000, i.e. 0.005% of its elements), so this way you can fetch the values by its 4 indices with the array notation.
Please, don't do that. You don't need a sparse matrix in this case either. The new approach you proposed is much better: storing the indices in each row of an smaller array, and fetching on the array of coefficients by the corresponding location of those indices in its own array. This is way faster (avoiding the large allocation) and much more memory-efficient.
PS: Is it mandatory for you to stick to Fortran 90? Its a very old version of the standard and chances are that the compiler you're using implements a more recent version. You could improve the quality of your code a lot with the intrinsic move_alloc (for less array copies), the kind constants from the intrinsic module iso_fortran_env (for portability), the [], >, <, <=,... notation (for readability)...

Fortran character format string as subroutine argument

I am struggling with reading a text string in. Am using gfortran 4.9.2.
Below I have written a little subroutine in which I would like to submit the write format as argument.
Ideally I'd like to be able to call it with
call printarray(mat1, "F8.3")
to print out a matrix mat1 in that format for example. The numbers of columns should be determined automatically inside the subroutine.
subroutine printarray(x, udf_temp)
implicit none
real, dimension(:,:), intent(in) :: x ! array to be printed
integer, dimension(2) :: dims ! array for shape of x
integer :: i, j
character(len=10) :: udf_temp ! user defined format, eg "F8.3, ...
character(len = :), allocatable :: udf ! trimmed udf_temp
character(len = 10) :: udf2
character(len = 10) :: txt1, txt2
integer :: ncols ! no. of columns of array
integer :: udf_temp_length
udf_temp_length = len_trim(udf_temp)
allocate(character(len=udf_temp_length) :: udf)
dims = shape(x)
ncols = dims(2)
write (txt1, '(I5)') ncols
udf2 = trim(txt1)//adjustl(udf)
txt2 = "("//trim(udf2)//")"
do i = 1, dims(1)
write (*, txt2) (x(i, j), j = 1, dims(2)) ! this is line 38
end do
end suroutine printarray
when I set len = 10:
character(len=10) :: udf_temp
I get compile error:
call printarray(mat1, "F8.3")
1
Warning: Character length of actual argument shorter than of dummy argument 'udf_temp' (4/10) at (1)
When I set len = *
character(len=*) :: udf_temp
it compiles but at runtime:
At line 38 of file where2.f95 (unit = 6, file = 'stdout')
Fortran runtime error: Unexpected element '( 8
What am I doing wrong?
Is there a neater way to do this?
Here's a summary of your question that I will try to address: You want to have a subroutine that will print a specified two-dimensional array with a specified format, such that each row is printed on a single line. For example, assume we have the real array:
real, dimension(2,8) :: x
x = reshape([1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16], shape=[2,8], order=[2,1])
! Then the array is:
! 1.000 2.000 3.000 4.000 5.000 6.000 7.000 8.000
! 9.000 10.000 11.000 12.000 13.000 14.000 15.000 16.000
We want to use the format "F8.3", which prints floating point values (reals) with a field width of 8 and 3 decimal places.
Now, you are making a couple of mistakes when creating the format within your subroutine. First, you try to use udf to create the udf2 string. This is a problem because although you have allocated the size of udf, nothing has been assigned to it (pointed out in a comment by #francescalus). Thus, you see the error message you reported: Fortran runtime error: Unexpected element '( 8.
In the following, I make a couple of simplifying changes and demonstrate a few (slightly) different techniques. As shown, I suggest the use of * to indicate that the format can be applied an unlimited number of times, until all elements of the output list have been visited. Of course, explicitly stating the number of times to apply the format (ie, "(8F8.3)" instead of "(*(F8.3))") is fine, but the latter is slightly less work.
program main
implicit none
real, dimension(2,8) :: x
character(len=:), allocatable :: udf_in
x = reshape([1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16], shape=[2,8], order=[2,1])
udf_in = "F8.3"
call printarray(x, udf_in)
contains
subroutine printarray(x, udf_in)
implicit none
real, dimension(:,:), intent(in) :: x
character(len=*), intent(in) :: udf_in
integer :: ncols ! size(x,dim=2)
character(len=10) :: ncols_str ! ncols, stringified
integer, dimension(2) :: dims ! shape of x
character(len=:), allocatable :: udf0, udf1 ! format codes
integer :: i, j ! index counters
dims = shape(x) ! or just use: ncols = size(x, dim=2)
ncols = dims(2)
write (ncols_str, '(i0)') ncols ! use 'i0' for min. size
udf0 = "(" // ncols_str // udf_in // ")" ! create string: "(8F8.3)"
udf1 = "(*(" // udf_in // "))" ! create string: "(*(F8.3))"
print *, "Version 1:"
do i = 1, dims(1)
write (*, udf0) (x(i, j), j = 1,ncols) ! implied do-loop over j.
end do
print *, "Version 2:"
do i = 1, dims(1)
! udf1: "(*(F8.3))"
write (*, udf1) (x(i, j), j = 1,ncols) ! implied do-loop over j
end do
print *, "Version 3:"
do i = 1, size(x,dim=1) ! no need to create nrows/ncols vars.
write(*, udf1) x(i,:) ! let the compiler handle the extents.
enddo
end subroutine printarray
end program main
Observe: the final do-loop ("Version 3") is very simple. It does not need an explicit count of ncols because the * takes care of it automatically. Due to its simplicity, there is really no need for a subroutine at all.
besides the actual error (not using the input argument), this whole thing can be done much more simply:
subroutine printarray(m,f)
implicit none
character(len=*)f
real m(:,:)
character*10 n
write(n,'(i0)')size(m(1,:))
write(*,'('//n//f//')')transpose(m)
end subroutine
end
note no need for the loop constructs as fortran will automatically write the whole array , line wrapping as you reach the length of data specified by your format.
alternately you can use a loop construct, then you can use a '*' repeat count in the format and obviate the need for the internal write to construct the format string.
subroutine printarray(m,f)
implicit none
character(len=*)f
real m(:,:)
integer :: i
do i=1,size(m(:,1))
write(*,'(*('//f//'))')m(i,:)
enddo
end subroutine
end

subset array with Fortran given a condition?

Suppose I have an array A(n,m). Is it possible to subset that array in Fortran to create a new array? For example,
A = 11 22 43 55
15 56 65 63
54 56 32 78
I want to create an array B with m-1 columns and the rows that satisfies A(:,2) .eq. 56
So B should be:
B = 15 65 63
54 32 78
I don't even know how to start because, for example, the dimension of B should be determined dynamically (I think)
Thanks for the help!
Are you looking for something like this?
function extractB(A) result(B)
integer, dimension(:,:), intent(in) :: A
integer, dimension(:,:), pointer :: B
integer :: nrowB, i, pos
nrowB = count( A(:,2)==56)
allocate( B(nrowB, size(A,2)-1 ) )
pos = 1
do i = 1, size(A,1)
if(A(i,2)==56)then
B(pos,1) = A(i,1)
B(pos,2:) = A(i,3:)
pos = pos+1
end if
end do
end function extractB
That you call like
B = extractB(A)
with B defined like:
integer, dimension(:,:), allocatable :: B
I assumed integer for your arrays. If your compiler implement pointer as return value, you can used pointers in the place of allocatable.
====adding a full program ====
module extract
contains
subroutine testExtract(A, B)
double precision, dimension(:,:), intent(in) :: A
double precision, dimension(:,:), intent(out), allocatable :: B
B = extractB(A)
end subroutine testExtract
function extractB(A) result(B)
double precision, dimension(:,:), intent(in) :: A
double precision, dimension(:,:), allocatable :: B
integer :: nrowB, i, pos
nrowB = count( A(:,2)==56)
allocate( B(nrowB, size(A,2)-1 ) )
pos = 1
do i = 1, size(A,1)
if(A(i,2)==56)then
B(pos,1) = A(i,1)
B(pos,2:) = A(i,3:)
pos = pos+1
end if
end do
end function extractB
end module extract
program test
use extract
integer, parameter :: n = 3
integer, parameter :: m = 4
double precision, dimension(3,4) :: A
double precision, dimension(:,:), allocatable :: B
A(1,:) = [11, 22, 43, 55]
A(2,:) = [15, 56, 65, 63]
A(3,:) = [54, 56, 32, 78]
print*, 'A :'
print*, int(A)
!B = extractB(A)
call testExtract(A, B)
print*, 'B'
print*, int(B)
end program
A loop is clearly a good way to go, but if you want concise, then
integer, dimension(N,M) :: A
integer, allocatable :: B(:,:)
integer i
A = ...
B = A(PACK([(i,i=1,SIZE(A,1))],A(:,2)==56),[1,(i,i=3,SIZE(A,2))])
I should explain this as there are a number of silly things being done here. First note that [..] is an array constructor, and [(..)] is an array constructor with an implied-do.
So [(i,i=1,SIZE(A,1))] creates an array with values 1, ..., N and [1,(i,i=3,SIZE(A,2))] an array with values 1, 3, ..., M. These form the indexes for the rows and columns of A missing out the second column. The PACK part selects those indexes for rows matching the mask condition A(:,2)==56.
Finally, we use vector subscripting to select the suitable rows with the restricted columns.
The only real reason for doing this is to benefit from automatic allocation of B. And that's very marginal.
Don't do this in real code without good documentation.