module arrays
      integer nc,i,iii,j, iswap , irate, icmax, icount2,
     & icount3, icount4, icount5, icount6, icount7, icount8,
     & icount9, icount10, icount11, icount12, icount13,
     & icount14, icount15, icount16, icount17, icount18,
     & icount19, icount20
c
      real rannum, time
      parameter (nc=3000)
      real, target ::  a(nc),b(nc),c(nc)
      real, allocatable ::  aa(:),ab(:),ac(:)
c
      integer ivec(nc)
      real a2(2,nc),b2(2,nc),c2(2,nc)
      real a9(9,nc),b9(9,nc),c9(9,nc)
      real, pointer :: pa(:), pb(:), pc(:), paa(:), pab(:),
     &                 pac(:)
c
      type xdef1
      real xr
      end type xdef1
c
      type (xdef1) xa1(nc), xb1(nc), xc1(nc)
c
      type xdef2
      real xr(nc)
      end type xdef2
c
      type (xdef2) xa2, xb2, xc2
c
      type xdef3
      real xr,yr
      end type xdef3
c
      type (xdef3)  xa3(nc), xb3(nc), xc3(nc)
c
      type xdef4
      real, pointer :: xr
      end type xdef4
c
      type (xdef4) xa4(nc), xb4(nc), xc4(nc) , sa4(nc), sb4(nc), sc4(nc)
c
      type xdef9
      real xr,x2,x3,x4,x5,x6,x7,x8,x9
      end type xdef9
c
      type (xdef9)  xa9(nc), xb9(nc), xc9(nc)
c
      end module
c=========================================================================
      program speed
      use arrays
      implicit none
      integer nloop
      parameter (nloop=3000)
      interface loop14
         subroutine loop14(a,b,c,nc)
         integer, intent(in) :: nc
         real, intent(in) ::  a(:), b(:)
         real, intent(out) :: c(:)
         end
      end interface
      interface loop16
         subroutine loop16 (pa,pb,pc,nc)
         implicit none
         real, pointer :: pa(:), pb(:), pc(:)
         end
      end interface
c
c    program to time several different array calculations
c
c    Use the Fortran 90 Intrinsic Subroutine to load
c    the vectors with random numbers
c
c     call random_number (a)
c     call random_number(b)
      a=.7
      b=.8
      a2=.7
      b2=.8
c
c    Load the defined type arrays and assign pointers
c
      xa1%xr=a
      xb1%xr=b
      xa2%xr=a
      xb2%xr=b
      xa3%xr=a
      xb3%xr=b
      xa9%xr=a
      xb9%xr=b
      pa=> a
      pb=> b
      pc=> c
      do i=1,nc
         xa4(i)%xr => a(i)
         xb4(i)%xr => b(i)
         xc4(i)%xr => c(i)
         ivec(i)=i
      enddo
c
c   Assign random order in the indirect indices.
c
      do i=1,nc
         call random_number(rannum)
         j= nint(real((nc-1)*rannum)) + 1
         iswap=ivec(i)
         ivec(i)=ivec(j)
         ivec(j)=iswap
      enddo
c
      do i=1,nc
         sa4(i)%xr => a(ivec(i))
         sb4(i)%xr => b(ivec(i))
         sc4(i)%xr => c(i)
      enddo
      allocate(aa(nc),ab(nc),ac(nc))
      allocate(paa(nc),pab(nc),pac(nc))
      aa=a
      ab=b
