OpenCores
URL https://opencores.org/ocsvn/openrisc_me/openrisc_me/trunk

Subversion Repositories openrisc_me

[/] [openrisc/] [trunk/] [gnu-src/] [gcc-4.5.1/] [gcc/] [testsuite/] [gfortran.fortran-torture/] [execute/] [common.f90] - Blame information for rev 303

Details | Compare with Previous | View Log

Line No. Rev Author Line
1 303 jeremybenn
! Program to test COMMON and EQUIVALENCE.
2
program common
3
   real (kind=8) a(8)
4
   real (kind=8) b(5), c(5)
5
   common /com1/b,c
6
   equivalence (a(1), b(2))
7
   b = 100
8
   c = 200
9
   call common_pass
10
   call common_par (a, b,c)
11
   call global_equiv
12
   call local_equiv
13
end
14
 
15
! Use common block to pass values
16
subroutine common_pass
17
   real (kind=8) a(8)
18
   real (kind=8) b(5), c(5)
19
   common /com1/b,c
20
   equivalence (a(1), b(2))
21
   if (any (a .ne. (/100,100,100,100,200,200,200,200/))) call abort
22
end subroutine
23
 
24
! Common variables as argument
25
subroutine common_par (a, b, c)
26
   real (kind=8) a(8), b(5), c(5)
27
   if (any (a .ne. (/100,100,100,100,200,200,200,200/))) call abort
28
   if (any (b .ne. (/100,100,100,100,100/))) call abort
29
   if (any (c .ne. (/200,200,200,200,200/))) call abort
30
end subroutine
31
 
32
! Global equivalence
33
subroutine global_equiv
34
   real (kind=8) a(8), b(5), c(5), x(8), y(4), z(4)
35
   common /com2/b, c, y, z
36
   equivalence (a(1), b(2))
37
   equivalence (x(4), y(1))
38
   b = 100
39
   c = 200
40
   y = 300
41
   z = 400
42
   if (any (a .ne. (/100,100,100,100,200,200,200,200/))) call abort
43
   if (any (x .ne. (/200,200,200,300,300,300,300,400/))) call abort
44
end
45
 
46
! Local equivalence
47
subroutine local_equiv
48
  real (kind=8) a(8), b(10)
49
  equivalence (a(1), b(3))
50
  b(1:5) = 100
51
  b(6:10) = 200
52
  if (any (a .ne. (/100,100,100,200,200,200,200,200/))) call abort
53
end subroutine

powered by: WebSVN 2.1.0

© copyright 1999-2024 OpenCores.org, equivalent to Oliscience, all rights reserved. OpenCores®, registered trademark.