gcc/testsuite/gfortran.dg/coarray/lock_2.f90

   1 ! { dg-do run }
   2 !
   3 ! LOCK/UNLOCK check
   4 !
   5 ! PR fortran/18918
   6 !
   7
   8 use iso_fortran_env
   9 implicit none
  10
  11 type(lock_type), allocatable :: lock1[:]
  12 type(lock_type), allocatable :: lock2(:,:)[:]
  13 type(lock_type) :: lock3(4)[*]
  14 integer :: stat
  15 logical :: acquired
  16
  17 allocate(lock1[*])
  18 allocate(lock2(2,2)[*])
  19
  20 LOCK(lock1)
  21 UNLOCK(lock1)
  22
  23 LOCK(lock2(1,1))
  24 LOCK(lock2(2,2))
  25 UNLOCK(lock2(1,1))
  26 UNLOCK(lock2(2,2))
  27
  28 LOCK(lock3(3))
  29 LOCK(lock3(4))
  30 UNLOCK(lock3(3))
  31 UNLOCK(lock3(4))
  32
  33 stat = 99
  34 LOCK(lock1, stat=stat)
  35 if (stat /= 0) call abort()
  36
  37 LOCK(lock2(1,1), stat=stat)
  38 if (stat /= 0) call abort()
  39 LOCK(lock2(2,2), stat=stat)
  40 if (stat /= 0) call abort()
  41
  42 LOCK(lock3(3), stat=stat)
  43 if (stat /= 0) call abort()
  44 LOCK(lock3(4), stat=stat)
  45 if (stat /= 0) call abort()
  46
  47 stat = 99
  48 UNLOCK(lock1, stat=stat)
  49 if (stat /= 0) call abort()
  50
  51 UNLOCK(lock2(1,1), stat=stat)
  52 if (stat /= 0) call abort()
  53 UNLOCK(lock2(2,2), stat=stat)
  54 if (stat /= 0) call abort()
  55
  56 UNLOCK(lock3(3), stat=stat)
  57 if (stat /= 0) call abort()
  58 UNLOCK(lock3(4), stat=stat)
  59 if (stat /= 0) call abort()
  60
  61 if (this_image() == 1) then
  62   acquired = .false.
  63   LOCK (lock1[this_image()], acquired_lock=acquired)
  64   if (.not. acquired) call abort()
  65
  66   acquired = .false.
  67   LOCK (lock2(1,1)[this_image()], acquired_lock=acquired)
  68   if (.not. acquired) call abort()
  69
  70   acquired = .false.
  71   LOCK (lock2(2,2)[this_image()], acquired_lock=acquired)
  72   if (.not. acquired) call abort()
  73
  74   acquired = .false.
  75   LOCK (lock3(3)[this_image()], acquired_lock=acquired)
  76   if (.not. acquired) call abort()
  77
  78   acquired = .false.
  79   LOCK (lock3(4)[this_image()], acquired_lock=acquired)
  80   if (.not. acquired) call abort()
  81
  82   UNLOCK (lock1[1])
  83   UNLOCK (lock2(1,1)[1])
  84   UNLOCK (lock2(2,2)[1])
  85   UNLOCK (lock3(3)[1])
  86   UNLOCK (lock3(4)[1])
  87 end if
  88 end
  89