c
c     print *, a(1), xa4(1)%xr
c
c    Use the Fortran 90 Intrinsic Subroutine to determine
c    the current time in clock ticks (icount2), the clock
c    rate in clicks per second, and the largest possible
c    count before the clock resets.
c
c    CAUTION:  On this and probably most Unix work stations
c    this clock is measuring real time, not time your program
c    spends running.  If you are sharing the machine with others
c    you will count the time they have the CPU also.  USE the
c    unix "users" command to check for a situation when you are
c    the only user on the machine before running the program.
c    To filter out system activity run the program many times
c    and select results with the lowest total times.
c
c     call system_clock(icount2,irate,icmax)
c
c     The product of the array dimension "nc" and the number
c     of calls to each subroutine "nloop" is very large so
c     that I get good statistics. "nc" is itself large enough
c     that the relative cost of calling the subroutine is
c     insignificant.
c
c     print *, 'clock rate = ',irate, ' ticks per second'
c
      do 1999 iii=1,4
      call system_clock(icount2,irate,icmax)
      do i = 1,nloop
         call loop1
      enddo
      call system_clock(icount3,irate,icmax)
      do i = 1,nloop
         call loop2
      enddo
      call system_clock(icount4,irate,icmax)
      do i = 1,nloop
         call loop3
      enddo
      call system_clock(icount5,irate,icmax)
      do i = 1,nloop
         call loop4
      enddo
      call system_clock(icount6,irate,icmax)
      do i = 1,nloop
         call loop5
      enddo
      call system_clock(icount7,irate,icmax)
      do i = 1,nloop
         call loop6
      enddo
      call system_clock(icount8,irate,icmax)
      do i = 1,nloop
         call loop7
      enddo
      call system_clock(icount9,irate,icmax)
      do i = 1,nloop
         call loop8
      enddo
      call system_clock(icount10,irate,icmax)
      do i = 1,nloop
         call loop9
      enddo
      call system_clock(icount11,irate,icmax)
      do i = 1,nloop
         call loop10
      enddo
      call system_clock(icount12,irate,icmax)
      do i = 1,nloop
         call loop11
      enddo
      call system_clock(icount13,irate,icmax)
      do i = 1,nloop
         call loop12
      enddo
      call system_clock(icount14,irate,icmax)
      do i = 1,nloop
         call loop13(a,b,c,nc)
      enddo
      call system_clock(icount15,irate,icmax)
      do i = 1,nloop
         call loop13(pa,pb,pc,nc)
      enddo
      call system_clock(icount16,irate,icmax)
      do i = 1,nloop
         call loop13(aa,ab,ac,nc)
      enddo
      call system_clock(icount17,irate,icmax)
      do i = 1,nloop
         call loop14(a,b,c,nc)
      enddo
      call system_clock(icount18,irate,icmax)
      do i = 1,nloop
         call loop15
      enddo
      call system_clock(icount19,irate,icmax)
      do i = 1,nloop
         call loop16 (pa,pb,pc,nc)
      enddo
      call system_clock(icount20,irate,icmax)
      do i = 1,nloop
         call empty(a,b,c,nc)
      enddo
      call system_clock(icount21,irate,icmax)
      print *, 'Result of element by element multiplication of 2 arrays'
      time = real(icount3-icount2)/real(irate)
      print *, 'Normal arrays = ', time,
     $ ' seconds'
      time = real(icount8-icount7)/real(irate)
      print *, ' (2,nc) arrays = ', time,
     $ ' seconds'
      time = real(icount9-icount8)/real(irate)
      print *, ' (9,nc) arrays = ', time,
     $ ' seconds'
      time = real(icount4-icount3)/real(irate)
      print *, 'Array of defined type with 1 struct. var= ', time,
     $ ' seconds'
      time = real(icount6-icount5)/real(irate)
      print *, 'Array of defined type with 2 struct. var= ', time,
     $ ' seconds'
      time = real(icount10-icount9)/real(irate)
      print *, 'Array of defined type with 9 struct. var= ', time,
     $ ' seconds'
      time = real(icount5-icount4)/real(irate)
      print *, 'Defined type containing xr(nc) = ', time,
     $ ' seconds'
      time = real(icount7-icount6)/real(irate)
      print *, 'Array of Defined type with 1 pointer = ', time,
     $ ' seconds'
      time = real(icount11-icount10)/real(irate)
      print *, 'Normal pointer to basic arrays = ', time,
     $ ' seconds'
      time = real(icount12-icount11)/real(irate)
      print *, 'Arrays with random vector subscript = ', time,
     $ ' seconds'
      time = real(icount13-icount12)/real(irate)
      print *, 'Above with Defined array of pointers = ', time,
     $ ' seconds'
      time = real(icount14-icount13)/real(irate)
      print *, 'Allocated arrays = ', time,
     $ ' seconds'
      time = real(icount19-icount18)/real(irate)
      print *, 'Allocated pointers = ', time,
     $ ' seconds'
      time = real(icount15-icount14)/real(irate)
      print *, 'Arrays in argument list = ', time,
     $ ' seconds'
      time = real(icount16-icount15)/real(irate)
      print *, 'Pointers in argument list without interface = ',
     $ time,' seconds'
      time = real(icount20-icount19)/real(irate)
      print *, 'Pointers in argument list with interface = ',
     $ time,' seconds'
      time = real(icount17-icount16)/real(irate)
      print *, 'Allocated Arrays in argument list = ', time,
     $ ' seconds'
      time = real(icount18-icount17)/real(irate)
      print *, 'Arrays in argument list with Interface = ', time,
     $ ' seconds'
      time = real(icount21-icount20)/real(irate)
      print *, 'Empty Subroutine with above arguments = ', time,
     $ ' seconds'
      write(*,*)'-----------------------------------------------'
 1999 continue
      print *, c(nc),xc1(nc)%xr,xc2%xr(nc)
      print *, xc3(nc)%xr, xc4(nc)%xr
      stop
      end
