Hi Paul,
Prof. Lassmann reported a bug that I have proofed with FTN95 v4.91. He wrote: In the demonstration program Test_array_assumed_shape the arrays a and b are passed to subroutine test as arrays of assumed shape. The output confirms that shape and bounds have been transferred correctly. However, when a and b are further passed to subroutine swap (see utility.f95), they are obviously considered as arrays of zero shape. This “error” came up since a program from Numerical Recipes did not run correctly.
I hope you can fix this.
He has sent me three files which document the error:
BEGIN DataTypes.f95
MODULE DataTypes INTEGER , PARAMETER :: I4B = SELECTED_INT_KIND (9) INTEGER , PARAMETER :: I2B = SELECTED_INT_KIND (4) INTEGER , PARAMETER :: I1B = SELECTED_INT_KIND (2) INTEGER , PARAMETER :: SP = KIND (1.0) INTEGER , PARAMETER :: DP = KIND (1.0D0) INTEGER , PARAMETER :: LGT = KIND (.true.) REAL (SP), PARAMETER :: PI = 3.141592653589793238462643383279502884197_sp REAL (SP), PARAMETER :: PIO2 = 1.57079632679489661923132169163975144209858_sp REAL (SP), PARAMETER :: TWOPI = 6.283185307179586476925286766559005768394_sp REAL (SP), PARAMETER :: SQRT2 = 1.41421356237309504880168872420969807856967_sp REAL (SP), PARAMETER :: EULER = 0.5772156649015328606065120900824024310422_sp REAL (DP), PARAMETER :: PI_D = 3.141592653589793238462643383279502884197_dp REAL (DP), PARAMETER :: PIO2_D = 1.57079632679489661923132169163975144209858_dp REAL (DP), PARAMETER :: TWOPI_D= 6.283185307179586476925286766559005768394_dp END MODULE DataTypes
END DataTypes.f95
BEGIN Utility.f95 MODULE utility
USE DataTypes IMPLICIT NONE
INTERFACE swap MODULE PROCEDURE swap_i, swap_r, swap_rv END INTERFACE
Contains
SUBROUTINE swap_i(a,b) INTEGER(I4B), INTENT(INOUT) :: a,b INTEGER(I4B) :: dum Write (,) 'Subroutine swap_i' dum=a a=b b=dum END SUBROUTINE swap_i !BL SUBROUTINE swap_r(a,b) REAL(SP), INTENT(INOUT) :: a,b REAL(SP) :: dum Write (,) 'Subroutine swap_r' dum=a a=b b=dum END SUBROUTINE swap_r !BL SUBROUTINE swap_rv(a,b) REAL(SP), DIMENSION(:), INTENT(INOUT) :: a,b REAL(SP), DIMENSION(SIZE(a)) :: dum dum=a a=b b=dum write (,) write (,) ' -------------------------------------------------------' write (,) ' Print out from Swap_rv gives wrong shape of a and b !!!' write (,) ' =======================================================' write (,) ' size (a) =', size (a) write (,) ' size (b) =', size (b) write (,) ' shape (a) =', shape (a) write (,) ' shape (b) =', shape (b) write (,) ' a =', a write (,) ' b =', b write (,) ' -------------------------------------------------------' write (,) END SUBROUTINE swap_rv END MODULE utility
END Utility.f95
BEGIN Test_array_assumed_shape.f95
Winapp
Program Test_array_assumed_shape
! -------------------------------------------------------------------- Interface Subroutine test ( a, b ) Use DataTypes Real (sp), Dimension (:) :: a, b End Subroutine Test End Interface ! --------------------------------------------------------------------
Use DataTypes
Implicit None
Real (sp), Dimension (2) :: a, b
a (1) = 0. ; a (2) = 0.
b (1) = 1. ; b (2) = 1.
! ------------------------------------------------------------------
Call Test ( a, b )
! #########
End Program Test__array_assumed_shape
! ------------------------------------------------------------------ ! ------------------------------------------------------------------
Subroutine test ( a, b )
Use DataTypes
Use Utility
Implicit None
Real (sp) , Dimension (:), Intent (INOUT) :: a, b
Integer (I4B), Dimension (1) :: A_shape, B_shape
Write (*,*)
Write (*,*) ' ===================================================='
Write (*,*) ' Subroutine Test before call swap '
Write (*,*) 'size (a) = ', size (a)
Write (*,*) 'size (b) = ', size (a)
Write (*,*) 'A_shape = ', shape (a)
Write (*,*) 'B_shape = ', shape (b)
Write (*,*) 'A_low = ', Lbound (a)
Write (*,*) 'A_up = ', Ubound (a)
Write (*,*) 'B_low = ', Lbound (b)
Write (*,*) 'B_up = ', Ubound (b)
Write (*,*)
Write (*,*) 'a = ', a
Write (*,*) 'b = ', b
Call Swap ( a, b )
! This gives the correct solution, but why? ! Call Swap ( a (1:2), b (1:2) ) ! #########
Write (*,*) ' Subroutine Test after call swap '
Write (*,*) 'a = ', a
Write (*,*) 'b = ', b
End Subroutine Test
END Test_array_assumed_shape.f95