Fortran syntax for assignments - syntax

The Fortran syntax is driving me mad! Can anyone explain how I can call the assignment (I'm pretty sure that is not the right terminology either...). I'm trying to assign a type according to the value type. I have the following:
module test_module
implicit none
type :: mytype
integer :: i
real :: r
logical :: l
contains
generic :: assignment(=) => mytype_to_type
procedure, pass(me) :: mytype_to_type
end type mytype
contains
subroutine mytype_to_type(t, me)
implicit none
class(*), intent(inout) :: t
class(mytype), intent(in) :: me
!.. process based on input type
select type (t)
type is (integer)
t = me%i
type is (real)
t = me%r
type is (logical)
t = me%l
class default
stop "none"
return
end select
end subroutine mytype_to_type
end module test_module
program test
use test_module
implicit none
type(mytype) :: t_type
integer :: i = 1
real :: r = 1.
logical :: l = .true.
t_type = i !! how is this supposed to work?
select type(t_type)
type is (integer)
write(*,*) "is int"
type is (real)
write(*,*) "is real"
type is (logical)
write(*,*) "is logical"
class default
return
end select
end program test
Would this even work? Could anyone help me with this?
Thanks!

In a subroutine supporting defined assignment the two arguments are such that the first corresponds to the left-hand side of the assignment statement and the second the right-hand side.1
Here, then the subroutine you provide is assignment from a my_type expression to an unlimited polymorphic object. This isn't what you want, seeing t_type on the left.
Instead, you should provide defined assignment to a my_type object.
subroutine stuff_to_mytype(me,t)
class(mytype), intent(out) :: me
class(*), intent(in) :: t
!.. process based on input type
select type (t)
type is (integer)
me%i = t
type is (real)
me%r = t
type is (logical)
me%l = t
class default
stop "none"
return
end select
end subroutine stuff_to_mytype
That said, you could do this with a specific subroutine for each type you support, rather than an unlimited polymorphic right-hand side, with generic resolution. In this case you could also consider generic structure constructors (t_type=mytype(i)).
1 Precisely, the second argument is the right-hand side enclosed in parentheses.

Related

Is it possible in Fortran to determine if two polymorphic objects are the same derived type?

Is it possible to take two polymorphic objects and determine if they are of the same derived type (or class)? The intention is to use it as a clean way to filter a generic linked list.
Something like the following mock code.
function isSameType(a, b) result(itIs)
!arguments
class(*), intent(in) :: a
class(*), intent(in) :: b
!output
logical :: itIs
!return true if a and b are both the same type
!return false if a and b are not
end function isSameType
The standard inquiry function same_type_as tests equality of dynamic type of two objects:
program typetest
implicit none
type t1
end type t1
type t2
end type t2
class(*), allocatable :: a, b
allocate(t1 :: a)
allocate(t2 :: b)
print *, SAME_TYPE_AS(a,b) ! False
end program
same_type_as does not test declared type (except where this is the same thing). It does not consider kind parameters:
program partest
implicit none
type :: t1(n)
integer, kind :: n
end type t1
type(t1(1)) :: a
type(t1(2)) :: b
print *, SAME_TYPE_AS(a,b) ! True
end program
Further, to get a useful result you'll be wanting (at least) one of a and b to be of extensible dynamic type. While you can ask
program intrinsictest
implicit none
class(*), allocatable :: a, b
allocate(real :: a)
allocate(double precision :: b)
print *, SAME_TYPE_AS(a,b) ! ...
end program
the result is processor dependent (could be true or false).

call windows system command through fortran without showing the shell window and output the result to an external file

I'm doing a little project using Fortran. A part of the code is designed to check the PC's mac address. Currently, I'm using call system command as follows:
CALL SYSTEM("ipconfig -all >result.tmp")
Above code will invoke the windows ipconfig-all command and output the information to an external file result.tmp. Later this file will be read to check the mac address.
https://software.intel.com/en-us/forums/intel-visual-fortran-compiler-fo...
I tried that solution, it works fine for the system command "ipconfig -all", but I did not figure out how to output the result to an external file. Does anyone can give me some hints on how to achieve that ?
Above works, except one annoying thing. The Fortran code will be compiled as a DLL and used by another C# program. The annoying thing is, whenever above code is executed in the C# program, a console window will be prompted shortly and then closed. I searched the forum to find if there is some way to disable the window prompt, it turns out there is some solution in the following link:
You also posted this at the Intel forum and user Paul Curtis replied with an example of how to get the MAC address directly using the Windows API.
Since StackOverflow prefers answers that aren't just links, I've included the code below.
MODULE MAC
USE ifwinty
USE charfunc
IMPLICIT NONE
PUBLIC GetMacInfo !, PortExists
PRIVATE
SAVE
INTEGER, PARAMETER :: MAX_ADAPTER_DESCRIPTION_LENGTH = 128
INTEGER, PARAMETER :: MAX_ADAPTER_NAME_LENGTH = 256
INTEGER, PARAMETER :: MAX_ADAPTER_ADDRESS_LENGTH = 8
INTEGER, PARAMETER :: MIB_IF_TYPE_ETHERNET = 6 ! Ipifcons.h
TYPE IP_ADDRESS_STRING
CHARACTER(LEN=16) :: String
END TYPE IP_ADDRESS_STRING
TYPE IP_MASK_STRING
CHARACTER(LEN=16) :: String
END TYPE IP_MASK_STRING
TYPE t_IP_ADDR_STRING
INTEGER (LPLONG) :: pNext
TYPE (IP_ADDRESS_STRING) :: IpAddress
TYPE (IP_MASK_STRING) :: IpMask
INTEGER (DWORD) :: Context
END TYPE t_IP_ADDR_STRING
TYPE t_IP_ADAPTER_INFO
INTEGER(LPLONG) :: pNext
INTEGER(DWORD) :: ComboIndex
CHARACTER(LEN=MAX_ADAPTER_NAME_LENGTH+4) :: AdapterName
CHARACTER(LEN=MAX_ADAPTER_DESCRIPTION_LENGTH+4) :: Description
INTEGER(UINT) :: AddressLength
INTEGER(BYTE) :: Address(MAX_ADAPTER_ADDRESS_LENGTH)
INTEGER(DWORD) :: Index
INTEGER(ULONG) :: iType
INTEGER(ULONG) :: DhcpEnabled
INTEGER(LPLONG) :: pCurrentIpAddress
TYPE(t_IP_ADDR_STRING) :: IpAddressList
TYPE(t_IP_ADDR_STRING) :: GatewayList
TYPE(t_IP_ADDR_STRING) :: DhcpServer
INTEGER(BOOL) :: HaveWins
TYPE(t_IP_ADDR_STRING) :: PrimaryWinsServer
TYPE(t_IP_ADDR_STRING) :: SecondaryWinsServer
INTEGER(ULONG) :: LeaseObtained
INTEGER(ULONG) :: LeaseExpires
END TYPE t_IP_ADAPTER_INFO
! must link with IpHlpApi.lib to access this API function;
! this interface is not included in ifwinty
INTERFACE
INTEGER(BOOL) FUNCTION GetAdaptersInfo (arg1, arg2)
USE ifwinty
!DEC$ ATTRIBUTES DEFAULT, STDCALL, DECORATE, ALIAS:'GetAdaptersInfo' :: GetAdaptersInfo
INTEGER(LPLONG) :: arg1
INTEGER(LPLONG) :: arg2
END FUNCTION
END INTERFACE
CONTAINS
SUBROUTINE GetMacInfo (hwnd, id)
USE contwrap
IMPLICIT NONE
! dialog window handle and set of static-text IDs for display
INTEGER(HANDLE), INTENT(IN) :: hwnd
INTEGER, INTENT(IN), DIMENSION(4) :: id
CHARACTER(LEN=200) :: msg
INTEGER :: i, nc, count
INTEGER, PARAMETER :: acount = 16
TYPE(t_IP_ADAPTER_INFO),ALLOCATABLE :: ai(:)
count = 0
! allow for multiple adapters
ALLOCATE (ai(acount))
nc = SIZEOF(ai)
IF (GetAdaptersInfo(LOC(ai), LOC(nc)) == 0) THEN
DO i = 1, acount
SELECT CASE (ai(i)%iType)
CASE (MIB_IF_TYPE_ETHERNET)
! line 1: description and MAC address
!nc = INDEX(ai(i)%Description, CHAR(0)) - 1
!WRITE (msg, '(A,", ",5(Z2.2,"-"),Z2.2)') &
! ai(i)%Description(1:nc), &
! ai(i)%Address(1:ai(i)%AddressLength)
nc = INDEX(ai(i)%Description, CHAR(0))
msg = ai(i)%Description(1:nc)
count = count + 1
CALL StaticSetText (hwnd, id(count), msg)
CALL ControlSetVisible (hwnd, id(count), .TRUE.)
! line 2: IP and Gateway addresses
WRITE (msg, '("IP Addr: ",A," Gateway: ",A)') &
ai(i)%IpAddressList%IpAddress%string, &
ai(i)%GatewayList%IpAddress%string
CALL remove_nulls (msg)
count = count + 1
CALL StaticSetText (hwnd, id(count), msg)
CALL ControlSetVisible (hwnd, id(count), .TRUE.)
IF (count >= 4) EXIT
END SELECT
IF (ai(i)%pNext == NULL) EXIT
END DO
END IF
DEALLOCATE (ai)
END SUBROUTINE GetMacInfo
END MODULE MAC

F2py default argument

I want to build a function with default arguments. However, any of the following simple methods fail to compile with F2PY printing the following simple and no-informing error message "error: f2py target file '/tmp/....' not generated".
1st using optional
module a
contains
integer function func(j)
implicit none
integer, optional :: j
if(present(j)) then
func = j
else
func = 0
endif
end function
end module
The other is function overloading using interface
module test
interface func
module procedure :: func0, func1
end interface
contains
integer function func0()
implicit none
func0 = 0
end function
integer function func1(j)
implicit none
integer, intent(in) :: j
func1 = j
end function
end module
Appreciate your help.
You can initialize the expression using the F2PY directive.
integer function func(j)
implicit none
integer :: j
!f2py integer :: j = 0
func = j
end function

A value sended by host not return correctly by device using CUDA Fortran

I took an example of data transfer between Host and Device for CUDA Fortran and found this:
Host Code:
program incTest
use cudafor
use simpleOps_m
implicit none
integer, parameter :: n = 256
integer :: a(n), b, i
integer, device :: a_d(n)
a = 1
b = 3
a_d = a
call inc<<<1,n>>>(a_d, b)
a = a_d
if (all(a == 4)) then
write(*,*) 'Success'
endif
end program incTest
Device Code:
module simpleOps_m
contains
attributes(global) subroutine inc(a, b)
implicit none
integer :: a(:)
integer, value :: b
integer :: i
i = threadIdx%x
a(i) = a(i)+b
end subroutine inc
end module simpleOps_m
The expected outcome is the console presenting "Success", but this did not happen. Nothing appears in the screen, nothing errors or messages.
This happen because don't enter in if, because a_d has the same value that before call inc subroutine.
I'm using:
OS: Linux - Ubuntu 16
Cuda 8
PGI to compile
Commands to compile:
pgf90 -Mcuda -c Device.cuf
pgf90 -Mcuda -c Host.cuf
pgf90 -Mcuda -o HostDevice Device.o Host.o
./HostDevice
I tried other examples and they did not work too.
I tried using simple Fortran (.f90) code with the same commands to compile and it works!
How can I fix this problem?
What type of device are you using? (If you don't know, post the output from the "pgaccelinfo" utility).
My best guess is that you have a Pascal based device in which case you need to compile with "-Mcuda=cc60".
For example, if I add error checking to the example code, we see that we get an invalid device kernel error when running on a Pascal without the "cc60" as part of the compilation.
% cat test.cuf
module simpleOps_m
contains
attributes(global) subroutine inc(a, b)
implicit none
integer :: a(:)
integer, value :: b
integer :: i
i = threadIdx%x
a(i) = a(i)+b
end subroutine inc
end module simpleOps_m
program incTest
use cudafor
use simpleOps_m
implicit none
integer, parameter :: n = 256
integer :: a(n), b, i, istat
integer, device :: a_d(n)
a = 1
b = 3
a_d = a
call inc<<<1,n>>>(a_d, b)
istat=cudaDeviceSynchronize()
istat=cudaGetLastError()
a = a_d
if (all(a == 4)) then
write(*,*) 'Success'
else
write(*,*) 'Error code:', cudaGetErrorString(istat)
endif
end program incTest
% pgf90 test.cuf -Mcuda
% a.out
Error code:
invalid device function
% pgf90 test.cuf -Mcuda=cc60
% a.out
Success

generating random numbers in a Fortran Module

Now I am facing the problem that in a module, with a seed I am generating random numbers to be used in a loop of a function but each time I call that function, the same random numbers are generated (because the seed is obviously the same) but it's supposed that it must continue the series or at least it must be different between calls. One solution could be that the main program gives a new seed to be used in the module but I think it there could be another elegant solution.
I am using Mersenne Twister generator by suggestion of many people.
Added
My function in my module (it is a package of functions) escentially makes such a Metropolis test using random numbers generated by a seed, for some reason compilation complains if I put
module mymod
uses mtmod
call sgrnd(4357)!<-- this line causes compilation error
contains
myfunc(args)
implicit none
// declarations etc
!call sgrnd(4357) <-- if I put this call here compilator says ok,
!but re-start random number series each time this function is called :(
....
!the following part is inside a loop
if (prob < grnd()) then
!grnd() is random number generated
return
else continue testing to the end of the loop cycle
end myfunc
But if I put that function in the contains of the main program (using mtmod too) and call sgrnd(4357) before contains section and the calls to myfunc, now everything compile and run nicely. For clarity, I didn't want to put that long function in the main program, it has 70 lines of code, but it seems I have no escape. Notice that so, the seed is once called. The simulations have now physical meanings but with that price payed.
I always used this subroutine (I'm running a MonteCarlo simulation), call it in the beginning of your main program and tis should do the job:
(Source: gfortran 4.6.1)
c initialize a random seed from the system clock at every run (fortran 95 code)
subroutine init_random_seed()
INTEGER :: i, n, clock
INTEGER, DIMENSION(:), ALLOCATABLE :: seed
CALL RANDOM_SEED(size = n)
ALLOCATE(seed(n))
CALL SYSTEM_CLOCK(COUNT=clock)
seed = clock + 37 * (/ (i - 1, i = 1, n) /)
CALL RANDOM_SEED(PUT = seed)
DEALLOCATE(seed)
end
You can find here a subroutine that uses system time to re-seed the random number generator. You shouldn't have to do this every time you call random_number(), just each time you re-start the program.
Honestly, it didn't take me more than ten minutes to find this with Google.
In order to recover my points taken, I was obliged to find my own answer, here it is (after one hour of tries)
main program is
program callrtmod
use mymod
implicit none
real::x
x=1.0
write(*,*) x+writerandnum()
write(*,*) x+writerandnum()
write(*,*) x+writerandnum()
end program callrtmod
here's my module
module mymod
implicit none
!-------------mt variables-------------
! Default seed
integer, parameter :: defaultsd = 4357
! Period parameters
integer, parameter :: N = 624, N1 = N + 1
! the array for the state vector
integer, save, dimension(0:N-1) :: mt
integer, save :: mti = N1
!--------------------------------------
contains
function writerandnum
implicit none
real(8)::writerandnum
writerandnum = grnd()
!if you please, you could perform a Metropolis test here too
end function writerandnum
!Initialization subroutine
subroutine sgrnd(seed)
implicit none
integer, intent(in) :: seed
mt(0) = iand(seed,-1)
do mti=1,N-1
mt(mti) = iand(69069 * mt(mti-1),-1)
enddo
!
return
end subroutine sgrnd
!---------------------------------------------------------------------------
!the function grnd was here
!---------------------------------------------------------------------------
subroutine mtsavef( fname, forma )
character(*), intent(in) :: fname
character, intent(in) :: forma
select case (forma)
case('u','U')
open(unit=10,file=trim(fname),status='UNKNOWN',form='UNFORMATTED', &
position='APPEND')
write(10)mti
write(10)mt
case default
open(unit=10,file=trim(fname),status='UNKNOWN',form='FORMATTED', &
position='APPEND')
write(10,*)mti
write(10,*)mt
end select
close(10)
return
end subroutine mtsavef
subroutine mtsaveu( unum, forma )
integer, intent(in) :: unum
character, intent(in) :: forma
select case (forma)
case('u','U')
write(unum)mti
write(unum)mt
case default
write(unum,*)mti
write(unum,*)mt
end select
return
end subroutine mtsaveu
subroutine mtgetf( fname, forma )
character(*), intent(in) :: fname
character, intent(in) :: forma
select case (forma)
case('u','U')
open(unit=10,file=trim(fname),status='OLD',form='UNFORMATTED')
read(10)mti
read(10)mt
case default
open(unit=10,file=trim(fname),status='OLD',form='FORMATTED')
read(10,*)mti
read(10,*)mt
end select
close(10)
return
end subroutine mtgetf
subroutine mtgetu( unum, forma )
integer, intent(in) :: unum
character, intent(in) :: forma
select case (forma)
case('u','U')
read(unum)mti
read(unum)mt
case default
read(unum,*)mti
read(unum,*)mt
end select
return
end subroutine mtgetu
!===============================================
!Random number generator
! real(8) function grnd()
function grnd !agregue yo
implicit integer(a-z)
real(8) grnd !agregue yo
! Period parameters
integer, parameter :: M = 397, MATA = -1727483681
! constant vector a
integer, parameter :: LMASK = 2147483647
! least significant r bits
integer, parameter :: UMASK = -LMASK - 1
! most significant w-r bits
! Tempering parameters
integer, parameter :: TMASKB= -1658038656, TMASKC= -272236544
dimension mag01(0:1)
data mag01/0, MATA/
save mag01
! mag01(x) = x * MATA for x=0,1
TSHFTU(y)=ishft(y,-11)
TSHFTS(y)=ishft(y,7)
TSHFTT(y)=ishft(y,15)
TSHFTL(y)=ishft(y,-18)
if(mti.ge.N) then
! generate N words at one time
if(mti.eq.N+1) then
! if sgrnd() has not been called,
call sgrnd( defaultsd )
! a default initial seed is used
endif
do kk=0,N-M-1
y=ior(iand(mt(kk),UMASK),iand(mt(kk+1),LMASK))
mt(kk)=ieor(ieor(mt(kk+M),ishft(y,-1)),mag01(iand(y,1)))
enddo
do kk=N-M,N-2
y=ior(iand(mt(kk),UMASK),iand(mt(kk+1),LMASK))
mt(kk)=ieor(ieor(mt(kk+(M-N)),ishft(y,-1)),mag01(iand(y,1)))
enddo
y=ior(iand(mt(N-1),UMASK),iand(mt(0),LMASK))
mt(N-1)=ieor(ieor(mt(M-1),ishft(y,-1)),mag01(iand(y,1)))
mti = 0
endif
y=mt(mti)
mti = mti + 1
y=ieor(y,TSHFTU(y))
y=ieor(y,iand(TSHFTS(y),TMASKB))
y=ieor(y,iand(TSHFTT(y),TMASKC))
y=ieor(y,TSHFTL(y))
if(y .lt. 0) then
grnd=(dble(y)+2.0d0**32)/(2.0d0**32-1.0d0)
else
grnd=dble(y)/(2.0d0**32-1.0d0)
endif
return
end function grnd
end module mymod
test my solution and vote me up ;) [of course, as you see, I modified mt.f90 code to be included conveniently in my module, so I can keep separately the main program from the randon numbers generation part, so I can do a Metropolis test aside the main program. The main program just wants to know if a trial was accepted or not. My solution does give more clarity to the main progam]

Resources