c
      subroutine loop1
      use arrays
      implicit none
c
         c(1:nc) = a(1:nc)*b(1:nc)
      end
      subroutine loop2
c
      use arrays
      implicit none
c
         xc1(1:nc)%xr=xa1(1:nc)%xr*xb1(1:nc)%xr
      end
      subroutine loop3
      use arrays
      implicit none
c
         xc2%xr(1:nc)=xa2%xr(1:nc)*xb2%xr(1:nc)
      end
      subroutine loop4
      use arrays
      implicit none
c
         xc3(1:nc)%xr=xa3(1:nc)%xr*xb3(1:nc)%xr
      end
      subroutine loop5
      use arrays
      implicit none
c
c        xc4(1:nc)%xr=xa4(1:nc)%xr*xb4(1:nc)%xr
         do  j=1,nc
            xc4(j)%xr=xa4(j)%xr*xb4(j)%xr
         enddo
      end
      subroutine loop6
      use arrays
      implicit none
c
         c2(1,1:nc) = a2(1,1:nc)*b2(1,1:nc)
      end
      subroutine loop7
      use arrays
      implicit none
c
         c9(1,1:nc) = a9(1,1:nc)*b9(1,1:nc)
      end
      subroutine loop8
      use arrays
      implicit none
c
         xc9(1:nc)%xr=xa9(1:nc)%xr*xb9(1:nc)%xr
      end
      subroutine loop9
      use arrays
      implicit none
c
         pc(1:nc) = pa(1:nc)*pb(1:nc)
      end
      subroutine loop10
      use arrays
      implicit none
c
         c(1:nc) = a(ivec(1:nc))*b(ivec(1:nc))
      end
      subroutine loop11
      use arrays
      implicit none
c
      do j = 1,nc
         sc4(j)%xr=sa4(j)%xr*sb4(j)%xr
      enddo
      end
c
      subroutine loop12
      use arrays
      implicit none
c
         ac(1:nc) = aa(1:nc)*ab(1:nc)
      end
      subroutine loop13(a,b,c,nc)
      implicit none
      integer nc
      real a(nc),b(nc),c(nc)
c
         c(1:nc) = a(1:nc)*b(1:nc)
      end
c
      subroutine loop14(a,b,c,nc)
      implicit none
      integer, intent(in) :: nc
      real, intent(in) ::  a(:), b(:)
      real, intent(out) :: c(:)
c
         c(1:nc) = a(1:nc)*b(1:nc)
      end
c
      subroutine loop15
      use arrays
      implicit none
c
         pac(1:nc) = paa(1:nc)*pab(1:nc)
      end
c
      subroutine loop16 (pa,pb,pc,nc)
      implicit none
      real, pointer, intent(in) :: pa(:), pb(:)
      real, pointer, intent(out) :: pc(:)
      integer, intent(in) nc
c
         pc(1:nc) = pa(1:nc)*pb(1:nc)
      end
      subroutine empty(a,b,c,nc)
      implicit none
      integer nc
      real a(nc),b(nc),c(nc)
c
c        c(1:nc) = a(1:nc)*b(1:nc)
      end