c  f90-intrinsic-bit.f
c
c Test Fortran 90
c  * intrinsic bit manipulation functions - Section 13.10.10
c  * bitcopy subroutine - Section 13.9.3
c David Billinghurst <David.Billinghurst@riotinto.com>
c
c Notes:
c  * g77 only supports scalar arguments
c  * third argument of ISHFTC is not optional in g77

      logical fail
      integer   i, i2, ia, i3
      integer*2 j, j2, j3, ja
      integer*1 k, k2, k3, ka
      integer*8 m, m2, m3, ma

      common /flags/ fail
      fail = .false.

c     BIT_SIZE - Section 13.13.16
c     Determine BIT_SIZE by counting the bits
      ia = 0
      i = 0
      i = not(i)
      do while ( (i.ne.0) .and. (ia.lt.127) )
         ia = ia + 1
         i = ishft(i,-1)
      end do
      call c_i(BIT_SIZE(i),ia,'BIT_SIZE(integer)')
      ja = 0
      j = 0
      j = not(j)
      do while  ( (j.ne.0) .and. (ja.lt.127) )
         ja = ja + 1
         j = ishft(j,-1)
      end do
      call c_i2(BIT_SIZE(j),ja,'BIT_SIZE(integer*2)')
      ka = 0
      k = 0
      k = not(k)
      do while ( (k.ne.0) .and. (ka.lt.127) )
         ka = ka + 1
         k = ishft(k,-1)
      end do
      call c_i1(BIT_SIZE(k),ka,'BIT_SIZE(integer*1)')
      ma = 0
      m = 0
      m = not(m)
      do while ( (m.ne.0) .and. (ma.lt.127) )
         ma = ma + 1
         m = ishft(m,-1)
      end do
      call c_i8(BIT_SIZE(m),ma,'BIT_SIZE(integer*8)')

c     BTEST  - Section 13.13.17
      j  = 7
      j2 = 3
      k  = 7
      k2 = 3
      m  = 7
      m2 = 3
      call c_l(BTEST(7,3),.true.,'BTEST(integer,integer)')
      call c_l(BTEST(7,j2),.true.,'BTEST(integer,integer*2)')
      call c_l(BTEST(7,k2),.true.,'BTEST(integer,integer*1)')
      call c_l(BTEST(7,m2),.true.,'BTEST(integer,integer*8)')
      call c_l(BTEST(j,3),.true.,'BTEST(integer*2,integer)')
      call c_l(BTEST(j,j2),.true.,'BTEST(integer*2,integer*2)')
      call c_l(BTEST(j,k2),.true.,'BTEST(integer*2,integer*1)')
      call c_l(BTEST(j,m2),.true.,'BTEST(integer*2,integer*8)')
      call c_l(BTEST(k,3),.true.,'BTEST(integer*1,integer)')
      call c_l(BTEST(k,j2),.true.,'BTEST(integer*1,integer*2)')
      call c_l(BTEST(k,k2),.true.,'BTEST(integer*1,integer*1)')
      call c_l(BTEST(k,m2),.true.,'BTEST(integer*1,integer*8)')
      call c_l(BTEST(m,3),.true.,'BTEST(integer*8,integer)')
      call c_l(BTEST(m,j2),.true.,'BTEST(integer*8,integer*2)')
      call c_l(BTEST(m,k2),.true.,'BTEST(integer*8,integer*1)')
      call c_l(BTEST(m,m2),.true.,'BTEST(integer*8,integer*8)')

c     IAND   - Section 13.13.40
      j  = 3
      j2 = 1
      ja = 1
      k  = 3
      k2 = 1
      ka = 1
      m  = 3
      m2 = 1
      ma = 1
      call c_i(IAND(3,1),1,'IAND(integer,integer)')
      call c_i2(IAND(j,j2),ja,'IAND(integer*2,integer*2)')
      call c_i1(IAND(k,k2),ka,'IAND(integer*1,integer*1)')
      call c_i8(IAND(m,m2),ma,'IAND(integer*8,integer*8)')

c     IBCLR  - Section 13.13.41
      j  = 14
      j2 = 1
      ja = 12
      k  = 14
      k2 = 1
      ka = 12
      m  = 14
      m2 = 1
      ma = 12
      call c_i(IBCLR(14,1),12,'IBCLR(integer,integer)')
      call c_i(IBCLR(14,j2),12,'IBCLR(integer,integer*2)')
      call c_i(IBCLR(14,k2),12,'IBCLR(integer,integer*1)')
      call c_i(IBCLR(14,m2),12,'IBCLR(integer,integer*8)')
      call c_i2(IBCLR(j,1),ja,'IBCLR(integer*2,integer)')
      call c_i2(IBCLR(j,j2),ja,'IBCLR(integer*2,integer*2)')
      call c_i2(IBCLR(j,k2),ja,'IBCLR(integer*2,integer*1)')
      call c_i2(IBCLR(j,m2),ja,'IBCLR(integer*2,integer*8)')
      call c_i1(IBCLR(k,1),ka,'IBCLR(integer*1,integer)')
      call c_i1(IBCLR(k,j2),ka,'IBCLR(integer*1,integer*2)')
      call c_i1(IBCLR(k,k2),ka,'IBCLR(integer*1,integer*1)')
      call c_i1(IBCLR(k,m2),ka,'IBCLR(integer*1,integer*8)')
      call c_i8(IBCLR(m,1),ma,'IBCLR(integer*8,integer)')
      call c_i8(IBCLR(m,j2),ma,'IBCLR(integer*8,integer*2)')
      call c_i8(IBCLR(m,k2),ma,'IBCLR(integer*8,integer*1)')
      call c_i8(IBCLR(m,m2),ma,'IBCLR(integer*8,integer*8)')

c     IBSET  - Section 13.13.43
      j  = 12
      j2 = 1
      ja = 14
      k  = 12
      k2 = 1
      ka = 14
      m  = 12
      m2 = 1
      ma = 14
      call c_i(IBSET(12,1),14,'IBSET(integer,integer)')
      call c_i(IBSET(12,j2),14,'IBSET(integer,integer*2)')
      call c_i(IBSET(12,k2),14,'IBSET(integer,integer*1)')
      call c_i(IBSET(12,m2),14,'IBSET(integer,integer*8)')
      call c_i2(IBSET(j,1),ja,'IBSET(integer*2,integer)')
      call c_i2(IBSET(j,j2),ja,'IBSET(integer*2,integer*2)')
      call c_i2(IBSET(j,k2),ja,'IBSET(integer*2,integer*1)')
      call c_i2(IBSET(j,m2),ja,'IBSET(integer*2,integer*8)')
      call c_i1(IBSET(k,1),ka,'IBSET(integer*1,integer)')
      call c_i1(IBSET(k,j2),ka,'IBSET(integer*1,integer*2)')
      call c_i1(IBSET(k,k2),ka,'IBSET(integer*1,integer*1)')
      call c_i1(IBSET(k,m2),ka,'IBSET(integer*1,integer*8)')
      call c_i8(IBSET(m,1),ma,'IBSET(integer*8,integer)')
      call c_i8(IBSET(m,j2),ma,'IBSET(integer*8,integer*2)')
      call c_i8(IBSET(m,k2),ma,'IBSET(integer*8,integer*1)')
      call c_i8(IBSET(m,m2),ma,'IBSET(integer*8,integer*8)')

c     IEOR   - Section 13.13.45
      j  = 3
      j2 = 1
      ja = 2
      k  = 3
      k2 = 1
      ka = 2
      m  = 3
      m2 = 1
      ma = 2
      call c_i(IEOR(3,1),2,'IEOR(integer,integer)')
      call c_i2(IEOR(j,j2),ja,'IEOR(integer*2,integer*2)')
      call c_i1(IEOR(k,k2),ka,'IEOR(integer*1,integer*1)')
      call c_i8(IEOR(m,m2),ma,'IEOR(integer*8,integer*8)')

c     ISHFT  - Section 13.13.49
      i  = 3
      i2 = 1
      i3 = 0
      ia = 6
      j  = 3
      j2 = 1
      j3 = 0
      ja = 6
      k  = 3
      k2 = 1
      k3 = 0
      ka = 6
      m  = 3
      m2 = 1
      m3 = 0
      ma = 6
      call c_i(ISHFT(i,i2),ia,'ISHFT(integer,integer)')
      call c_i(ISHFT(i,BIT_SIZE(i)),i3,'ISHFT(integer,integer) 2')
      call c_i(ISHFT(i,-BIT_SIZE(i)),i3,'ISHFT(integer,integer) 3')
      call c_i(ISHFT(i,0),i,'ISHFT(integer,integer) 4')
      call c_i2(ISHFT(j,j2),ja,'ISHFT(integer*2,integer*2)')
      call c_i2(ISHFT(j,BIT_SIZE(j)),j3,
     $     'ISHFT(integer*2,integer*2) 2')
      call c_i2(ISHFT(j,-BIT_SIZE(j)),j3,
     $     'ISHFT(integer*2,integer*2) 3')
      call c_i2(ISHFT(j,0),j,'ISHFT(integer*2,integer*2) 4')
      call c_i1(ISHFT(k,k2),ka,'ISHFT(integer*1,integer*1)')
      call c_i1(ISHFT(k,BIT_SIZE(k)),k3,
     $     'ISHFT(integer*1,integer*1) 2')
      call c_i1(ISHFT(k,-BIT_SIZE(k)),k3,
     $     'ISHFT(integer*1,integer*1) 3')
      call c_i1(ISHFT(k,0),k,'ISHFT(integer*1,integer*1) 4')
      call c_i8(ISHFT(m,m2),ma,'ISHFT(integer*8,integer*8)')
      call c_i8(ISHFT(m,BIT_SIZE(m)),m3,
     $     'ISHFT(integer*8,integer*8) 2')
      call c_i8(ISHFT(m,-BIT_SIZE(m)),m3,
     $     'ISHFT(integer*8,integer*8) 3')
      call c_i8(ISHFT(m,0),m,'ISHFT(integer*8,integer*8) 4')

c     ISHFTC - Section 13.13.50
c     The third argument is not optional in g77
      i  = 3
      i2 = 2
      i3 = 3
      ia = 5
      j  = 3
      j2 = 2
      j3 = 3
      ja = 5
      k  = 3
      k2 = 2
      k3 = 3
      ka = 5
      m2 = 2
      m3 = 3
      ma = 5
c     test all the combinations of arguments
      call c_i(ISHFTC(i,i2,i3),5,'ISHFTC(integer,integer,integer)')
      call c_i(ISHFTC(i,i2,j3),5,'ISHFTC(integer,integer,integer*2)')
      call c_i(ISHFTC(i,i2,k3),5,'ISHFTC(integer,integer,integer*1)')
      call c_i(ISHFTC(i,i2,m3),5,'ISHFTC(integer,integer,integer*8)')
      call c_i(ISHFTC(i,j2,i3),5,'ISHFTC(integer,integer*2,integer)')
      call c_i(ISHFTC(i,j2,j3),5,'ISHFTC(integer,integer*2,integer*2)')
      call c_i(ISHFTC(i,j2,k3),5,'ISHFTC(integer,integer*2,integer*1)')
      call c_i(ISHFTC(i,j2,m3),5,'ISHFTC(integer,integer*2,integer*8)')
      call c_i(ISHFTC(i,k2,i3),5,'ISHFTC(integer,integer*1,integer)')
      call c_i(ISHFTC(i,k2,j3),5,'ISHFTC(integer,integer*1,integer*2)')
      call c_i(ISHFTC(i,k2,k3),5,'ISHFTC(integer,integer*1,integer*1)')
      call c_i(ISHFTC(i,k2,m3),5,'ISHFTC(integer,integer*1,integer*8)')
      call c_i(ISHFTC(i,m2,i3),5,'ISHFTC(integer,integer*8,integer)')
      call c_i(ISHFTC(i,m2,j3),5,'ISHFTC(integer,integer*8,integer*2)')
      call c_i(ISHFTC(i,m2,k3),5,'ISHFTC(integer,integer*8,integer*1)')
      call c_i(ISHFTC(i,m2,m3),5,'ISHFTC(integer,integer*8,integer*8)')

      call c_i2(ISHFTC(j,i2,i3),ja,'ISHFTC(integer*2,integer,integer)')
      call c_i2(ISHFTC(j,i2,j3),ja,
     $     'ISHFTC(integer*2,integer,integer*2)')
      call c_i2(ISHFTC(j,i2,k3),ja,
     $     'ISHFTC(integer*2,integer,integer*1)')
      call c_i2(ISHFTC(j,i2,m3),ja,
     $     'ISHFTC(integer*2,integer,integer*8)')
      call c_i2(ISHFTC(j,j2,i3),ja,
     $     'ISHFTC(integer*2,integer*2,integer)')
      call c_i2(ISHFTC(j,j2,j3),ja,
     $     'ISHFTC(integer*2,integer*2,integer*2)')
      call c_i2(ISHFTC(j,j2,k3),ja,
     $     'ISHFTC(integer*2,integer*2,integer*1)')
      call c_i2(ISHFTC(j,j2,m3),ja,
     $     'ISHFTC(integer*2,integer*2,integer*8)')
      call c_i2(ISHFTC(j,k2,i3),ja,
     $     'ISHFTC(integer*2,integer*1,integer)')
      call c_i2(ISHFTC(j,k2,j3),ja,
     $     'ISHFTC(integer*2,integer*1,integer*2)')
      call c_i2(ISHFTC(j,k2,k3),ja,
     $     'ISHFTC(integer*2,integer*1,integer*1)')
      call c_i2(ISHFTC(j,k2,m3),ja,
     $     'ISHFTC(integer*2,integer*1,integer*8)')
      call c_i2(ISHFTC(j,m2,i3),ja,
     $     'ISHFTC(integer*2,integer*8,integer)')
      call c_i2(ISHFTC(j,m2,j3),ja,
     $     'ISHFTC(integer*2,integer*8,integer*2)')
      call c_i2(ISHFTC(j,m2,k3),ja,
     $     'ISHFTC(integer*2,integer*8,integer*1)')
      call c_i2(ISHFTC(j,m2,m3),ja,
     $     'ISHFTC(integer*2,integer*8,integer*8)')

      call c_i1(ISHFTC(k,i2,i3),ka,'ISHFTC(integer*1,integer,integer)')
      call c_i1(ISHFTC(k,i2,j3),ka,
     $     'ISHFTC(integer*1,integer,integer*2)')
      call c_i1(ISHFTC(k,i2,k3),ka,
     $     'ISHFTC(integer*1,integer,integer*1)')
      call c_i1(ISHFTC(k,i2,m3),ka,
     $     'ISHFTC(integer*1,integer,integer*8)')
      call c_i1(ISHFTC(k,j2,i3),ka,
     $     'ISHFTC(integer*1,integer*2,integer)')
      call c_i1(ISHFTC(k,j2,j3),ka,
     $     'ISHFTC(integer*1,integer*2,integer*2)')
      call c_i1(ISHFTC(k,j2,k3),ka,
     $     'ISHFTC(integer*1,integer*2,integer*1)')
      call c_i1(ISHFTC(k,j2,m3),ka,
     $     'ISHFTC(integer*1,integer*2,integer*8)')
      call c_i1(ISHFTC(k,k2,i3),ka,
     $     'ISHFTC(integer*1,integer*1,integer)')
      call c_i1(ISHFTC(k,k2,j3),ka,
     $     'ISHFTC(integer*1,integer*1,integer*2)')
      call c_i1(ISHFTC(k,k2,k3),ka,
     $     'ISHFTC(integer*1,integer*1,integer*1)')
      call c_i1(ISHFTC(k,k2,m3),ka,
     $     'ISHFTC(integer*1,integer*1,integer*8)')
      call c_i1(ISHFTC(k,m2,i3),ka,
     $     'ISHFTC(integer*1,integer*8,integer)')
      call c_i1(ISHFTC(k,m2,j3),ka,
     $     'ISHFTC(integer*1,integer*8,integer*2)')
      call c_i1(ISHFTC(k,m2,k3),ka,
     $     'ISHFTC(integer*1,integer*8,integer*1)')
      call c_i1(ISHFTC(k,m2,m3),ka,
     $     'ISHFTC(integer*1,integer*8,integer*8)')

      call c_i8(ISHFTC(m,i2,i3),ma,'ISHFTC(integer*8,integer,integer)')
      call c_i8(ISHFTC(m,i2,j3),ma,
     $     'ISHFTC(integer*8,integer,integer*2)')
      call c_i8(ISHFTC(m,i2,k3),ma,
     $     'ISHFTC(integer*8,integer,integer*1)')
      call c_i8(ISHFTC(m,i2,m3),ma,
     $     'ISHFTC(integer*8,integer,integer*8)')
      call c_i8(ISHFTC(m,j2,i3),ma,
     $     'ISHFTC(integer*8,integer*2,integer)')
      call c_i8(ISHFTC(m,j2,j3),ma,
     $     'ISHFTC(integer*8,integer*2,integer*2)')
      call c_i8(ISHFTC(m,j2,k3),ma,
     $     'ISHFTC(integer*8,integer*2,integer*1)')
      call c_i8(ISHFTC(m,j2,m3),ma,
     $     'ISHFTC(integer*8,integer*2,integer*8)')
      call c_i8(ISHFTC(m,k2,i3),ma,
     $     'ISHFTC(integer*8,integer*1,integer)')
      call c_i8(ISHFTC(m,k2,j3),ma,
     $     'ISHFTC(integer*1,integer*8,integer*2)')
      call c_i8(ISHFTC(m,k2,k3),ma,
     $     'ISHFTC(integer*1,integer*8,integer*1)')
      call c_i8(ISHFTC(m,k2,m3),ma,
     $     'ISHFTC(integer*1,integer*8,integer*8)')
      call c_i8(ISHFTC(m,m2,i3),ma,
     $     'ISHFTC(integer*8,integer*8,integer)')
      call c_i8(ISHFTC(m,m2,j3),ma,
     $     'ISHFTC(integer*8,integer*8,integer*2)')
      call c_i8(ISHFTC(m,m2,k3),ma,
     $     'ISHFTC(integer*8,integer*8,integer*1)')
      call c_i8(ISHFTC(m,m2,m3),ma,
     $     'ISHFTC(integer*8,integer*8,integer*8)')

