gcc/testsuite/gfortran.fortran-torture/execute/common.f90

   1 ! 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