c-----------------------------------------------------------
c     Demonstration main program, subroutines and functions
c     to illustrate argument passing (call by address) in
c     Fortran.
c-----------------------------------------------------------
      program         tsub

      real*8          r8side

      integer         n 
      parameter     ( n = 6 )
      real*8          v1(n),         v2(n),        v3(n)   
      real*8          a,             b,            c

      a = -1.0d0 
      b =  1.0d0 
      write(*,*) 'Pre r8swap: a = ', a, ' b = ', b
      call r8swap(a,b)
      write(*,*) 'Post r8swap: a = ', a, ' b = ', b
      call prompt('Through r8swap')

      a = 10.0d0
      b = r8side(a)
      write(*,*) 'Post r8side: a = ', a, ' b = ', b
      call prompt('Through r8side')

c-----------------------------------------------------------
c     Load 'v1' with 0.0d0
c-----------------------------------------------------------
      call dvloadsc(v1,n,0.0d0)
      call dvstderr('v1 loaded with 0.0',v1,n)
      call prompt('Through dvloadsc')

c-----------------------------------------------------------
c     'v1' and 'v1(1)' have the SAME ADDRESS and thus 
c     this call to 'dvloadsc' has precisely the same effect 
c     as the previous one.
c-----------------------------------------------------------
      call dvloadsc(v1(1),n,0.0d0)
      call dvstderr('v1 loaded with 0.0',v1,n)
      call prompt('Through dvloadsc (second time)')

c-----------------------------------------------------------
c     Load v(2:n-1) with 1.0d0, values 'v(1)' and 'v(n)'
c     are unchanged
c-----------------------------------------------------------
      call dvloadsc(v1(2),n-2,1.0d0)
      call dvstderr('v1 loaded with 0.0 and 1.0',v1,n)
      call prompt('Through dvloadsc (third time)')

c-----------------------------------------------------------
c     Is is actually a violation of strict F77 to pass 
c     the same address more than once to a subroutine 
c     or argument, but in many cases, such as this one 
c     it is perfectly safe.  This sequence uses the 
c     routine 'dvaddsc' to increment each value of 'v1'
c     by 2.0d0.
c-----------------------------------------------------------
      call dvaddsc(v1,v1,n,2.0d0)
      call dvstderr('v1 incremented by 2.0',v1,n)
      call prompt('Through dvaddsc')

      call prompt('Through tsub')

      stop
      end

c-----------------------------------------------------------
c     This routine swaps its two real*8 arguments
c-----------------------------------------------------------
      subroutine  r8swap(val1,val2)
         
         implicit     none

         real*8       val1,      val2
         real*8       temp

         temp = val1 
         val1 = val2
         val2 = temp
         
         return

      end

c-----------------------------------------------------------
c     Real*8 function 'r8side' which has the 'side effect' 
c     of overwriting its argument with 0.0d0.  As a general
c     matter of style, Fortran FUNCTION subprograms should 
c     act like real functions (i.e. NO side-effects) where
c     possible.  
c
c     Also note that the name of a Fortran 
c     function is treated as a local variable in the 
c     subprogram source code and MUST be assigned a value 
c     before any 'return' statements are encountered.
c-----------------------------------------------------------
      real*8 function r8side(x)

         implicit     none

         real*8       x
       
         r8side = x * x * x
         x = 0.0d0

         return

      end

c-----------------------------------------------------------
c     Loads output real*8 vector 'v' with input scalar 
c     value 'sc'.
c-----------------------------------------------------------
      subroutine dvloadsc(v,n,sc)

         implicit      none
         
         integer       n
         real*8        v(n)
         real*8        sc

         integer       i
            
         do i = 1 , n
            v(i) = sc
         end do

         return

      end

c-----------------------------------------------------------
c     Adds real*8 scalar to input real*8 vector 'v1',
c     and returns results in output real*8 vector 'v2'
c-----------------------------------------------------------
      subroutine dvaddsc(v1,v2,n,sc)

         implicit      none

         integer       n
         real*8        v1(n),      v2(n)
         real*8        sc

         integer       i
         
         do i = 1 , n
            v2(i) = v1(i) + sc
         end do

         return

      end

c-----------------------------------------------------------
c     Dumps 'string' the real*8 vector 'v' to standard error
c-----------------------------------------------------------
      subroutine dvstderr(string,v,n)
      
         implicit       none

         character*(*)  string
         integer        n
         real*8         v(n)
      
         integer        i

         write(0,*) string
         do i = 1 , n
            write(*,*) v(i)
         end do

         return

      end

c-----------------------------------------------------------
c     Prints a message on stdout and then waits for input
c     from stdin.
c-----------------------------------------------------------
      subroutine prompt(pstring)

         implicit      none

         character*(*) pstring
         integer       rc
         character*1   resp

         write(*,*) pstring
         write(*,*) 'Enter anything & <CR> to continue'
         read(*,*,iostat=rc,end=900)  resp
         return

 900     continue
         stop
      end