c     test the corner cases
      call c_i(ISHFTC(i,BIT_SIZE(i),BIT_SIZE(i)),i,
     $     'ISHFTC(i,BIT_SIZE(i),BIT_SIZE(i)) i = integer')
      call c_i(ISHFTC(i,0,BIT_SIZE(i)),i,
     $     'ISHFTC(i,0,BIT_SIZE(i)) i = integer')
      call c_i(ISHFTC(i,-BIT_SIZE(i),BIT_SIZE(i)),i,
     $     'ISHFTC(i,-BIT_SIZE(i),BIT_SIZE(i)) i = integer')
      call c_i2(ISHFTC(j,BIT_SIZE(j),BIT_SIZE(j)),j,
     $     'ISHFTC(j,BIT_SIZE(j),BIT_SIZE(j)) j = integer*2')
      call c_i2(ISHFTC(j,0,BIT_SIZE(j)),j,
     $     'ISHFTC(j,0,BIT_SIZE(j)) j = integer*2')
      call c_i2(ISHFTC(j,-BIT_SIZE(j),BIT_SIZE(j)),j,
     $     'ISHFTC(j,-BIT_SIZE(j),BIT_SIZE(j)) j = integer*2')
      call c_i1(ISHFTC(k,BIT_SIZE(k),BIT_SIZE(k)),k,
     $     'ISHFTC(k,BIT_SIZE(k),BIT_SIZE(k)) k = integer*1')
      call c_i1(ISHFTC(k,0,BIT_SIZE(k)),k,
     $     'ISHFTC(k,0,BIT_SIZE(k)) k = integer*1')
      call c_i1(ISHFTC(k,-BIT_SIZE(k),BIT_SIZE(k)),k,
     $     'ISHFTC(k,-BIT_SIZE(k),BIT_SIZE(k)) k = integer*1')
      call c_i8(ISHFTC(m,BIT_SIZE(m),BIT_SIZE(m)),m,
     $     'ISHFTC(m,BIT_SIZE(m),BIT_SIZE(m)) m = integer*8')
      call c_i8(ISHFTC(m,0,BIT_SIZE(m)),m,
     $     'ISHFTC(m,0,BIT_SIZE(m)) m = integer*8')
      call c_i8(ISHFTC(m,-BIT_SIZE(m),BIT_SIZE(m)),m,
     $     'ISHFTC(m,-BIT_SIZE(m),BIT_SIZE(m)) m = integer*8')

c     MVBITS - Section 13.13.74
      i = 6
      call MVBITS(7,2,2,i,0)
      call c_i(i,5,'MVBITS 1')
      j = 6
      j2 = 7
      ja = 5
      call MVBITS(j2,2,2,j,0)
      call c_i2(j,ja,'MVBITS 2')
      k = 6
      k2 = 7
      ka = 5
      call MVBITS(k2,2,2,k,0)
      call c_i1(k,ka,'MVBITS 3')
      m = 6
      m2 = 7
      ma = 5
      call MVBITS(m2,2,2,m,0)
      call c_i8(m,ma,'MVBITS 4')

c     NOT    - Section 13.13.77
c     Rather than assume integer sizes, mask off high bits
      j  = 21
      j2 = 31
      ja = 10
      k  = 21
      k2 = 31
      ka = 10
      m  = 21
      m2 = 31
      ma = 10
      call c_i(IAND(NOT(21),31),10,'NOT(integer)')
      call c_i2(IAND(NOT(j),j2),ja,'NOT(integer*2)')
      call c_i1(IAND(NOT(k),k2),ka,'NOT(integer*1)')
      call c_i8(IAND(NOT(m),m2),ma,'NOT(integer*8)')

      if ( fail ) call abort()
      end

      subroutine failure(label)
c     Report failure and set flag
      character*(*) label
      logical fail
      common /flags/ fail
      write(6,'(a,a,a)') 'Test ',label,' FAILED'
      fail = .true.
      end

      subroutine c_l(i,j,label)
c     Check if LOGICAL i equals j, and fail otherwise
      logical i,j
      character*(*) label
      if ( i .eqv. j ) then
         call failure(label)
         write(6,*) 'Got ',i,' expected ', j
      end if
      end

      subroutine c_i(i,j,label)
c     Check if INTEGER i equals j, and fail otherwise
      integer i,j
      character*(*) label
      if ( i .ne. j ) then
         call failure(label)
         write(6,*) 'Got ',i,' expected ', j
      end if
      end

      subroutine c_i2(i,j,label)
c     Check if INTEGER*2 i equals j, and fail otherwise
      integer*2 i,j
      character*(*) label
      if ( i .ne. j ) then
         call failure(label)
         write(6,*) 'Got ',i,' expected ', j
      end if
      end

      subroutine c_i1(i,j,label)
c     Check if INTEGER*1 i equals j, and fail otherwise
      integer*1 i,j
      character*(*) label
      if ( i .ne. j ) then
         call failure(label)
         write(6,*) 'Got ',i,' expected ', j
      end if
      end

      subroutine c_i8(i,j,label)
c     Check if INTEGER*8 i equals j, and fail otherwise
      integer*8 i,j
      character*(*) label
      if ( i .ne. j ) then
         call failure(label)
         write(6,*) 'Got ',i,' expected ', j
      end if
      end


      DOUBLE PRECISION FUNCTION PHO_DORFQP(X,S,St,Al,Be,Ak,Ag,B,D,E,Es)
      IMPLICIT NONE
      DOUBLE PRECISION Ag , Ak , Al , B , Be , D , dx , E , Es , lx ,
     &                 S , St , X
      SAVE

      dx = SQRT(X)
      lx = LOG(1./X)
      IF ( S.LE.St ) THEN
         PHO_DORFQP = 0.0
      ELSE
         PHO_DORFQP = (S-St)**Al/lx**Ak*(1.D0+Ag*dx+B*X)*(1.D0-X)
     &                **D*EXP(-E+SQRT(Es*S**Be*lx))

      END IF
      END FUNCTION


module triutil

character(len=512) :: fault_file        ! source fault file
character(len=512) :: station_file      ! station location file
character(len=512) :: target_file       ! target/receiver fault geometry file
character(len=512) :: halfspace_file    ! half-space parameter file
character(len=512) :: displacement_file ! displacement file
character(len=512) :: strain_file       ! strain tensor file
character(len=512) :: stress_file       ! stress tensor file
character(len=512) :: estress_file      ! effective (maximum) shear stress file
character(len=512) :: normal_file       ! normal stress file
character(len=512) :: shear_file        ! shear & maximum shear stress file
character(len=512) :: coulomb_file      ! Coulomb stress
logical :: isFaultFileDefined           ! Boolean for fault_file
logical :: isStationFileDefined         ! Boolean for station_file
logical :: isTargetFileDefined          ! Boolean for target_file
logical :: isOutputFileDefined          ! Boolean for deformation output
logical :: iWantDisp                    ! Boolean for calculating displacement
logical :: iWantStrain
logical :: iWantStress
logical :: iWantTraction
logical :: iWantProg
character(len=16) :: coord_type         ! cartesian-m, cartesian-km, geographic
integer :: nfaults
integer :: nstations
double precision, allocatable :: faults(:,:)
double precision, allocatable :: stations(:,:)
double precision, allocatable :: targets(:,:)
double precision :: poisson, lame, shearmod

end module

!==================================================================================================!

program main
!----
! Utility for computing displacements, strains, and stresses in an elastic half-space resulting
! from triangular shear dislocations. All the work is done in tri_disloc_module.f90, which is
! simply a modification of Brendan Meade's Matlab code into Fortran.
!
! Please cite: Meade, B.J. (2007). Algorithms for the calculation of exact displacements, strains,
! and stresses for Triangular Dislocation Elements in a uniform elastic half space. Computers &
! Geosciences. doi:10.1016/j.cageo.2006.12.003.
!----

use triutil, only: isOutputFileDefined
implicit none

call gcmdln()
if (.not.isOutputFileDefined) then
    call usage('triutil: no output defined')
endif

call read_faults()
call read_stations()
call read_targets()
call read_halfspace()
call calc_deformation()

end

!--------------------------------------------------------------------------------------------------!

subroutine read_faults()
!----
! Read the input fault file, in format:
!     x1 y1 z1 x2 y2 z2 x3 y3 z3 strike_slip dip_slip [tensile_slip]
!----

use io, only: stderr, line_count
use triutil, only: fault_file, &
                   nfaults, &
                   faults, &
                   isFaultFileDefined
implicit none

! Local variables
integer :: i, j, ios
character(len=512) :: input_line
logical :: doesFaultFileExist

! Initialize ios
ios = 0

! Check that fault file is defined and exists
if (.not.isFaultFileDefined) then
    call usage('read_faults: no fault file defined')
