!===== Version Fortran 95 en format libre : IDRIS 10/01/2002
module acom_m 
      real(kind=4) :: aa, bb 
end module acom_m 

module mes_proc
CONTAINS 
   subroutine sp1(inc, tab, ctl, coef) 
!-----------------------------------------------
!   M o d u l e s 
!-----------------------------------------------
      USE acom_m
      implicit none
!-----------------------------------------------
!   D u m m y   A r g u m e n t s
!-----------------------------------------------
      integer ,      intent(inout) :: ctl 
      real(kind=4) , intent(in)    :: inc , tab(:,:) 
      real(kind=4) , intent(out)   :: coef
!-----------------------------------------------
!   L o c a l   V a r i a b l e s
!-----------------------------------------------
      real(kind=4)    :: s 
!-----------------------------------------------
      s = real(ctl) + sum(tab(:, 1)) 
      if (s > 0.) ctl = 99 
      coef = inc + aa + bb / 2. 
      return  
   end subroutine sp1 
end module mes_proc

program prog 
USE acom_m ; USE mes_proc
    implicit none
!-----------------------------------------------
!   L o c a l   P a r a m e t e r s
!-----------------------------------------------
      integer, parameter :: n  = 8 
      integer, parameter :: m  = n + 2 
      integer, parameter :: l1 = n / 2 
      integer, parameter :: l2 = m / 2 
!-----------------------------------------------
!   L o c a l   V a r i a b l e s
!-----------------------------------------------
      integer                            :: j1, j2, ctl, i, j, k
      real(kind=4), dimension(n,m)       :: a
      real(kind=4), dimension(m,m)       :: b, c
      real(kind=4), dimension(l1,l2,m,n) :: br 
      real(kind=4), dimension(n,l2,l1)   :: ar 
      real(kind=4), dimension(n)         :: ra, rb, rd, re 
      real(kind=4)                       :: y, z, x, t, s, xout 
!
!-- Lecture des données dans le fichier "data_prog"
      write (unit = 6, fmt = 123) 
      open(unit = 10, file = 'data_prog', action = 'READ', &
           access = 'sequential', form = 'unformatted') 
      read (unit = 10) b
      read (unit = 10) c
      read (unit = 10) br, ar
      read (unit = 10) ra, rb, rd, re 
      y = b(2, 1) 
!
!-- IF arithmétique ==> Blocs IF THEN -----
      z = y * 2. 
      if (y >= 0.) then 
         if (y <= 0.) then 
            x = 0. 
         else 
            x = 1. 
         endif 
         y = y + z 
      endif 
      print *, 'X=', x, ' Y=', y 
!
!-- GO TO ==>  Blocs IF THEN -----
      t = x + y 
      if (x <= y) then 
         s = sqrt(t) 
      else 
         s = exp(t) 
      endif 
      print *, 'S=', s 
!
!-- Appel sous programme avec COMMON ==> Module -------
      aa  = 2. 
      bb  = 3. 
      ctl = 0 
      call sp1 (inc=t, tab=b, ctl=ctl, coef=xout) 
      print *, 'sp1 : ctl=', ctl, ' xout=', xout
!
!--- Boucles avec GO TO ==> Boucles avec CYCLE/EXIT --
      l233: do j = 1, m 
         do i = 1, n 
            a(i, j) = b(i, j) - 10. 
            if (b(i, j) <  0.) cycle  
            if (a(i, j) == 0.) exit  l233 
            b(i, j) = 2. 
         end do 
      end do l233 
      print *, 'B(2,2)=', b(2, 2), ' B(N,M)=', b(n, m) 
!
!--- GO TO calculé ==> SELECT CASE --------------------
      if (i > 100) i = 0 
      select case (i)  
      case default 
         b(i, 1) = 2. 
      case (1:2)  
         x = 1. 
      case (3)  
         x = 2. 
      end select 
      print *, 'Select case : X=', x 
!
!--- Opérations tableaux -----------------------------
!
!-- Initialisation globale
      c(:m, :m) = 3.14 
!
!--- Initialisation globale avec transposée
      a(:n, :n) = transpose(2.0 * b(:n, :n)) 
      print *, 'A(2,2)=', a(2, 2), ' A(N,N)=', a(n, n) 
!
!--- Sommation ==> SUM
      s = sum(a(:n, :n)+b(:n, :n)) 
      print *, 'S=', s 
!
!--- Boucle + IF ==> Réduction via SUM + MINVAL + COUNT
      s = s + sum(rb(:n), mask=ra(:n) > 0) 
      x = min(x, minval(re(:n), mask=rb(:n) >= rd(:n))) 
      k = count(ra(:n) > rb(:n)) 
      print *, 'S=', s, ' K=', k 
!--- Quadruple boucle imbriquée ==> RESHAPE + SPREAD
      br(:l1, :l2, :m, :n) = spread(reshape(source = ar(:n, :l2, :l1), &
                                            shape  = (/l1,l2, n/),     &
                                            order  = (/3,2, 1/) ),     &
                                    dim = 3, ncopies = m) 
      print *, 'BR(1,1,1,1)=', br(1, 1, 1, 1) 
!
!--- Réduction double boucle ==> SPREAD + (/ ... /)
      b(:n, :n) = c(:n, :n) + real(  spread( (/(j1,j1=1,n)/), dim = 2, &
                                             ncopies = n)              &
                                   + spread( (/(j2,j2=1,n)/), dim = 1, &
                                             ncopies = n) ) 
      print *, 'B(2,2)=', b(2,2), ' B(N,N)=', b(n, n) 
!
!--- Multiplication de matrices ==> MATMUL
      a(:n, :m) = 1.0 + matmul(transpose(b(:m, :n)), c(:m, :m)) 
      print *, 'MATMUL : A(1,1)=', a(1, 1), ' A(N,M)=', a(n, m), &
                       ' A(2,2)=', A(2, 2), ' A(2,3)=', A(2, 3) 
  123 format('Prog_conv : lecture des données')
!  
end program prog