gcc/testsuite/gfortran.dg/findloc_6.f90

   1 ! { dg-do run }
   2 ! Test different code paths for findloc with scalar result.
   3
   4 program main
   5   integer, dimension(0:5) :: a = [1,2,3,1,2,3]
   6   logical, dimension(6) :: mask = [.false.,.false.,.false.,.true.,.true.,.true.]
   7   logical, dimension(6) :: mask2
   8   logical :: true, false
   9   character(len=2), dimension(6) :: ch = ["AA", "BB", "CC", "AA", "BB", "CC"]
  10
  11   true = .true.
  12   false = .false.
  13   mask2 = .not. mask
  14
  15 ! Tests without mask
  16
  17   if (findloc(a,2,dim=1,back=false) /= 2) stop 1
  18   if (findloc(a,2,dim=1,back=.false.) /= 2) stop 2
  19   if (findloc(a,2,dim=1) /= 2) stop 3
  20   if (findloc(a,2,dim=1,back=.true.) /= 5) stop 4
  21   if (findloc(a,2,dim=1,back=true) /= 5) stop 5
  22
  23 ! Test with array mask
  24   if (findloc(a,2,dim=1,mask=mask) /= 5) stop 6
  25   if (findloc(a,2,dim=1,mask=mask,back=.true.) /= 5) stop 7
  26   if (findloc(a,2,dim=1,mask=mask,back=.false.) /= 5) stop 8
  27   if (findloc(a,2,dim=1,mask=mask2) /= 2) stop 9
  28   if (findloc(a,2,dim=1,mask=mask2,back=.true.) /= 2) stop 10
  29   if (findloc(a,2,dim=1,mask=mask2,back=true) /= 2) stop 11
  30
  31 ! Test with scalar mask
  32
  33   if (findloc(a,2,dim=1,mask=.true.) /= 2) stop 12
  34   if (findloc(a,2,dim=1,mask=.false.) /= 0) stop 13
  35   if (findloc(a,2,dim=1,mask=true) /= 2) stop 14
  36   if (findloc(a,2,dim=1,mask=false) /= 0) stop 15
  37
  38 ! Some character tests
  39
  40   if (findloc(ch,"AA",dim=1) /= 1) stop 16
  41   if (findloc(ch,"AA",dim=1,mask=mask) /= 4) stop 17
  42   if (findloc(ch,"AA",dim=1,back=.true.) /= 4) stop 18
  43   if (findloc(ch,"AA",dim=1,mask=mask2,back=.true.) /= 1) stop 19
  44
  45 ! Nothing to be found here...
  46   if (findloc(ch,"DD",dim=1) /= 0) stop 20
  47   if (findloc(a,4,dim=1) /= 0) stop 21
  48
  49 ! Finally, character tests with a scalar mask.
  50
  51   if (findloc(ch,"CC ",dim=1,mask=true) /= 3) stop 22
  52   if (findloc(ch,"CC ",dim=1,mask=false) /= 0) stop 23
  53 end program main