endif
inquire(exist=doesFaultFileExist,file=fault_file)
if (.not.doesFaultFileExist) then
    call usage('read_faults: no fault file named '//trim(fault_file)//' found')
endif

! Count the number of lines in the file and allocate memory for the fault array
! Fault array: x1 y1 z1 x2 y2 z2 x3 y3 z3 ss ds ts
nfaults = line_count(fault_file)
allocate(faults(nfaults,12))
! write(0,*) 'read_faults: nfaults=',nfaults

! Read fault file
open(unit=12,file=fault_file,status='old')
do i = 1,nfaults
    read(12,'(A)') input_line

    ! Attempt to read 12 inputs, assuming tensile_slip is provided
    read(input_line,*,iostat=ios,err=1001) (faults(i,j),j=1,12)

    ! Attempt to read 11 inputs, assuming tensile_slip is not included
    if (ios.ne.0) then
        read(input_line,*,iostat=ios,err=1001,end=1002) (faults(i,j),j=1,11)
        faults(i,12) = 0.0d0
    endif
    ! write(0,*) 'read_faults:',i,faults(i,:)
enddo
close(12)

! Read error messages
1001 if (ios.ne.0) then
    write(stderr,*) 'read_faults: read error'
    call usage('offending line: '//trim(input_line))
endif
1002 if (ios.ne.0) then
    write(stderr,*) 'read_faults: line end'
    call usage('offending line: '//trim(input_line))
endif

return
end subroutine read_faults

!--------------------------------------------------------------------------------------------------!

subroutine read_stations()
!----
! Read the input station file, in format:
!     x1 y1 z1
!----

use io, only: stderr, line_count

use triutil, only: station_file, &
                   nstations, &
                   stations, &
                   isStationFileDefined

implicit none

! Local variables
integer :: i, j, ios
character(len=512) :: input_line
logical :: doesStationFileExist

! Check that station file is defined and the file exists
if (.not.isStationFileDefined) then
    call usage('read_stations: no station file defined')
endif
inquire(exist=doesStationFileExist,file=station_file)
if (.not.doesStationFileExist) then
    call usage('read_stations: no station file named '//trim(station_file)//' found')
endif

! Count number of stations and allocate memory to station array (x y z)
nstations = line_count(station_file)
! write(0,*) 'read_stations: nstations=',nstations
allocate(stations(nstations,3))

! Read stations
open(unit=13,file=station_file,status='old')
do i = 1,nstations
    read(13,'(A)') input_line
    read(input_line,*,iostat=ios,err=1003,end=1004) (stations(i,j),j=1,3)
    ! write(0,*) 'read_stations: ',i,stations(i,:)
enddo
close(13)

! Error messages
1003 if (ios.ne.0) then
    write(stderr,*) 'read_stations: read error'
    call usage('offending line: '//trim(input_line))
endif
1004 if (ios.ne.0) then
    write(stderr,*) 'read_stations: line end'
    call usage('offending line: '//trim(input_line))
endif

return
end subroutine read_stations

!--------------------------------------------------------------------------------------------------!

subroutine read_targets()
!----
! Read the input target fault geometry file, in format:
!     str dip rak fric
!----

use io, only: stderr, line_count

use triutil, only: target_file, &
                   targets, &
                   isTargetFileDefined, &
                   iWantTraction, &
                   nstations

implicit none

! Local variables
integer :: i, j, ios, ntargets
character(len=512) :: input_line
logical :: doesTargetFileExist

! Check that tractions need to be resolved, target fault file is defined, and the file exists
if (.not.iWantTraction) then
    return
else
    if (.not.isTargetFileDefined) then
        call usage('read_targets: no target geometry file defined')
    endif
endif
inquire(exist=doesTargetFileExist,file=target_file)
if (.not.doesTargetFileExist) then
    call usage('read_targets: no target geometry file named '//trim(target_file)//' found')
endif

! Count number of target geometries and allocate memory to target array (str dip rak fric)
ntargets = line_count(target_file)
if (ntargets.ne.1.and.ntargets.ne.nstations) then
    call usage('read_targets: number of target geometries must be 1 or nstations')
endif
allocate(targets(nstations,4))

! Read target fault geometries
open(unit=14,file=target_file,status='old')
do i = 1,ntargets
    read(14,'(A)') input_line
    read(input_line,*,iostat=ios,err=1005,end=1006) (targets(i,j),j=1,4)
enddo
close(14)

! Fill target array if only one is specified
if (ntargets.eq.1) then
    do i = 2,nstations
        targets(i,:) = targets(1,:)
    enddo
endif

! Error messages
1005 if (ios.ne.0) then
    write(stderr,*) 'read_targets: read error'
    call usage('offending line: '//trim(input_line))
endif
1006 if (ios.ne.0) then
    write(stderr,*) 'read_targets: line end'
    call usage('offending line: '//trim(input_line))
endif

return
end subroutine read_targets

!--------------------------------------------------------------------------------------------------!

subroutine read_halfspace()
!----
! Read half-space parameters with the subroutine read_halfspace_file in the elast module.
!----
use elast, only: read_halfspace_file
use triutil, only: halfspace_file, &
                   poisson, &
                   lame, &
                   shearmod
implicit none
integer :: ierr
call read_halfspace_file(halfspace_file,poisson,shearmod,lame,ierr)
if (ierr.ne.0) then
    call usage('')
endif
return
end subroutine

!--------------------------------------------------------------------------------------------------!

subroutine calc_deformation()
!----
! Calculate all requested deformation values at station locations
!----

use io, only: stderr, verbosity, progress_indicator
use trig, only: d2r
use elast, only: strain2stress, stress2traction, max_shear_stress, traction_components
use algebra, only: dot_product
use eq, only: sdr2sv
use geom, only: strdip2normal

use triutil, only: displacement_file, &
                   strain_file, &
                   stress_file, &
                   estress_file, &
                   normal_file, &
                   shear_file, &
                   coulomb_file, &
                   iWantDisp, &
                   iWantStrain, &
                   iWantStress, &
                   iWantTraction, &
                   iWantProg, &
                   nstations, &
                   stations, &
                   targets, &
                   lame, &
                   shearmod

implicit none

! Local variables
integer :: ierr, iSta, file_unit
logical :: isThisUnitOpen
double precision :: disp(3), strain(3,3), stress(3,3), estress
double precision :: trac_vector(3), shear, shearmax, normal, coulomb, svec(3), nvec(3), tstr, tupd

! Check which calculations are needed and open output files if requested
if (iWantDisp) then
    if (verbosity.ge.1) then
        write(stderr,*) 'calc_deformation: calculating displacements'
    endif
    if (displacement_file.ne.'') then
        open(unit=101,file=displacement_file,status='unknown')
    endif
endif
if (iWantStrain) then
    if (verbosity.ge.1) then
        write(stderr,*) 'calc_deformation: calculating strains'
    endif
    if (strain_file.ne.'') then
        open(unit=111,file=strain_file,status='unknown')
    endif
endif
if (iWantStress) then
    if (verbosity.ge.1) then
        write(stderr,*) 'calc_deformation: calculating stresses'
    endif
    if (stress_file.ne.'') then
        open(unit=121,file=stress_file,status='unknown')
    endif
    if (estress_file.ne.'') then
        open(unit=122,file=estress_file,status='unknown')
    endif
endif
if (iWantTraction) then
    if (verbosity.ge.1) then
        write(stderr,*) 'calc_deformation: calculating resolved tractions'
    endif
    if (normal_file.ne.'') then
        open(unit=131,file=normal_file,status='unknown')
    endif
    if (shear_file.ne.'') then
        open(unit=132,file=shear_file,status='unknown')
    endif
    if (coulomb_file.ne.'') then
        open(unit=133,file=coulomb_file,status='unknown')
    endif
endif

! Calculate the requested quantities at each station
do iSta = 1,nstations

    if (iWantDisp) then
        call calc_displacement(disp,stations(iSta,1),stations(iSta,2),stations(iSta,3))
        ! Displacement: ux, uy, uz
        if (displacement_file.ne.'') then
            write(101,*) stations(iSta,:),disp
        endif
    endif

    if (iWantStrain) then
        call calc_strain(strain,stations(iSta,1),stations(iSta,2),stations(iSta,3))
        ! Strain tensor: exx, eyy, ezz, exy, exz, eyz
        if (strain_file.ne.'') then
            write(111,*) stations(iSta,:),strain(1,1),strain(2,2),strain(3,3), &
                         strain(1,2),strain(1,3),strain(2,3)
        endif
    endif

    if (iWantStress) then
        call strain2stress(strain,lame,shearmod,stress)
        ! Stress tensor: sxx, syy, szz, sxy, sxz, syz
        if (stress_file.ne.'') then
            write(121,*) stations(iSta,:),stress(1,1),stress(2,2),stress(3,3), &
                         stress(1,2),stress(1,3),stress(2,3)
        endif
        ! Maximum (effective) shear stress: estress
        if (estress_file.ne.'') then
            call max_shear_stress(stress,estress)
            write(122,*) stations(iSta,:),estress
        endif
    endif

    if (iWantTraction) then
        ! call calc_tractions(trac_vector,shear,shearmax,normal,coulomb,stress,targets(iSta,:))
        call sdr2sv(targets(iSta,1),targets(iSta,2),targets(iSta,3),svec)
        call strdip2normal(targets(iSta,1),targets(iSta,2),nvec)
        call stress2traction(stress,nvec,trac_vector)
        call traction_components(trac_vector,nvec,normal,tstr,tupd)
        shearmax = sqrt(tstr*tstr+tupd*tupd)
        shear = tstr*cos(targets(iSta,3)*d2r) + tupd*sin(targets(iSta,3)*d2r)
        coulomb = shear + targets(iSta,4)*normal

        ! Normal traction: normal (positive=dilation)
        if (normal_file.ne.'') then
            write(131,*) stations(iSta,:),normal
        endif
        ! Shear traction: resolved_onto_rake, max_shear_on_plane
        if (shear_file.ne.'') then
            write(132,*) stations(iSta,:),shear,shearmax
        endif
        ! Coulomb stress: coulomb
        if (coulomb_file.ne.'') then
            write(133,*) stations(iSta,:),coulomb
        endif
    endif

    if (iWantProg) then
        call progress_indicator(iSta,nstations,'triutil calc_deformation',ierr)
        if (ierr.ne.0) then
            call usage('calc_deformation: error in progress_indicator')
        endif
    endif
enddo

! Close files that were opened for writing
inquire(file=displacement_file,number=file_unit,opened=isThisUnitOpen)
if (isThisUnitOpen) then
    close(file_unit)
endif
inquire(file=strain_file,number=file_unit,opened=isThisUnitOpen)
if (isThisUnitOpen) then
    close(file_unit)
endif
inquire(file=stress_file,number=file_unit,opened=isThisUnitOpen)
if (isThisUnitOpen) then
    close(file_unit)
endif
inquire(file=estress_file,number=file_unit,opened=isThisUnitOpen)
if (isThisUnitOpen) then
    close(file_unit)
endif
inquire(file=normal_file,number=file_unit,opened=isThisUnitOpen)
if (isThisUnitOpen) then
    close(file_unit)
endif
inquire(file=shear_file,number=file_unit,opened=isThisUnitOpen)
if (isThisUnitOpen) then
    close(file_unit)
endif
inquire(file=coulomb_file,number=file_unit,opened=isThisUnitOpen)
if (isThisUnitOpen) then
    close(file_unit)
endif

return
end subroutine calc_deformation

!--------------------------------------------------------------------------------------------------!

subroutine calc_displacement(disp,x,y,z)
!----
! Calculate displacements at coordinate (x,y,z), where z is defined positive down, but the
! displacement uz is defined positive up.
!----

use geom, only: lola2distaz
use tri_disloc, only: tri_disloc_disp, tri_center           ! Triangular dislocation subroutines
use earth, only: radius_earth_m

use triutil, only: nfaults, &
                   faults, &
                   poisson, &
                   coord_type     ! Fault and half-space variables

implicit none

! Arguments
double precision :: disp(3), x, y, z

! Local variables
double precision :: sta_coord(3), tri_coord(3,4), slip(3), tri_coord_new(3,4)
double precision :: center(3), dist, az
double precision :: disptmp(3)
integer :: iFlt, iTri, ierr

! Initialize displacement
disp = 0.0d0

! Set station location units to meters (input units are km)
if (coord_type.eq.'cartesian') then
    sta_coord(1) = x*1.0d3
    sta_coord(2) = y*1.0d3
endif
sta_coord(3) = z*1.0d3

do iFlt = 1,nfaults
    tri_coord(1,1) = faults(iFlt,1)
    tri_coord(2,1) = faults(iFlt,2)
    tri_coord(3,1) = faults(iFlt,3)
    tri_coord(1,2) = faults(iFlt,4)
    tri_coord(2,2) = faults(iFlt,5)
    tri_coord(3,2) = faults(iFlt,6)
    tri_coord(1,3) = faults(iFlt,7)
    tri_coord(2,3) = faults(iFlt,8)
    tri_coord(3,3) = faults(iFlt,9)
    slip(1) = -faults(iFlt,10)        ! triutil: ll positive;  tri_disloc_disp(): rl positive
    slip(2) = -faults(iFlt,11)        ! triutil: thr positive; tri_disloc_disp(): nor positive
    slip(3) = faults(iFlt,12)
    ! write(0,*) 'triutil    : tri_coord',tri_coord(1:3,1:3)
    ! write(0,*) 'triutil    : slip',slip

    if (coord_type.eq.'geographic') then
        ! Convert lon lat dep(km) to x(m) y(m) z(m) from triangle center
        call tri_center(center,tri_coord(:,1),tri_coord(:,2),tri_coord(:,3))
        call lola2distaz(center(1),center(2),x,y,dist,az,'radians','radians',ierr)
        if (ierr.ne.0) then
            call usage('calc_displacement: error computing distance and azimuth')
        endif
        sta_coord(1) = dist*radius_earth_m*dsin(az)
        sta_coord(2) = dist*radius_earth_m*dcos(az)
        do iTri = 1,3
            call lola2distaz(center(1),center(2),tri_coord(1,iTri),tri_coord(2,iTri),dist,az,&
                        'radians','radians',ierr)
            if (ierr.ne.0) then
                call usage('calc_displacement: error computing distance and azimuth')
            endif
            tri_coord_new(1,iTri) = dist*radius_earth_m*dsin(az)
            tri_coord_new(2,iTri) = dist*radius_earth_m*dcos(az)
            tri_coord_new(3,iTri) = tri_coord(3,iTri)*1.0d3
        enddo
    else
        ! Convert triangle x(km) y(km) z(km) to x(m) y(m) z(m)
        tri_coord_new = tri_coord*1.0d3
    endif
    ! write(0,*) 'triutil    : sta_coord',sta_coord

    call tri_disloc_disp(disptmp, sta_coord, tri_coord_new, poisson, slip)
    disp = disp + disptmp
enddo

! Output from tri_disloc_disp is positive down, so invert vertical component
disp(3) = -disp(3)

return
end subroutine calc_displacement

!--------------------------------------------------------------------------------------------------!

subroutine calc_strain(strain,x,y,z)
!----
! Calculate strains at coordinate (x,y,z), where z is defined positive down, but the
! strain z coordinate is defined positive up.
!----

use tri_disloc, only: tri_disloc_strain, tri_center       ! Triangular dislocation subroutines
use geom, only: lola2distaz
use earth, only: radius_earth_m

use triutil, only: nfaults, &
                   faults, &
                   poisson, &
                   coord_type   ! Fault and half-space variables

implicit none

! Arguments
double precision :: strain(3,3), x, y, z

! Local variables
double precision :: sta_coord(3), tri_coord(3,4), slip(3), tri_coord_new(3,4)
double precision :: center(3), dist, az
double precision :: straintmp(3,3)
integer :: iFlt, iTri, ierr

! Initialize displacement
strain = 0.0d0

! Set coordinates to meters (input units are geographic and/or km)
if (coord_type.eq.'cartesian') then
    sta_coord(1) = x*1.0d3
    sta_coord(2) = y*1.0d3
endif
sta_coord(3) = z*1.0d3

do iFlt = 1,nfaults
    tri_coord(1,1) = faults(iFlt,1)
    tri_coord(2,1) = faults(iFlt,2)
    tri_coord(3,1) = faults(iFlt,3)
    tri_coord(1,2) = faults(iFlt,4)
    tri_coord(2,2) = faults(iFlt,5)
    tri_coord(3,2) = faults(iFlt,6)
    tri_coord(1,3) = faults(iFlt,7)
    tri_coord(2,3) = faults(iFlt,8)
    tri_coord(3,3) = faults(iFlt,9)
    slip(1) = -faults(iFlt,10)        ! triutil: ll positive;  tri_disloc_disp(): rl positive
    slip(2) = -faults(iFlt,11)        ! triutil: thr positive; tri_disloc_disp(): nor positive
    slip(3) = faults(iFlt,12)

    if (coord_type.eq.'geographic') then
        ! Convert lon lat dep(km) to x(m) y(m) z(m) from triangle center
        call tri_center(center,tri_coord(:,1),tri_coord(:,2),tri_coord(:,3))
        call lola2distaz(center(1),center(2),x,y,dist,az,'radians','radians',ierr)
        if (ierr.ne.0) then
            call usage('calc_strain: error computing distance and azimuth')
        endif
        sta_coord(1) = dist*radius_earth_m*dsin(az)
        sta_coord(2) = dist*radius_earth_m*dcos(az)
        do iTri = 1,3
            call lola2distaz(center(1),center(2),tri_coord(1,iTri),tri_coord(2,iTri),dist,az,&
                        'radians','radians',ierr)
            if (ierr.ne.0) then
                call usage('calc_strain: error computing distance and azimuth')
            endif
            tri_coord_new(1,iTri) = dist*radius_earth_m*dsin(az)
            tri_coord_new(2,iTri) = dist*radius_earth_m*dcos(az)
            tri_coord_new(3,iTri) = tri_coord(3,iTri)*1.0d3
        enddo
    else
        ! Convert triangle x(km) y(km) z(km) to x(m) y(m) z(m)
        tri_coord_new = tri_coord*1.0d3
    endif

    call tri_disloc_strain(straintmp, sta_coord, tri_coord_new, poisson, slip)
    strain = strain + straintmp
enddo

! Output from tri_disloc_strain is positive down, so invert xz and yz strain components
strain(1,3) = -strain(1,3)
strain(3,1) = -strain(3,1)
strain(2,3) = -strain(2,3)
strain(3,2) = -strain(3,2)

return
end subroutine calc_strain

!--------------------------------------------------------------------------------------------------!

subroutine gcmdln()

use io, only: stderr, verbosity
use triutil, only: fault_file, &
                   station_file, &
                   target_file, &
                   halfspace_file, &
                   displacement_file, &
                   strain_file, &
                   stress_file, &
                   estress_file, &
                   normal_file, &
                   shear_file, &
                   coulomb_file, &
                   coord_type, &
                   isFaultFileDefined, &
                   isStationFileDefined, &
                   isTargetFileDefined, &
                   isOutputFileDefined, &
                   iWantDisp, &
                   iWantStrain, &
                   iWantStress, &
                   iWantTraction, &
                   iWantProg, &
                   poisson, &
                   lame, &
                   shearmod
implicit none

! Local variables
integer :: i, narg, ios
character(len=512) :: tag

! Initialize control variables
fault_file = ''
station_file = ''
target_file = ''
halfspace_file = ''
displacement_file = ''
strain_file = ''
stress_file = ''
estress_file = ''
normal_file = ''
shear_file = ''
coulomb_file = ''
isFaultFileDefined = .false.
isStationFileDefined = .false.
isTargetFileDefined = .false.
isOutputFileDefined = .false.
iWantDisp = .false.
iWantStrain = .false.
iWantStress = .false.
iWantTraction = .false.
iWantProg = .false.
poisson = 0.25d0
lame = 40.0d9
shearmod = 40.0d9
coord_type = 'geographic'
verbosity = 0

narg = command_argument_count()
if (narg.eq.0) then
    call usage('')
endif

! Everything is hunky-dory to start out
ios = 0

i = 1
do while (i.le.narg)

    call get_command_argument(i,tag)

    if (trim(tag).eq.'-flt') then
        i = i + 1
        call get_command_argument(i,fault_file)

        isFaultFileDefined = .true.

    elseif (trim(tag).eq.'-sta') then
        i = i + 1
        call get_command_argument(i,station_file)

        isStationFileDefined = .true.

    elseif (trim(tag).eq.'-trg') then
        i = i + 1
        call get_command_argument(i,target_file)

        isTargetFileDefined = .true.

    elseif (trim(tag).eq.'-haf') then
        i = i + 1
        call get_command_argument(i,halfspace_file)

    elseif (trim(tag).eq.'-disp') then
        i = i + 1
        call get_command_argument(i,displacement_file)

        isOutputFileDefined = .true.
        iWantDisp = .true.

    elseif (trim(tag).eq.'-strain') then
        i = i + 1
        call get_command_argument(i,strain_file)

        isOutputFileDefined = .true.
        iWantStrain = .true.

    elseif (trim(tag).eq.'-stress') then
        i = i + 1
        call get_command_argument(i,stress_file)

        isOutputFileDefined = .true.
        iWantStrain = .true.
        iWantStress = .true.

    elseif (trim(tag).eq.'-estress') then
        i = i + 1
        call get_command_argument(i,estress_file)

        isOutputFileDefined = .true.
        iWantStrain = .true.
        iWantStress = .true.

    elseif (trim(tag).eq.'-normal') then
        i = i + 1
        call get_command_argument(i,normal_file)

        isOutputFileDefined = .true.
        iWantStrain = .true.
        iWantStress = .true.
        iWantTraction = .true.

    elseif (trim(tag).eq.'-shear'.or.trim(tag).eq.'-shearmax') then
        i = i + 1
        call get_command_argument(i,shear_file)

        isOutputFileDefined = .true.
        iWantStrain = .true.
        iWantStress = .true.
        iWantTraction = .true.

    elseif (trim(tag).eq.'-coul') then
        i = i + 1
        call get_command_argument(i,coulomb_file)

        isOutputFileDefined = .true.
        iWantStrain = .true.
        iWantStress = .true.
        iWantTraction = .true.

    elseif (trim(tag).eq.'-geographic'.or.trim(tag).eq.'-geo') then
        coord_type = 'geographic'

    elseif (trim(tag).eq.'-cartesian'.or.trim(tag).eq.'-xy') then
        coord_type = 'cartesian'

    elseif (trim(tag).eq.'-prog') then
        iWantProg = .true.

    elseif (trim(tag).eq.'-v'.or.trim(tag).eq.'-verbose'.or.trim(tag).eq.'-verbosity') then
        i = i + 1
        call get_command_argument(i,tag)
        read(tag,*,iostat=ios,err=9001) verbosity

    else
        call usage('triutil: no option '//trim(tag))

    endif

    i = i + 1

enddo

if (verbosity.ge.1) then
    write(stderr,*) 'gcmdln read:'
    write(stderr,*) 'fault_file:          ',trim(fault_file)
    write(stderr,*) 'station_file:        ',trim(station_file)
    write(stderr,*) 'target_file:         ',trim(target_file)
    write(stderr,*) 'halfspace_file:      ',trim(halfspace_file)
    write(stderr,*) 'displacement_file:   ',trim(displacement_file)
    write(stderr,*) 'strain_file:         ',trim(strain_file)
    write(stderr,*) 'stress_file:         ',trim(stress_file)
    write(stderr,*) 'estress_file:        ',trim(estress_file)
    write(stderr,*) 'normal_file:         ',trim(normal_file)
    write(stderr,*) 'shear_file:          ',trim(shear_file)
    write(stderr,*) 'coulomb_file:        ',trim(coulomb_file)
    write(stderr,*) 'isFaultFileDefined:  ',isFaultFileDefined
    write(stderr,*) 'isStationFileDefined:',isStationFileDefined
    write(stderr,*) 'isTargetFileDefined: ',isTargetFileDefined
    write(stderr,*) 'isOutputFileDefined: ',isOutputFileDefined
    write(stderr,*) 'iWantDisp:           ',iWantDisp
    write(stderr,*) 'iWantStrain:         ',iWantStrain
    write(stderr,*) 'iWantStress:         ',iWantStress
    write(stderr,*) 'iWantTraction:       ',iWantTraction
    write(stderr,*) 'coord_type:          ',trim(coord_type)
    write(stderr,*) 'verbosity:           ',verbosity
endif

9001 if (ios.ne.0) then
    call usage('triutil: error reading string '//trim(tag))
endif

return
end subroutine gcmdln

!--------------------------------------------------------------------------------------------------!

subroutine usage(str)

use io, only: stderr
implicit none

! Arguments
character(len=*) :: str

if (trim(str).ne.'') then
    write(stderr,*) trim(str)
    write(stderr,*)
endif

write(stderr,*) 'Usage: triutil ...options...'
write(stderr,*)
write(stderr,*) '-flt FLTFILE         Triangular source faults'
write(stderr,*) '-sta STAFILE         Station/receiver locations'
write(stderr,*) '-trg TRGFILE         Target/receiver geometry'
write(stderr,*) '-haf HAFSPCFILE      Elastic half-space properties'
write(stderr,*) '-disp DSPFILE        Displacement (E N Z)'
write(stderr,*) '-strain STNFILE      Strain matrix (EE NN ZZ EN EZ NZ)'
write(stderr,*) '-stress STSFILE      Stress matrix (EE NN ZZ EN EZ NZ)'
write(stderr,*) '-estress ESTSFILE    Effective (maximum) shear stress'
write(stderr,*) '-normal NORFILE      Normal traction on target faults (requires -trg)'
write(stderr,*) '-shear SHRFILE       Shear traction on target faults (requires -trg)'
write(stderr,*) '-coul COULFILE       Coulomb stress on target faults (requires -trg)'
write(stderr,*) '-geo|-xy             Use geographic (default) or cartesian coordinates'
write(stderr,*) '-prog                Progress indicator'
write(stderr,*) '-v LVL               Turn on verbose mode'
write(stderr,*)
write(stderr,*) 'See man page for details'
write(stderr,*)

call error_exit(1)
end subroutine usage


PROGRAM DATE

  IMPLICIT NONE

  INTEGER :: dateinfo(8), day
  CHARACTER(9) :: month, dayname

  CALL DATE_AND_TIME(VALUES=dateinfo)
  SELECT CASE(dateinfo(2))
    CASE(1)
      month = "January"
    CASE(2)
      month = "February"
    CASE(3)
      month = "March"
    CASE(4)
      month = "April"
    CASE(5)
      month = "May"
    CASE(6)
      month = "June"
    CASE(7)
      month = "July"
    CASE(8)
      month = "August"
    CASE(9)
      month = "September"
    CASE(10)
      month = "October"
    CASE(11)
      month = "November"
    CASE(12)
     month = "December"
  END SELECT

  day = Day_of_week(dateinfo(3), dateinfo(2), dateinfo(1))

  SELECT CASE(day)
    CASE(0)
      dayname = "Saturday"
    CASE(1)
      dayname = "Sunday"
    CASE(2)
      dayname = "Monday"
    CASE(3)
      dayname = "Tuesday"
    CASE(4)
      dayname = "Wednesday"
    CASE(5)
      dayname = "Thursday"
    CASE(6)
      dayname = "Friday"
  END SELECT

  WRITE(*,"(I0,A,I0,A,I0)") dateinfo(1),"-", dateinfo(2),"-", dateinfo(3)
  WRITE(*,"(4(A),I0,A,I0)") trim(dayname), ", ", trim(month), " ", dateinfo(3), ", ", dateinfo(1)

CONTAINS

  FUNCTION Day_of_week(d, m, y)
    INTEGER :: Day_of_week, j, k
    INTEGER, INTENT(IN) :: d, m, y

    j = y / 100
    k = MOD(y, 100)
    Day_of_week = MOD(d + (m+1)*26/10 + k + k/4 + j/4 + 5*j, 7)
  END FUNCTION Day_of_week

END PROGRAM DATE


      DOUBLE PRECISION FUNCTION DAMCON(JOB)
      INTEGER JOB
C
C     ADAPTED FROM BLAS SUBROUTINE SMACH/DMACH FOR ORACLS
C
C     SMACH COMPUTES MACHINE PARAMETERS OF FLOATING POINT
C     ARITHMETIC FOR USE IN TESTING ONLY.  NOT REQUIRED BY
C     LINPACK PROPER.
C
C     IF TROUBLE WITH AUTOMATIC COMPUTATION OF THESE QUANTITIES,
C     THEY CAN BE SET BY DIRECT ASSIGNMENT STATEMENTS.
C     ASSUME THE COMPUTER HAS
C
C        B = BASE OF ARITHMETIC
C        T = NUMBER OF BASE  B  DIGITS
C        L = SMALLEST POSSIBLE EXPONENT
C        U = LARGEST POSSIBLE EXPONENT
C
C     THEN
C
C        EPS = B**(1-T)
C        TINY = 100.0*B**(-L+T)
C        HUGE = 0.01*B**(U-T)
C
C     DMACH SAME AS SMACH EXCEPT T, L, U APPLY TO
C     DOUBLE PRECISION.
C
C     CMACH SAME AS SMACH EXCEPT IF COMPLEX DIVISION
C     IS DONE BY
C
C        1/(X+I*Y) = (X-I*Y)/(X**2+Y**2)
C
C     THEN
C
C        TINY = SQRT(TINY)
C        HUGE = SQRT(HUGE)
C
C **** ORACLS REQUIRES NUMBERING REVERSED FROM THAT USED BY LINPACK
C
C     JOB IS 3, 2 OR 1 FOR EPSILON, TINY AND HUGE, RESPECTIVELY.
C
      DOUBLE PRECISION EPS,TINY,HUGE,S
C
      EPS = 1.0D0
   10 EPS = EPS/2.0D0
      S = 1.0D0 + EPS
      IF (S .GT. 1.0D0) GO TO 10
      EPS = 2.0D0*EPS
C
      S = 1.0D0
   20 TINY = S
      S = S/16.0D0
      IF (S*1.0 .NE. 0.0D0) GO TO 20
      TINY = (TINY/EPS)*100.0
      HUGE = 1.0D0/TINY
C
      IF (JOB .EQ. 3) DAMCON = EPS
      IF (JOB .EQ. 2) DAMCON = TINY
      IF (JOB .EQ. 1) DAMCON = HUGE
      RETURN
      END


! parameter(nmax=10)
! parameter(nterms=8)
! parameter(npts=1000)
! common/coeff/cdprime,cm,cl,rey,sfact,vt
! common/path/xx(npts),y(nterms,npts)

subroutine rkdumb(vstart, nvar, x1, x2, nstep)

  ! Starting from initial values VSTART for NVAR functions, known at
  ! X1, use fourth-order Runge-Kutta to advance npts equal increments
  ! to X2.  The user supplied subroutine DERIVS(X,V,DVDX) evaluates
  ! derivatives.  Results are stored in the common block PATH.  Be sure
  ! to dimension the common block appropriately

  ! Routine taken from Numerical Recipes, 15.1, p. 554
  common/coeff/cdprime,cm,cl,rey,sfact,vt

  !set to the maximum number of functions
  parameter(nmax=10)
  parameter(nterms=8)
  parameter(npts=1000)
  !nterms functions; npts values
  common/path/xx(npts),y(nterms,npts)
  dimension vstart(nvar),v(nmax),dv(nmax)

  ! load starting values
  do i=1,nvar
     v(i)=vstart(i)
     y(i,1)=v(i)
  end do
  xx(1)=x1
  x=x1
  h=(x2-x1)/nstep

  ! take nsetp steps
  do k=1,nstep-1
     call derivs(x,v,dv)
     call rk4(v,dv,nvar,x,h,v)

     ! Commented out - replace with error code
     !if (x+h.eq.x)pause 'Stepsize not significant in RKDUMB'
     x=x+h
     !store intermediate steps
     xx(k+1)=x
     do i=1,nvar
        y(i,k+1)=v(i)
     end do

  end do
  return
end subroutine rkdumb


!*==ssysv_rk.f90  processed by SPAG 7.51RB at 20:08 on  3 Mar 2022
!> \brief  SSYSV_RK computes the solution to system of linear equations A * X = B for SY matrices
!
!  =========== DOCUMENTATION ===========
!
! Online html documentation available at
!            http://www.netlib.org/lapack/explore-html/
!
!> \htmlonly
!> Download SSYSV_RK + dependencies
!>
!> [TGZ]
!>
!> [ZIP]
!>
!> [TXT]
!> \endhtmlonly
!
!  Definition:
!  ===========
!
!       SUBROUTINE SSYSV_RK( UPLO, N, NRHS, A, LDA, E, IPIV, B, LDB,
!                            WORK, LWORK, INFO )
!
!       .. Scalar Arguments ..
!       CHARACTER          UPLO
!       INTEGER            INFO, LDA, LDB, LWORK, N, NRHS
!       ..
!       .. Array Arguments ..
!       INTEGER            IPIV( * )
!       REAL               A( LDA, * ), B( LDB, * ), E( * ), WORK( * )
!       ..
!
!
!> \par Purpose:
!  =============
!>
!> \verbatim
!> SSYSV_RK computes the solution to a real system of linear
!> equations A * X = B, where A is an N-by-N symmetric matrix
!> and X and B are N-by-NRHS matrices.
!>
!> The bounded Bunch-Kaufman (rook) diagonal pivoting method is used
!> to factor A as
!>    A = P*U*D*(U**T)*(P**T),  if UPLO = 'U', or
!>    A = P*L*D*(L**T)*(P**T),  if UPLO = 'L',
!> where U (or L) is unit upper (or lower) triangular matrix,
!> U**T (or L**T) is the transpose of U (or L), P is a permutation
!> matrix, P**T is the transpose of P, and D is symmetric and block
!> diagonal with 1-by-1 and 2-by-2 diagonal blocks.
!>
!> SSYTRF_RK is called to compute the factorization of a real
!> symmetric matrix.  The factored form of A is then used to solve
!> the system of equations A * X = B by calling BLAS3 routine SSYTRS_3.
!> \endverbatim
!
!  Arguments:
!  ==========
!
!> \param[in] UPLO
!> \verbatim
!>          UPLO is CHARACTER*1
!>          Specifies whether the upper or lower triangular part of the
!>          symmetric matrix A is stored:
!>          = 'U':  Upper triangle of A is stored;
!>          = 'L':  Lower triangle of A is stored.
!> \endverbatim
!>
!> \param[in] N
!> \verbatim
!>          N is INTEGER
!>          The number of linear equations, i.e., the order of the
!>          matrix A.  N >= 0.
!> \endverbatim
!>
!> \param[in] NRHS
!> \verbatim
!>          NRHS is INTEGER
!>          The number of right hand sides, i.e., the number of columns
!>          of the matrix B.  NRHS >= 0.
!> \endverbatim
!>
!> \param[in,out] A
!> \verbatim
!>          A is REAL array, dimension (LDA,N)
!>          On entry, the symmetric matrix A.
!>            If UPLO = 'U': the leading N-by-N upper triangular part
!>            of A contains the upper triangular part of the matrix A,
!>            and the strictly lower triangular part of A is not
!>            referenced.
!>
!>            If UPLO = 'L': the leading N-by-N lower triangular part
!>            of A contains the lower triangular part of the matrix A,
!>            and the strictly upper triangular part of A is not
!>            referenced.
!>
!>          On exit, if INFO = 0, diagonal of the block diagonal
!>          matrix D and factors U or L  as computed by SSYTRF_RK:
!>            a) ONLY diagonal elements of the symmetric block diagonal
!>               matrix D on the diagonal of A, i.e. D(k,k) = A(k,k);
!>               (superdiagonal (or subdiagonal) elements of D
!>                are stored on exit in array E), and
!>            b) If UPLO = 'U': factor U in the superdiagonal part of A.
!>               If UPLO = 'L': factor L in the subdiagonal part of A.
!>
!>          For more info see the description of DSYTRF_RK routine.
!> \endverbatim
!>
!> \param[in] LDA
!> \verbatim
!>          LDA is INTEGER
!>          The leading dimension of the array A.  LDA >= max(1,N).
!> \endverbatim
!>
!> \param[out] E
!> \verbatim
!>          E is REAL array, dimension (N)
!>          On exit, contains the output computed by the factorization
!>          routine DSYTRF_RK, i.e. the superdiagonal (or subdiagonal)
!>          elements of the symmetric block diagonal matrix D
!>          with 1-by-1 or 2-by-2 diagonal blocks, where
!>          If UPLO = 'U': E(i) = D(i-1,i), i=2:N, E(1) is set to 0;
!>          If UPLO = 'L': E(i) = D(i+1,i), i=1:N-1, E(N) is set to 0.
!>
!>          NOTE: For 1-by-1 diagonal block D(k), where
!>          1 <= k <= N, the element E(k) is set to 0 in both
!>          UPLO = 'U' or UPLO = 'L' cases.
!>
!>          For more info see the description of DSYTRF_RK routine.
!> \endverbatim
!>
!> \param[out] IPIV
!> \verbatim
!>          IPIV is INTEGER array, dimension (N)
!>          Details of the interchanges and the block structure of D,
!>          as determined by SSYTRF_RK.
!>
!>          For more info see the description of DSYTRF_RK routine.
!> \endverbatim
!>
!> \param[in,out] B
!> \verbatim
!>          B is REAL array, dimension (LDB,NRHS)
!>          On entry, the N-by-NRHS right hand side matrix B.
!>          On exit, if INFO = 0, the N-by-NRHS solution matrix X.
!> \endverbatim
!>
!> \param[in] LDB
!> \verbatim
!>          LDB is INTEGER
!>          The leading dimension of the array B.  LDB >= max(1,N).
!> \endverbatim
!>
!> \param[out] WORK
!> \verbatim
!>          WORK is REAL array, dimension ( MAX(1,LWORK) ).
!>          Work array used in the factorization stage.
!>          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
!> \endverbatim
!>
!> \param[in] LWORK
!> \verbatim
!>          LWORK is INTEGER
!>          The length of WORK.  LWORK >= 1. For best performance
!>          of factorization stage LWORK >= max(1,N*NB), where NB is
!>          the optimal blocksize for DSYTRF_RK.
!>
!>          If LWORK = -1, then a workspace query is assumed;
!>          the routine only calculates the optimal size of the WORK
!>          array for factorization stage, returns this value as
!>          the first entry of the WORK array, and no error message
!>          related to LWORK is issued by XERBLA.
!> \endverbatim
!>
!> \param[out] INFO
!> \verbatim
!>          INFO is INTEGER
!>          = 0: successful exit
!>
!>          < 0: If INFO = -k, the k-th argument had an illegal value
!>
!>          > 0: If INFO = k, the matrix A is singular, because:
!>                 If UPLO = 'U': column k in the upper
!>                 triangular part of A contains all zeros.
!>                 If UPLO = 'L': column k in the lower
!>                 triangular part of A contains all zeros.
!>
!>               Therefore D(k,k) is exactly zero, and superdiagonal
!>               elements of column k of U (or subdiagonal elements of
!>               column k of L ) are all zeros. The factorization has
!>               been completed, but the block diagonal matrix D is
!>               exactly singular, and division by zero will occur if
!>               it is used to solve a system of equations.
!>
!>               NOTE: INFO only stores the first occurrence of
!>               a singularity, any subsequent occurrence of singularity
!>               is not stored in INFO even though the factorization
!>               always completes.
!> \endverbatim
!
!  Authors:
!  ========
!
!> \author Univ. of Tennessee
!> \author Univ. of California Berkeley
!> \author Univ. of Colorado Denver
!> \author NAG Ltd.
!
!> \date December 2016
!
!> \ingroup singleSYsolve
!
!> \par Contributors:
!  ==================
!>
!> \verbatim
!>
!>  December 2016,  Igor Kozachenko,
!>                  Computer Science Division,
!>                  University of California, Berkeley
!>
!>  September 2007, Sven Hammarling, Nicholas J. Higham, Craig Lucas,
!>                  School of Mathematics,
!>                  University of Manchester
!>
!> \endverbatim
!
!  =====================================================================
      SUBROUTINE SSYSV_RK(Uplo,N,Nrhs,A,Lda,E,Ipiv,B,Ldb,Work,Lwork,    &
     &                    Info)
      IMPLICIT NONE
!*--SSYSV_RK232
!
!  -- LAPACK driver routine (version 3.7.0) --
!  -- LAPACK is a software package provided by Univ. of Tennessee,    --
!  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
!     December 2016
!
!     .. Scalar Arguments ..
      CHARACTER Uplo
      INTEGER Info , Lda , Ldb , Lwork , N , Nrhs
!     ..
!     .. Array Arguments ..
      INTEGER Ipiv(*)
      REAL A(Lda,*) , B(Ldb,*) , E(*) , Work(*)
!     ..
!
!  =====================================================================
!
!     .. Local Scalars ..
      LOGICAL lquery
      INTEGER lwkopt
!     ..
!     .. External Functions ..
      LOGICAL LSAME
      EXTERNAL LSAME
!     ..
!     .. External Subroutines ..
      EXTERNAL XERBLA , SSYTRF_RK , SSYTRS_3
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC MAX
!     ..
!     .. Executable Statements ..
!
!     Test the input parameters.
!
      Info = 0
      lquery = (Lwork==-1)
      IF ( .NOT.LSAME(Uplo,'U') .AND. .NOT.LSAME(Uplo,'L') ) THEN
         Info = -1
      ELSEIF ( N<0 ) THEN
         Info = -2
      ELSEIF ( Nrhs<0 ) THEN
         Info = -3
      ELSEIF ( Lda<MAX(1,N) ) THEN
         Info = -5
      ELSEIF ( Ldb<MAX(1,N) ) THEN
         Info = -9
      ELSEIF ( Lwork<1 .AND. .NOT.lquery ) THEN
         Info = -11
      ENDIF
!
      IF ( Info==0 ) THEN
         IF ( N==0 ) THEN
            lwkopt = 1
         ELSE
            CALL SSYTRF_RK(Uplo,N,A,Lda,E,Ipiv,Work,-1,Info)
            lwkopt = Work(1)
         ENDIF
         Work(1) = lwkopt
      ENDIF
!
      IF ( Info/=0 ) THEN
         CALL XERBLA('SSYSV_RK ',-Info)
         RETURN
      ELSEIF ( lquery ) THEN
         RETURN
      ENDIF
!
!     Compute the factorization A = P*U*D*(U**T)*(P**T) or
!     A = P*U*D*(U**T)*(P**T).
!
      CALL SSYTRF_RK(Uplo,N,A,Lda,E,Ipiv,Work,Lwork,Info)
!
!
!        Solve the system A*X = B with BLAS3 solver, overwriting B with X.
!
!
      IF ( Info==0 ) CALL SSYTRS_3(Uplo,N,Nrhs,A,Lda,E,Ipiv,B,Ldb,Info)
!
      Work(1) = lwkopt
!
!
!     End of SSYSV_RK
!
      END SUBROUTINE SSYSV_RK


      SUBROUTINE ORTCK (X,MASS,IBUF,NUM,NDIM,GM,ACCUM,EPS)
C
C     ORTCK WILL GENERATE THE GENERALIZED MASS MATRIX FOR CLOSE ROOTS
C     AND MAKE THE EPSILON TEST TO DETERMINE IF THE VECTORS SHOULD BE
C     ORTHOGONALIZED
C
      DOUBLE PRECISION   ACCUM(1)
      DIMENSION          IBUF(1)   ,X(NDIM,1),GM(NUM,1),IM(7)
C     COMMON   /DESCRP/  LENGTH    ,MAJOR(1)
      COMMON   /ZNTPKX/  Z(4)      ,II       ,IEOL
      COMMON   /NAMES /  RD        ,RDREW    ,WRT      ,WRTREW   ,
     1                   REW       ,NOREW    ,EOFNRW   ,RSP
C
      IDEN  = 0
      IM(1) = MASS
      CALL RDTRL (IM)
      IF (IM(4) .EQ. 8) IDEN = 1
      IF (IDEN  .EQ. 1) GO TO 10
      CALL GOPEN (MASS,IBUF,0)
   10 K = 1
   20 DO 30 I = 1,NUM
      DO 30 J = 1,NUM
   30 GM(I,J) = 0.
      DO 110 I = 1,NDIM
      DO 40 J = 1,NUM
   40 ACCUM(J) = 0.D0
      IF (IDEN .EQ. 1) GO TO 80
      CALL INTPK (*110,MASS,0,RSP,0)
   50 IF (IEOL .EQ. 1)GO TO 90
      CALL ZNTPKI
   60 DO 70 J = 1,NUM
   70 ACCUM(J) = ACCUM(J) + Z(1)*X(II,J)
      GO TO 50
C
C     IDENTITY
C
   80 IEOL = 1
      II   = I
      Z(1) = 1.0
      GO TO 60
   90 DO 100 J = 1,NUM
      DO 100 M = 1,NUM
  100 GM(J,M) = GM(J,M) + ACCUM(J)*X(I,M)
  110 CONTINUE
      IF (IDEN .EQ. 1) GO TO 120
      CALL REWIND (MASS)
      CALL SKPREC (MASS,1)
  120 GM(1,1) = SQRT(GM(1,1))
      DO 130 I = 2,NUM
      GM(I,I) = SQRT(GM(I,I))
      II = I - 1
      DO 130 J = 1,II
  130 GM(I,J) = GM(I,J)/(GM(I,I)*GM(J,J))
      DO 140 I = 1,NUM
      DO 140 J = 1,NDIM
  140 X(J,I) = X(J,I)/GM(I,I)
      J = 0
  150 DO 170 KK = 1,K
      IF (ABS(GM(K+1,KK)) .LT. EPS) GO TO 170
      J = 1
      DO 160 I = 1,NDIM
  160 X(I,K+1) = X(I,K+1) - GM(K+1,KK)*X(I,KK)
  170 CONTINUE
      K = K + 1
      IF (K .GE. NUM) GO TO 180
      IF (J .EQ.   0) GO TO 150
      GO TO 20
  180 IF (IDEN .EQ. 1) GO TO 190
      CALL CLOSE (MASS,REW)
  190 RETURN
      END


      subroutine qrfac(m,n,a,lda,pivot,ipvt,lipvt,rdiag,acnorm,wa)
      integer m,n,lda,lipvt
      integer ipvt(lipvt)
      logical pivot
      real a(lda,n),rdiag(n),acnorm(n),wa(n)
c     **********
c
c     subroutine qrfac
c
c     this subroutine uses householder transformations with column
c     pivoting (optional) to compute a qr factorization of the
c     m by n matrix a. that is, qrfac determines an orthogonal
c     matrix q, a permutation matrix p, and an upper trapezoidal
c     matrix r with diagonal elements of nonincreasing magnitude,
c     such that a*p = q*r. the householder transformation for
c     column k, k = 1,2,...,min(m,n), is of the form
c
c                           t
c           i - (1/u(k))*u*u
c
c     where u has zeros in the first k-1 positions. the form of
c     this transformation and the method of pivoting first
c     appeared in the corresponding linpack subroutine.
c
c     the subroutine statement is
c
c       subroutine qrfac(m,n,a,lda,pivot,ipvt,lipvt,rdiag,acnorm,wa)
c
c     where
c
c       m is a positive integer input variable set to the number
c         of rows of a.
c
c       n is a positive integer input variable set to the number
c         of columns of a.
c
c       a is an m by n array. on input a contains the matrix for
c         which the qr factorization is to be computed. on output
c         the strict upper trapezoidal part of a contains the strict
c         upper trapezoidal part of r, and the lower trapezoidal
c         part of a contains a factored form of q (the non-trivial
c         elements of the u vectors described above).
c
c       lda is a positive integer input variable not less than m
c         which specifies the leading dimension of the array a.
c
c       pivot is a logical input variable. if pivot is set true,
c         then column pivoting is enforced. if pivot is set false,
c         then no column pivoting is done.
c
c       ipvt is an integer output array of length lipvt. ipvt
c         defines the permutation matrix p such that a*p = q*r.
c         column j of p is column ipvt(j) of the identity matrix.
c         if pivot is false, ipvt is not referenced.
c
c       lipvt is a positive integer input variable. if pivot is false,
c         then lipvt may be as small as 1. if pivot is true, then
c         lipvt must be at least n.
c
c       rdiag is an output array of length n which contains the
c         diagonal elements of r.
c
c       acnorm is an output array of length n which contains the
c         norms of the corresponding columns of the input matrix a.
c         if this information is not needed, then acnorm can coincide
c         with rdiag.
c
c       wa is a work array of length n. if pivot is false, then wa
c         can coincide with rdiag.
c
c     subprograms called
c
c       minpack-supplied ... spmpar,enorm
c
c       fortran-supplied ... amax1,sqrt,min0
c
c     argonne national laboratory. minpack project. march 1980.
c     burton s. garbow, kenneth e. hillstrom, jorge j. more
c
c     **********
      integer i,j,jp1,k,kmax,minmn
      real ajnorm,epsmch,one,p05,sum,temp,zero
      real spmpar,enorm
      data one,p05,zero /1.0e0,5.0e-2,0.0e0/
c
c     epsmch is the machine precision.
c
      epsmch = spmpar(1)
c
c     compute the initial column norms and initialize several arrays.
c
      do 10 j = 1, n
         acnorm(j) = enorm(m,a(1,j))
         rdiag(j) = acnorm(j)
         wa(j) = rdiag(j)
         if (pivot) ipvt(j) = j
   10    continue
c
c     reduce a to r with householder transformations.
c
      minmn = min0(m,n)
      do 110 j = 1, minmn
         if (.not.pivot) go to 40
c
c        bring the column of largest norm into the pivot position.
c
         kmax = j
         do 20 k = j, n
            if (rdiag(k) .gt. rdiag(kmax)) kmax = k
   20       continue
         if (kmax .eq. j) go to 40
         do 30 i = 1, m
            temp = a(i,j)
            a(i,j) = a(i,kmax)
            a(i,kmax) = temp
   30       continue
         rdiag(kmax) = rdiag(j)
         wa(kmax) = wa(j)
         k = ipvt(j)
         ipvt(j) = ipvt(kmax)
         ipvt(kmax) = k
   40    continue
c
c        compute the householder transformation to reduce the
c        j-th column of a to a multiple of the j-th unit vector.
c
         ajnorm = enorm(m-j+1,a(j,j))
         if (ajnorm .eq. zero) go to 100
         if (a(j,j) .lt. zero) ajnorm = -ajnorm
         do 50 i = j, m
            a(i,j) = a(i,j)/ajnorm
   50       continue
         a(j,j) = a(j,j) + one
c
c        apply the transformation to the remaining columns
c        and update the norms.
c
         jp1 = j + 1
         if (n .lt. jp1) go to 100
         do 90 k = jp1, n
            sum = zero
            do 60 i = j, m
               sum = sum + a(i,j)*a(i,k)
   60          continue
            temp = sum/a(j,j)
            do 70 i = j, m
               a(i,k) = a(i,k) - temp*a(i,j)
   70          continue
            if (.not.pivot .or. rdiag(k) .eq. zero) go to 80
            temp = a(j,k)/rdiag(k)
            rdiag(k) = rdiag(k)*sqrt(amax1(zero,one-temp**2))
            if (p05*(rdiag(k)/wa(k))**2 .gt. epsmch) go to 80
            rdiag(k) = enorm(m-j,a(jp1,k))
            wa(k) = rdiag(k)
   80       continue
   90       continue
  100    continue
         rdiag(j) = -ajnorm
  110    continue
      return
c
c     last card of subroutine qrfac.
c
      end


	FUNCTION PS_SEPA  ( datain, nparm, clev, ivcord )
C************************************************************************
C* PS_SEPA								*
C*									*
C* This function computes the separation in mb between bounding		*
C* isentropic levels.  The default layer width is 5 K.			*
C*									*
C* REAL PS_SEPA  ( DATAIN, NPARM, CLEV, IVCORD )			*
C*									*
C* Input parameters:							*
C*	DATAIN		REAL		Station data			*
C*	NPARM		INTEGER		Number of data set parameters	*
C*	CLEV		REAL		Vertical level			*
C*	IVCORD		INTEGER 	Vertical coordinate number	*
C*									*
C* Output parameters:							*
C*	PS_SEPA		REAL		Separation (mb)			*
C**									*
C* Log:									*
C* J. Nielsen/SUNYA	 8/90						*
C************************************************************************
	INCLUDE		'GEMPRM.PRM'
C*
	REAL		stndl (10), stndb (10), stndt (10)
C*
	INCLUDE		'ERMISS.FNC'
C-----------------------------------------------------------------------------
	PS_SEPA = RMISSD
C
C*	Get data over a 5 K layer, unless requested otherwise.
C
	dfdpth = 5.
	idfcrd = 2
	CALL PC_DPTH  ( datain, nparm, clev, ivcord, dfdpth, idfcrd, 1,
     +			depth, idcord, stndl, stndb, stndt, ier )
C
C*	Check for RETURN conditions.
C
	IF  ( ( ier .ne. 0 ) .or. ERMISS ( stndt (1) ) .or.
     +	      ERMISS ( stndb (1) ) )  RETURN
	deltap = stndt (1) - stndb (1)
	IF  ( deltap .eq. 0.0 )  RETURN
	PS_SEPA = deltap
C*
	RETURN
	END


c
c     cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
      subroutine congauss(ebot,etop,eibot,egrd,dele1,ngauss,nume,
     >                    pi,ipepts,iprint,istop)
c     ================================================================
c
      implicit   none
c
      character  sname*20
      character  istop*32
c
c     ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
!     include    'atom_param.h'
      integer ipepts
c     ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
c
      integer    nume
      integer    ngauss
      integer    ie
      integer    iprint
c
      real*8     xgs(ipepts)
      real*8     wgs(ipepts)
      real*8     ebot
      real*8     etop
      real*8     eibot
      real*8     pi
      real*8     erad
      real*8     half
      real*8     one
c
      complex*16 egrd(ipepts)
      complex*16 dele1(ipepts)
      complex*16 zzero
      complex*16 ihalfpi
      complex*16 czero
      complex*16 cone
      complex*16 sqrtm1
c
      parameter  (half=0.5d0)
      parameter  (one=1.0d0)
      parameter  (czero=(0.0d0,0.0d0))
      parameter  (cone=(1.0d0,0.0d0))
      parameter  (sqrtm1=(0.0d0,1.0d0))
      parameter  (sname='congauss')
c
c     ****************************************************************
c     constructs semi-circle energy contour
c
c                               . ! . Im(e)
c                           .     !     .
c                       .         !         .
c                     .           !           .
c                   .             !             .
c                  .              !              .
c          -----------------------!-------------------------
c              ebot               !    Real(e)   etop
c
c
c     ebot      : bottom of the contour on the real axis..........
c     etop      : top of the contour on the real axis.............
c     ngauss    : total number of desired points and weights for...
c                 Gauss-Legendre quadrature.......................
c     nume      : = ngauss
c     iprint    : print level control (>0 for print of energies)..
c
c     requires  : ebot,etop,ngauss,iprint
c     returns   : (egrd(ie),dele1(ie),ie=1,nume)
c     ****************************************************************
c
c     ================================================================
c     set up the gaussian integration points..........................
      if(ngauss+1.gt.ipepts) then
         write(6,'(/,'' CONGAUSS:: ngauss+1.gt.ipepts'',2i5)')
     >                             ngauss,ipepts
         call fstop(sname)
      endif
c
c     ================================================================
c     set nume equal to number of points on grid i.e. ngauss..........
      nume=ngauss
c     ----------------------------------------------------------------
      call gauss_legendre_points(-one,one,xgs,wgs,ngauss)
c     ----------------------------------------------------------------
c
c     ================================================================
c     loop over energy grid for gaussian integration.................
      erad  = half*(etop-ebot)
      ihalfpi=sqrtm1*half*pi
      do ie=1,ngauss
         zzero =  erad*exp( ihalfpi*(one-xgs(ie)) )
         egrd(ie) = half*(etop+ebot) + zzero
         dele1(ie)=-ihalfpi*zzero*wgs(ie)
      enddo
c
c     ================================================================
c     add an extra energy point to be used in extrapolating E_f.......
      nume=nume+1
      egrd(nume)=cone*etop+sqrtm1*eibot
      dele1(nume)=czero
c
c     ================================================================
c     write out grid and return.......................................
      if(iprint.ge.1) then
         write(6,'(/,'' CONGAUSS:: Bottom of contour'',
     >             t40,''='',f10.5)')   ebot
         write(6,'(12x,''Top    of contour'',
     >             t40,''='',f10.5)')   etop
         write(6,'(12x,''Number of energies'',
     >             t40,''='',i5)') nume
      endif
      if(iprint.ge.2) then
         write(6,'(12x,''n='',i5,'' e='',2e12.4,'' de='',2d12.4)')
     >   (ie,egrd(ie),dele1(ie),ie=1,nume)
      endif
c
c     ================================================================
      if(istop.eq.sname) then
         call fstop(sname)
      else
         return
      endif
c
      end


      subroutine fnegdef(a)
c     force negative definite 2nd order polynomial
      real*4 a(10)
      real*4 w(3,3),wt(3,3),g(3,3),b(3,3)
      logical*4 ltest

      g(1,1)=a(10)
      g(2,2)=a(7)
      g(3,3)=a(5)
      g(1,2)=a(9)/2.
      g(1,3)=a(8)/2.
      g(2,3)=a(6)/2.
      g(2,1)=g(1,2)
      g(3,1)=g(1,3)
      g(3,2)=g(2,3)

      ltest=.false.
      call eigen(g,w,3)
               write(*,"('fnegdef: eigenvalues',3f10.6)")(g(i,i),i=1,3)
      do 1 i=1,3
      if(g(i,i).gt.0.0)then
        ltest=.true.
        g(i,i)=0.0
      endif
    1 continue
      if(ltest)write(*,"('      -> eigenvalues',3f10.6)")(g(i,i),i=1,3)

      call transpos(w,wt,3)
      call matmul(w,g,b,3)
      call matmul(b,wt,g,3)

      a(10)=g(1,1)
      a(7)= g(2,2)
      a(5)= g(3,3)
      a(9)= g(1,2)*2.
      a(8)= g(1,3)*2.
      a(6)= g(2,3)*2.

      return
      end


*     SB09MD EXAMPLE PROGRAM TEXT
*     Copyright (c) 2002-2020 NICONET e.V.
*
*     .. Parameters ..
      INTEGER          NIN, NOUT
      PARAMETER        ( NIN = 5, NOUT = 6 )
      INTEGER          NMAX, NCMAX, NBMAX
      PARAMETER        ( NMAX = 20, NCMAX = 20, NBMAX = 20 )
      INTEGER          LDH1, LDH2, LDSS, LDSE, LDPRE
      PARAMETER        ( LDH1 = NCMAX, LDH2 = NCMAX, LDSS = NCMAX,
     $                   LDSE = NCMAX, LDPRE = NCMAX )
*     .. Local Scalars ..
      DOUBLE PRECISION TOL
      INTEGER          I, INFO, J, N, NB, NC
*     .. Local Arrays ..
      DOUBLE PRECISION H1(LDH1,NMAX*NBMAX), H2(LDH2,NMAX*NBMAX),
     $                 PRE(LDPRE,NBMAX), SE(LDSE,NBMAX), SS(LDSS,NBMAX)
*     .. External Subroutines ..
      EXTERNAL         SB09MD
*     .. Executable Statements ..
*
      WRITE ( NOUT, FMT = 99999 )
*     Skip the heading in the data file and read the data.
      READ ( NIN, FMT = '()' )
      READ ( NIN, FMT = * ) N, NC, NB, TOL
      IF ( N.LT.0 .OR. N.GT.NMAX ) THEN
         WRITE ( NOUT, FMT = 99993 ) N
      ELSE IF ( NB.LT.0 .OR. NB.GT.NBMAX ) THEN
         WRITE ( NOUT, FMT = 99992 ) NB
      ELSE IF ( NC.LT.0 .OR. NC.GT.NCMAX ) THEN
         WRITE ( NOUT, FMT = 99991 ) NC
      ELSE
         READ ( NIN, FMT = * ) ( ( H1(I,J), I = 1,NC ), J = 1,N*NB )
         READ ( NIN, FMT = * ) ( ( H2(I,J), I = 1,NC ), J = 1,N*NB )
*        Compare the given sequences and evaluate their closeness.
         CALL SB09MD( N, NC, NB, H1, LDH1, H2, LDH2, SS, LDSS, SE, LDSE,
     $                PRE, LDPRE, TOL, INFO )
*
         IF ( INFO.NE.0 ) THEN
            WRITE ( NOUT, FMT = 99998 ) INFO
         ELSE
            WRITE ( NOUT, FMT = 99997 )
            DO 20 I = 1, NC
               WRITE ( NOUT, FMT = 99996 ) ( SS(I,J), J = 1,NB )
   20       CONTINUE
            WRITE ( NOUT, FMT = 99995 )
            DO 40 I = 1, NC
               WRITE ( NOUT, FMT = 99996 ) ( SE(I,J), J = 1,NB )
   40       CONTINUE
            WRITE ( NOUT, FMT = 99994 )
            DO 60 I = 1, NC
               WRITE ( NOUT, FMT = 99996 ) ( PRE(I,J), J = 1,NB )
   60       CONTINUE
         END IF
      END IF
      STOP
*
99999 FORMAT (' SB09MD EXAMPLE PROGRAM RESULTS',/1X)
99998 FORMAT (' INFO on exit from SB09MD = ',I2)
99997 FORMAT (' The sum-of-squares matrix SS is ')
99996 FORMAT (20(1X,F8.4))
99995 FORMAT (/' The quadratic error matrix SE is ')
99994 FORMAT (/' The percentage relative error matrix PRE is ')
99993 FORMAT (/' N is out of range.',/' N = ',I5)
99992 FORMAT (/' NB is out of range.',/' NB = ',I5)
99991 FORMAT (/' NC is out of range.',/' NC = ',I5)
      END


      SUBROUTINE TC04AD( LERI, M, P, INDEX, PCOEFF, LDPCO1, LDPCO2,
     $                   QCOEFF, LDQCO1, LDQCO2, N, RCOND, A, LDA, B,
     $                   LDB, C, LDC, D, LDD, IWORK, DWORK, LDWORK,
     $                   INFO )
C
C     SLICOT RELEASE 5.5.
C
C     Copyright (c) 2002-2012 NICONET e.V.
C
C     PURPOSE
C
C     To find a state-space representation (A,B,C,D) with the same
C     transfer matrix T(s) as that of a given left or right polynomial
C     matrix representation, i.e.
C
C        C*inv(sI-A)*B + D = T(s) = inv(P(s))*Q(s) = Q(s)*inv(P(s)).
C
C     ARGUMENTS
C
C     Mode Parameters
C
C     LERI    CHARACTER*1
C             Indicates whether a left polynomial matrix representation
C             or a right polynomial matrix representation is input as
C             follows:
C             = 'L':  A left matrix fraction is input;
C             = 'R':  A right matrix fraction is input.
C
C     Input/Output Parameters
C
C     M       (input) INTEGER
C             The number of system inputs.  M >= 0.
C
C     P       (input) INTEGER
C             The number of system outputs.  P >= 0.
C
C     INDEX   (input) INTEGER array, dimension (MAX(M,P))
C             If LERI = 'L', INDEX(I), I = 1,2,...,P, must contain the
C             maximum degree of the polynomials in the I-th row of the
C             denominator matrix P(s) of the given left polynomial
C             matrix representation.
C             If LERI = 'R', INDEX(I), I = 1,2,...,M, must contain the
C             maximum degree of the polynomials in the I-th column of
C             the denominator matrix P(s) of the given right polynomial
C             matrix representation.
C
C     PCOEFF  (input) DOUBLE PRECISION array, dimension
C             (LDPCO1,LDPCO2,kpcoef), where kpcoef = MAX(INDEX(I)) + 1.
C             If LERI = 'L' then porm = P, otherwise porm = M.
C             The leading porm-by-porm-by-kpcoef part of this array must
C             contain the coefficients of the denominator matrix P(s).
C             PCOEFF(I,J,K) is the coefficient in s**(INDEX(iorj)-K+1)
C             of polynomial (I,J) of P(s), where K = 1,2,...,kpcoef; if
C             LERI = 'L' then iorj = I, otherwise iorj = J.
C             Thus for LERI = 'L', P(s) =
C             diag(s**INDEX(I))*(PCOEFF(.,.,1)+PCOEFF(.,.,2)/s+...).
C             If LERI = 'R', PCOEFF is modified by the routine but
C             restored on exit.
C
C     LDPCO1  INTEGER
C             The leading dimension of array PCOEFF.
C             LDPCO1 >= MAX(1,P) if LERI = 'L',
C             LDPCO1 >= MAX(1,M) if LERI = 'R'.
C
C     LDPCO2  INTEGER
C             The second dimension of array PCOEFF.
C             LDPCO2 >= MAX(1,P) if LERI = 'L',
C             LDPCO2 >= MAX(1,M) if LERI = 'R'.
C
C     QCOEFF  (input) DOUBLE PRECISION array, dimension
C             (LDQCO1,LDQCO2,kpcoef)
C             If LERI = 'L' then porp = M, otherwise porp = P.
C             The leading porm-by-porp-by-kpcoef part of this array must
C             contain the coefficients of the numerator matrix Q(s).
C             QCOEFF(I,J,K) is defined as for PCOEFF(I,J,K).
C             If LERI = 'R', QCOEFF is modified by the routine but
C             restored on exit.
C
C     LDQCO1  INTEGER
C             The leading dimension of array QCOEFF.
C             LDQCO1 >= MAX(1,P)   if LERI = 'L',
C             LDQCO1 >= MAX(1,M,P) if LERI = 'R'.
C
C     LDQCO2  INTEGER
C             The second dimension of array QCOEFF.
C             LDQCO2 >= MAX(1,M)   if LERI = 'L',
C             LDQCO2 >= MAX(1,M,P) if LERI = 'R'.
C
C     N       (output) INTEGER
C             The order of the resulting state-space representation.
C                          porm
C             That is, N = SUM INDEX(I).
C                          I=1
C
C     RCOND   (output) DOUBLE PRECISION
C             The estimated reciprocal of the condition number of the
C             leading row (if LERI = 'L') or the leading column (if
C             LERI = 'R') coefficient matrix of P(s).
C             If RCOND is nearly zero, P(s) is nearly row or column
C             non-proper.
C
C     A       (output) DOUBLE PRECISION array, dimension (LDA,N)
C             The leading N-by-N part of this array contains the state
C             dynamics matrix A.
C
C     LDA     INTEGER
C             The leading dimension of array A.  LDA >= MAX(1,N).
C
C     B       (output) DOUBLE PRECISION array, dimension (LDB,MAX(M,P))
C             The leading N-by-M part of this array contains the
C             input/state matrix B; the remainder of the leading
C             N-by-MAX(M,P) part is used as internal workspace.
C
C     LDB     INTEGER
C             The leading dimension of array B.  LDB >= MAX(1,N).
C
C     C       (output) DOUBLE PRECISION array, dimension (LDC,N)
C             The leading P-by-N part of this array contains the
C             state/output matrix C; the remainder of the leading
C             MAX(M,P)-by-N part is used as internal workspace.
C
C     LDC     INTEGER
C             The leading dimension of array C.  LDC >= MAX(1,M,P).
C
C     D       (output) DOUBLE PRECISION array, dimension (LDD,MAX(M,P))
C             The leading P-by-M part of this array contains the direct
C             transmission matrix D; the remainder of the leading
C             MAX(M,P)-by-MAX(M,P) part is used as internal workspace.
C
C     LDD     INTEGER
C             The leading dimension of array D.  LDD >= MAX(1,M,P).
C
C     Workspace
C
C     IWORK   INTEGER array, dimension (2*MAX(M,P))
C
C     DWORK   DOUBLE PRECISION array, dimension (LDWORK)
C             On exit, if INFO = 0, DWORK(1) returns the optimal value
C             of LDWORK.
C
C     LDWORK  INTEGER
C             The length of the array DWORK.
C             LDWORK >= MAX(1,MAX(M,P)*(MAX(M,P)+4)).
C             For optimum performance LDWORK should be larger.
C
C     Error Indicator
C
C     INFO    INTEGER
C             = 0:  successful exit;
C             < 0:  if INFO = -i, the i-th argument had an illegal
C                   value;
C             = 1:  if P(s) is not row (if LERI = 'L') or column
C                   (if LERI = 'R') proper. Consequently, no state-space
C                   representation is calculated.
C
C     METHOD
C
C     The method for a left matrix fraction will be described here;
C     right matrix fractions are dealt with by obtaining the dual left
C     polynomial matrix representation and constructing an equivalent
C     state-space representation for this. The first step is to check
C     if the denominator matrix P(s) is row proper; if it is not then
C     the routine returns with the Error Indicator (INFO) set to 1.
C     Otherwise, Wolovich's Observable  Structure Theorem is used to
C     construct a state-space representation (A,B,C,D) in observable
C     companion form. The sizes of the blocks of matrix A and matrix C
C     here are precisely the row degrees of P(s), while their
C     'non-trivial' columns are given easily from its coefficients.
C     Similarly, the matrix D is obtained from the leading coefficients
C     of P(s) and of the numerator matrix Q(s), while matrix B is given
C     by the relation Sbar(s)B = Q(s) - P(s)D, where Sbar(s) is a
C     polynomial matrix whose (j,k)(th) element is given by
C
C                  j-u(k-1)-1
C               ( s           , j = u(k-1)+1,u(k-1)+2,....,u(k)
C     Sbar    = (
C        j,k    (           0 , otherwise
C
C             k
C     u(k) = SUM d , k = 1,2,...,M and d ,d ,...,d  are the
C            i=1  i                     1  2      M
C     controllability indices. For convenience in solving this, C' and B
C     are initially set up to contain the coefficients of P(s) and Q(s),
C     respectively, stored by rows.
C
C     REFERENCES
C
C     [1] Wolovich, W.A.
C         Linear Multivariate Systems, (Theorem 4.3.3).
C         Springer-Verlag, 1974.
C
C     NUMERICAL ASPECTS
C                               3
C     The algorithm requires 0(N ) operations.
C
C     CONTRIBUTOR
C
C     Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Dec. 1996.
C     Supersedes Release 2.0 routine TC01BD by T.W.C.Williams, Kingston
C     Polytechnic, United Kingdom, March 1982.
C
C     REVISIONS
C
C     February 22, 1998 (changed the name of TC01ND).
C     May 12, 1998.
C
C     KEYWORDS
C
C     Coprime matrix fraction, elementary polynomial operations,
C     polynomial matrix, state-space representation, transfer matrix.
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION  ZERO, ONE
      PARAMETER         ( ZERO = 0.0D0, ONE = 1.0D0 )
C     .. Scalar Arguments ..
      CHARACTER         LERI
      INTEGER           INFO, LDA, LDB, LDC, LDD, LDPCO1, LDPCO2,
     $                  LDQCO1, LDQCO2, LDWORK, M, N, P
      DOUBLE PRECISION  RCOND
C     .. Array Arguments ..
      INTEGER           INDEX(*), IWORK(*)
      DOUBLE PRECISION  A(LDA,*), B(LDB,*), C(LDC,*), D(LDD,*),
     $                  DWORK(*), PCOEFF(LDPCO1,LDPCO2,*),
     $                  QCOEFF(LDQCO1,LDQCO2,*)
C     .. Local Scalars ..
      LOGICAL           LLERI
      INTEGER           I, IA, IBIAS, J, JA, JC, JW, JWORK, LDW, K,
     $                  KPCOEF, KSTOP, MAXIND, MINDEX, MWORK, PWORK,
     $                  WRKOPT
      DOUBLE PRECISION  DWNORM
C     .. External Functions ..
      LOGICAL           LSAME
      DOUBLE PRECISION  DLAMCH, DLANGE
      EXTERNAL          LSAME, DLAMCH, DLANGE
C     .. External Subroutines ..
      EXTERNAL          AB07MD, DCOPY, DGECON, DGEMM, DGETRF, DGETRI,
     $                  DGETRS, DLACPY, DLASET, TC01OD, XERBLA
C     .. Intrinsic Functions ..
      INTRINSIC         INT, MAX
C     .. Executable Statements ..
C
      INFO = 0
      LLERI = LSAME( LERI, 'L' )
      MINDEX = MAX( M, P )
C
C     Test the input scalar arguments.
C
      IF( .NOT.LLERI .AND. .NOT.LSAME( LERI, 'R' ) ) THEN
         INFO = -1
      ELSE IF( M.LT.0 ) THEN
         INFO = -2
      ELSE IF( P.LT.0 ) THEN
         INFO = -3
      ELSE IF( ( LLERI .AND. LDPCO1.LT.MAX( 1, P ) ) .OR.
     $    ( .NOT.LLERI .AND. LDPCO1.LT.MAX( 1, M ) ) ) THEN
         INFO = -6
      ELSE IF( ( LLERI .AND. LDPCO2.LT.MAX( 1, P ) ) .OR.
     $    ( .NOT.LLERI .AND. LDPCO2.LT.MAX( 1, M ) ) ) THEN
         INFO = -7
      ELSE IF( ( LLERI .AND. LDQCO1.LT.MAX( 1, P ) ) .OR.
     $    ( .NOT.LLERI .AND. LDQCO1.LT.MAX( 1, MINDEX ) ) ) THEN
         INFO = -9
      ELSE IF( ( LLERI .AND. LDQCO2.LT.MAX( 1, M ) ) .OR.
     $    ( .NOT.LLERI .AND. LDQCO2.LT.MAX( 1, MINDEX ) ) ) THEN
         INFO = -10
      END IF
C
      N = 0
      IF ( INFO.EQ.0 ) THEN
         IF ( LLERI ) THEN
            PWORK = P
            MWORK = M
         ELSE
            PWORK = M
            MWORK = P
         END IF
C
         MAXIND = 0
         DO 10 I = 1, PWORK
            N = N + INDEX(I)
            IF ( INDEX(I).GT.MAXIND ) MAXIND = INDEX(I)
   10    CONTINUE
         KPCOEF = MAXIND + 1
      END IF
C
      IF( LDA.LT.MAX( 1, N ) ) THEN
         INFO = -14
      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
         INFO = -16
      ELSE IF( LDC.LT.MAX( 1, MINDEX ) ) THEN
         INFO = -18
      ELSE IF( LDD.LT.MAX( 1, MINDEX ) ) THEN
         INFO = -20
      ELSE IF( LDWORK.LT.MAX( 1, MINDEX*( MINDEX + 4 ) ) ) THEN
         INFO = -23
      END IF
C
      IF ( INFO.NE.0 ) THEN
C
C        Error return.
C
         CALL XERBLA( 'TC04AD', -INFO )
         RETURN
      END IF
C
C     Quick return if possible.
C
      IF ( M.EQ.0 .OR. P.EQ.0 ) THEN
         N = 0
         RCOND = ONE
         DWORK(1) = ONE
         RETURN
      END IF
C
      IF ( .NOT.LLERI ) THEN
C
C        Initialization for right matrix fraction: obtain the dual
C        system.
C
         CALL TC01OD( 'R', M, P, KPCOEF, PCOEFF, LDPCO1, LDPCO2,
     $                QCOEFF, LDQCO1, LDQCO2, INFO )
      END IF
C
C     Store leading row coefficient matrix of P(s).
C
      LDW = MAX( 1, PWORK )
      CALL DLACPY( 'Full', PWORK, PWORK, PCOEFF, LDPCO1, DWORK, LDW )
C
C     Check if P(s) is row proper: if not, exit.
C
      DWNORM = DLANGE( '1-norm', PWORK, PWORK, DWORK, LDW, DWORK )
C
      CALL DGETRF( PWORK, PWORK, DWORK, LDW, IWORK, INFO )
C
C     Workspace: need  PWORK*(PWORK + 4).
C
C     (Note: Comments in the code beginning "Workspace:" describe the
C     minimal amount of real workspace needed at that point in the
C     code, as well as the preferred amount for good performance.
C     NB refers to the optimal block size for the immediately
C     following subroutine, as returned by ILAENV.)
C
      JWORK = LDW*PWORK + 1
C
      CALL DGECON( '1-norm', PWORK, DWORK, LDW, DWNORM, RCOND,
     $             DWORK(JWORK), IWORK(PWORK+1), INFO )
C
      WRKOPT = MAX( 1, PWORK*(PWORK + 4) )
C
      IF ( RCOND.LE.DLAMCH( 'Epsilon' ) ) THEN
C
C        Error return: P(s) is not row proper.
C
         INFO = 1
         RETURN
      ELSE
C
C        Calculate the order of equivalent state-space representation,
C        and initialize A.
C
         CALL DLASET( 'Full', N, N, ZERO, ZERO, A, LDA )
C
         DWORK(JWORK) = ONE
         IF ( N.GT.1 ) CALL DCOPY( N-1, DWORK(JWORK), 0, A(2,1), LDA+1 )
C
C        Find the PWORK ordered 'non-trivial' columns row by row,
C        in PWORK row blocks, the I-th having INDEX(I) rows.
C
         IBIAS = 2
C
         DO 50 I = 1, PWORK
            KSTOP = INDEX(I) + 1
            IF ( KSTOP.NE.1 ) THEN
               IBIAS = IBIAS + INDEX(I)
C
C              These rows given from the lower coefficients of row I
C              of P(s).
C
               DO 40 K = 2, KSTOP
                  IA = IBIAS - K
C
                  DO 20 J = 1, PWORK
                     DWORK(JWORK+J-1) = -PCOEFF(I,J,K)
   20             CONTINUE
C
                  CALL DGETRS( 'Transpose', PWORK, 1, DWORK, LDW,
     $                         IWORK, DWORK(JWORK), LDW, INFO )
C
                  JA = 0
C
                  DO 30 J = 1, PWORK
                     IF ( INDEX(J).NE.0 ) THEN
                        JA = JA + INDEX(J)
                        A(IA,JA) = DWORK(JWORK+J-1)
                     END IF
   30             CONTINUE
C
C                 Also, set up B and C (temporarily) for use when
C                 finding B.
C
                  CALL DCOPY( MWORK, QCOEFF(I,1,K), LDQCO1, B(IA,1),
     $                        LDB )
                  CALL DCOPY( PWORK, PCOEFF(I,1,K), LDPCO1, C(1,IA), 1 )
   40          CONTINUE
C
            END IF
   50    CONTINUE
C
C        Calculate D from the leading coefficients of P and Q.
C
         CALL DLACPY( 'Full', PWORK, MWORK, QCOEFF, LDQCO1, D, LDD )
C
         CALL DGETRS( 'No transpose', PWORK, MWORK, DWORK, LDW, IWORK,
     $                D, LDD, INFO )
C
C        For B and C as set up above, desired B = B - (C' * D).
C
         CALL DGEMM( 'Transpose', 'No transpose', N, MWORK, PWORK, -ONE,
     $               C, LDC, D, LDD, ONE, B, LDB )
C
C        Finally, calculate C: zero, apart from ...
C
         CALL DLASET( 'Full', PWORK, N, ZERO, ZERO, C, LDC )
C
C        PWORK ordered 'non-trivial' columns, equal to those
C        of inv(DWORK).
C
C        Workspace: need   PWORK*(PWORK + 1);
C                   prefer PWORK*PWORK + PWORK*NB.
C
         CALL DGETRI( PWORK, DWORK, LDW, IWORK, DWORK(JWORK),
     $                LDWORK-JWORK+1, INFO )
C
         WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) )+JWORK-1 )
         JC = 0
         JW = 1
C
         DO 60 J = 1, PWORK
            IF ( INDEX(J).NE.0 ) THEN
               JC = JC + INDEX(J)
               CALL DCOPY( PWORK, DWORK(JW), 1, C(1,JC), 1 )
            END IF
            JW = JW + LDW
   60    CONTINUE
C
      END IF
C
C     For right matrix fraction, return to original (dual of dual)
C     system.
C
      IF ( .NOT.LLERI ) THEN
         CALL TC01OD( 'L', MWORK, PWORK, KPCOEF, PCOEFF, LDPCO1,
     $                LDPCO2, QCOEFF, LDQCO1, LDQCO2, INFO )
C
C        Also, obtain dual of state-space representation.
C
         CALL AB07MD( 'D', N, MWORK, PWORK, A, LDA, B, LDB, C, LDC, D,
     $                LDD, INFO )
      END IF
C
C     Set optimal workspace dimension.
C
      DWORK(1) = WRKOPT
C
      RETURN
C *** Last line of TC04AD ***
      END


module man_or_boy

implicit none

contains

  recursive integer function A(k,x1,x2,x3,x4,x5) result(res)
    integer, intent(in) :: k
    interface
      recursive integer function x1()
      end function
      recursive integer function x2()
      end function
      recursive integer function x3()
      end function
      recursive integer function x4()
      end function
      recursive integer function x5()
      end function
    end interface
    integer :: m
    if ( k <= 0 ) then
      res = x4()+x5()
    else
      m = k
      res = B()
    end if

  contains

    recursive integer function B() result(res)
      m = m-1
      res = A(m,B,x1,x2,x3,x4)
    end function B

  end function A

  recursive integer function one() result(res)
    res = 1
  end function

  recursive integer function minus_one() result(res)
    res = -1
  end function

  recursive integer function zero() result(res)
    res = 0
  end function

end module man_or_boy

program test
  use man_or_boy
  write (*,*) A(10,one,minus_one,minus_one,one,zero)
end program test


module constants
implicit none

    real*8, parameter :: au_km = 149599650.0
    real*8, parameter :: au_miles = 92955807.267433

    real*8, parameter :: du_ft = 20925646.325459318
    real*8, parameter :: du_miles = 3963.190591943
    real*8, parameter :: du_nm = 3443.918466523
    real*8, parameter :: du_km = 6378.137000000

    real*8, parameter :: earth_angular_rotation = 0.05883359068688786
    real*8, parameter :: earth_deg_min = 0.25068444793441402
    real*8, parameter :: earth_rad_s = 0.00007292115000000
    real*8, parameter :: earth_radians_solarday = 6.30038809866574

    real*8, parameter :: shape_semi_minor_axis_km = 6356.752314200
    real*8, parameter :: shape_earth_eccentricity = 0.08181919044260 ** 2
    real*8, parameter :: shape_earth_flattening = 1.0 / 298.257223563

    real*8, parameter :: tu_min = 13.44685108204
    real*8, parameter :: tu_sec = 806.81106492270
    real*8, parameter :: tu_days = 0.00933809102919444

    real*8, parameter :: radperday = 6.3003880986657400
    real*8, parameter :: twopi = 6.2831853071795900

end module constants


!
!  Copyright 2016 ARTED developers
!
!  Licensed under the Apache License, Version 2.0 (the "License");
!  you may not use this file except in compliance with the License.
!  You may obtain a copy of the License at
!
!      http://www.apache.org/licenses/LICENSE-2.0
!
!  Unless required by applicable law or agreed to in writing, software
!  distributed under the License is distributed on an "AS IS" BASIS,
!  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
!  See the License for the specific language governing permissions and
!  limitations under the License.
!
subroutine Hartree
  use global_variables
  implicit none
  integer :: i,ix,iy,iz

  do i=1,NL
    rho_c_3D(iLx(1,i),iLx(2,i),iLx(3,i))=rho_c(i)
  end do

  do ix=0,NL1-1
  do iy=0,NL2-1
  do iz=0,NL3-1
    zft1(ix,iy,iz)=sum(cexp_x3(:,iz)*rho_c_3D(ix,iy,:))
  end do
  end do
  end do
  do ix=0,NL1-1
  do iy=0,NL2-1
  do iz=0,NL3-1
    zft2(ix,iy,iz)=sum(cexp_x2(:,iy)*zft1(ix,:,iz))
  end do
  end do
  end do
  do ix=0,NL1-1
  do iy=0,NL2-1
  do iz=0,NL3-1
    zft1(ix,iy,iz)=sum(cexp_x1(:,ix)*zft2(:,iy,iz))
  end do
  end do
  end do

  zft1=-4d0*pi*InLap_k*zft1/dble(NL1*NL2*NL3)

  do ix=0,NL1-1
  do iy=0,NL2-1
  do iz=0,NL3-1
    zft2(ix,iy,iz)=sum(exp_x3(:,iz)*zft1(ix,iy,:))
  end do
  end do
  end do
  do ix=0,NL1-1
  do iy=0,NL2-1
  do iz=0,NL3-1
    zft1(ix,iy,iz)=sum(exp_x2(:,iy)*zft2(ix,:,iz))
  end do
  end do
  end do

  do ix=0,NL1-1
  do iy=0,NL2-1
  do iz=0,NL3-1
    zft2(ix,iy,iz)=sum(exp_x1(:,ix)*zft1(:,iy,iz))
  end do
  end do
  end do

  do i=1,NL
    Vh(i)=zft2(iLx(1,i),iLx(2,i),iLx(3,i))
  end do

  return
end subroutine Hartree


\ -----------------------------------------------------------------------------
\  Game of Life with "Echo"
\  Cellular Automata
\  Michel Jean June 2019
\ -----------------------------------------------------------------------------

S" pixel.f" INCLUDED

320 constant largeur-monde \
200 constant hauteur-monde
largeur-monde hauteur-monde * constant dim-monde

variable pos-X
variable pos-Y

0 pos-X !
0 pos-Y !

\ ===============================================================
create  monde dim-monde allot
create  monde-buf dim-monde allot

variable *monde
variable *monde-buf
variable tampon

variable total \ nbr voisins
variable etat

' monde *monde !
' monde-buf *monde-buf !

: last-bit ( n -- )
2 mod ;

: centre ( n -- )
*monde @ + c@ last-bit
;

\ 9 voisins possibles
: est ( n -- )
	1 + dim-monde mod *monde @ + c@ last-bit ;

: ouest ( n -- )
	1 - dim-monde mod *monde @ + c@ last-bit ;

: nord ( n -- )
	largeur-monde - dim-monde mod *monde @ + c@ last-bit ;

: sud ( n -- )
	largeur-monde + dim-monde mod *monde @ + c@ last-bit ;

: nord-est ( n -- )
	largeur-monde - 1 + dim-monde mod *monde @ + c@ last-bit ;

: nord-ouest ( n -- )
	largeur-monde - 1 - dim-monde mod *monde @ + c@ last-bit ;

: sud-est ( n -- )
	largeur-monde + 1 + dim-monde mod *monde @ + c@ last-bit ;

: sud-ouest ( n -- )
	largeur-monde + 1 - dim-monde mod *monde @ + c@ last-bit ;

\ voisinage de moore

: moore ( n -- ) \ returne le nombre de voisins

	dup nord-ouest
	swap dup nord
	swap dup nord-est
	swap dup est
	swap dup sud-est
	swap dup sud
	swap dup sud-ouest
	swap ouest
;

: somme-moore
moore
+ + + + + + +
;

\ regles de conway avec echo
: conway-echo1
	dup
	centre etat c! \ l'état est 1 ou 0, vivant ou mort
	somme-moore total c!
	total @ 3 = if 3 etat c! else
	total @ 2 = if ( reste pareil ) else
	0 etat c!
	then then
	etat c@
;

: conway-echo
	dup
	centre etat c! \ l'état est 1 ou 0, vivant ou mort
	somme-moore total c!

	etat @ 0 = total @ 3 = and if 1 etat c! else
	etat @ 1 = total @ 3 = and if 3 etat c! else
	etat @ 1 = total @ 2 = and if 3 etat c! else
	etat @ 1 = if 2 etat c! else
	0 etat c!
	then then then then
	etat c@
;
\ =========================================

: initialisation ( -- ) \ monde aléatoire
	*monde @ dim-monde 0 fill
	dim-monde 0 do 8 random
	1 = if 1 *monde @ i + c! then loop
;

: regenere-monde
	dim-monde 0 do i conway-echo *monde-buf @ i + c! loop
	*monde tampon 1 cells move
	*monde-buf *monde 1 cells move
	tampon *monde-buf 1 cells move
;

: dessine-monde ( -- )
	largeur-monde 0 do
	hauteur-monde 0 do
		largeur-monde i * j + *monde @ + c@ 1 = if
				j i blue pixel else
		largeur-monde i * j + *monde @ + c@ 2 = if
				j i red pixel else
		largeur-monde i * j + *monde @ + c@ 3 = if
				j i green pixel else
				j i black pixel

	then then then
	loop loop
;

: run

	initialisation
	set-screen
	dessine-monde
	BEGIN
	dessine-monde
	regenere-monde
	view
	key? if key 83 = if cr exit then then
	10 pause
	AGAIN
;

: depart
	cr ." Type run to start"
	cr ." Type s to stop" cr ;

depart


      DOUBLE PRECISION FUNCTION rexp(x)
C-----------------------------------------------------------------------
C            EVALUATION OF THE FUNCTION EXP(X) - 1
C-----------------------------------------------------------------------
C     .. Scalar Arguments ..
      DOUBLE PRECISION x
C     ..
C     .. Local Scalars ..
      DOUBLE PRECISION p1,p2,q1,q2,q3,q4,w
C     ..
C     .. Intrinsic Functions ..
      INTRINSIC abs,exp
C     ..
C     .. Data statements ..
      DATA p1/.914041914819518D-09/,p2/.238082361044469D-01/,
     +     q1/-.499999999085958D+00/,q2/.107141568980644D+00/,
     +     q3/-.119041179760821D-01/,q4/.595130811860248D-03/
C     ..
C     .. Executable Statements ..
C-----------------------
      IF (abs(x).GT.0.15D0) GO TO 10
      rexp = x* (((p2*x+p1)*x+1.0D0)/ ((((q4*x+q3)*x+q2)*x+q1)*x+1.0D0))
      RETURN
C
   10 w = exp(x)
      IF (x.GT.0.0D0) GO TO 20
      rexp = (w-0.5D0) - 0.5D0
      RETURN

   20 rexp = w* (0.5D0+ (0.5D0-1.0D0/w))
      RETURN

      END