      subroutine sgefa(a,lda,n,ipvt,info)
      implicit real*8(A-H,O-Z)
      integer lda,n,ipvt(1),info
      real*8 a(lda,1)
c
c     sgefa factors a real matrix by gaussian elimination.
c
c     sgefa is usually called by sgeco, but it can be called
c     directly with a saving in time if  rcond  is not needed.
c     (time for sgeco) = (1 + 9/n)*(time for sgefa) .
c
c     on entry
c
c        a       real(lda, n)
c                the matrix to be factored.
c
c        lda     integer
c                the leading dimension of the array  a .
c
c        n       integer
c                the order of the matrix  a .
c
c     on return
c
c        a       an upper triangular matrix and the multipliers
c                which were used to obtain it.
c                the factorization can be written  a = l*u  where
c                l  is a product of permutation and unit lower
c                triangular matrices and  u  is upper triangular.
c
c        ipvt    integer(n)
c                an integer vector of pivot indices.
c
c        info    integer
c                = 0  normal value.
c                = k  if  u(k,k) .eq. 0.0 .  this is not an error
c                     condition for this subroutine, but it does
c                     indicate that sgesl or sgedi will divide by zero
c                     if called.  use  rcond  in sgeco for a reliable
c                     indication of singularity.
c
c     linpack. this version dated 08/14/78 .
c     cleve moler, university of new mexico, argonne national lab.
c
c     subroutines and functions
c
c     blas saxpy,sscal,isamax
c
c     internal variables
c
      real*8 t
      integer isamax,j,k,kp1,l,nm1
c
c
c     gaussian elimination with partial pivoting
c
      info = 0
      nm1 = n - 1
      if (nm1 .lt. 1) go to 70
      do 60 k = 1, nm1
         kp1 = k + 1
c
c        find l = pivot index
c
         l = isamax(n-k+1,a(k,k),1) + k - 1
         ipvt(k) = l
c
c        zero pivot implies this column already triangularized
c
         if (a(l,k) .eq. 0.0e0) go to 40
c
c           interchange if necessary
c
            if (l .eq. k) go to 10
               t = a(l,k)
               a(l,k) = a(k,k)
               a(k,k) = t
   10       continue
c
c           compute multipliers
c
            t = -1.0e0/a(k,k)
            call sscal(n-k,t,a(k+1,k),1)
c
c           row elimination with column indexing
c
            do 30 j = kp1, n
               t = a(l,j)
               if (l .eq. k) go to 20
                  a(l,j) = a(k,j)
                  a(k,j) = t
   20          continue
               call saxpy(n-k,t,a(k+1,k),1,a(k+1,j),1)
   30       continue
         go to 50
   40    continue
            info = k
   50    continue
   60 continue
   70 continue
      ipvt(n) = n
      if (a(n,n) .eq. 0.0e0) info = n
      return
      end

      subroutine sgesl(a,lda,n,ipvt,b,job)
      implicit real*8(A-H,O-Z)
      integer lda,n,ipvt(1),job
      real*8 a(lda,1),b(1)
c
c     sgesl solves the real system
c     a * x = b  or  trans(a) * x = b
c     using the factors computed by sgeco or sgefa.
c
c     on entry
c
c        a       real(lda, n)
c                the output from sgeco or sgefa.
c
c        lda     integer
c                the leading dimension of the array  a .
c
c        n       integer
c                the order of the matrix  a .
c
c        ipvt    integer(n)
c                the pivot vector from sgeco or sgefa.
c
c        b       real(n)
c                the right hand side vector.
c
c        job     integer
c                = 0         to solve  a*x = b ,
c                = nonzero   to solve  trans(a)*x = b  where
c                            trans(a)  is the transpose.
c
c     on return
c
c        b       the solution vector  x .
c
c     error condition
c
c        a division by zero will occur if the input factor contains a
c        zero on the diagonal.  technically this indicates singularity
c        but it is often caused by improper arguments or improper
c        setting of lda .  it will not occur if the subroutines are
c        called correctly and if sgeco has set rcond .gt. 0.0
c        or sgefa has set info .eq. 0 .
c
c     to compute  inverse(a) * c  where  c  is a matrix
c     with  p  columns
c           call sgeco(a,lda,n,ipvt,rcond,z)
c           if (rcond is too small) go to ...
c           do 10 j = 1, p
c              call sgesl(a,lda,n,ipvt,c(1,j),0)
c        10 continue
c
c     linpack. this version dated 08/14/78 .
c     cleve moler, university of new mexico, argonne national lab.
c
c     subroutines and functions
c
c     blas saxpy,sdot
c
c     internal variables
c
      real*8 sdot,t
      integer k,kb,l,nm1
c
      nm1 = n - 1
      if (job .ne. 0) go to 50
c
c        job = 0 , solve  a * x = b
c        first solve  l*y = b
c
         if (nm1 .lt. 1) go to 30
         do 20 k = 1, nm1
            l = ipvt(k)
            t = b(l)
            if (l .eq. k) go to 10
               b(l) = b(k)
               b(k) = t
   10       continue
            call saxpy(n-k,t,a(k+1,k),1,b(k+1),1)
   20    continue
   30    continue
c
c        now solve  u*x = y
c
         do 40 kb = 1, n
            k = n + 1 - kb
            b(k) = b(k)/a(k,k)
            t = -b(k)
            call saxpy(k-1,t,a(1,k),1,b(1),1)
   40    continue
      go to 100
   50 continue
c
c        job = nonzero, solve  trans(a) * x = b
c        first solve  trans(u)*y = b
c
         do 60 k = 1, n
            t = sdot(k-1,a(1,k),1,b(1),1)
            b(k) = (b(k) - t)/a(k,k)
   60    continue
c
c        now solve trans(l)*x = y
c
         if (nm1 .lt. 1) go to 90
         do 80 kb = 1, nm1
            k = n - kb
            b(k) = b(k) + sdot(n-k,a(k+1,k),1,b(k+1),1)
            l = ipvt(k)
            if (l .eq. k) go to 70
               t = b(l)
               b(l) = b(k)
               b(k) = t
   70       continue
   80    continue
   90    continue
  100 continue
      return
      end

      subroutine sscal(n,sa,sx,incx)
c
c     scales a vector by a constant.
c     uses unrolled loops for increment equal to 1.
c     jack dongarra, linpack, 3/11/78.
c     modified 3/93 to return if incx .le. 0.
c
      implicit real*8(A-H,O-Z)
      real*8 sa,sx(1)
      integer i,incx,m,mp1,n,nincx
c
      if( n.le.0 .or. incx.le.0 )return
      if(incx.eq.1)go to 20
c
c        code for increment not equal to 1
c
      nincx = n*incx
      do 10 i = 1,nincx,incx
        sx(i) = sa*sx(i)
   10 continue
      return
c
c        code for increment equal to 1
c
c
c        clean-up loop
c
   20 m = mod(n,5)
      if( m .eq. 0 ) go to 40
      do 30 i = 1,m
        sx(i) = sa*sx(i)
   30 continue
      if( n .lt. 5 ) return
   40 mp1 = m + 1
      do 50 i = mp1,n,5
        sx(i) = sa*sx(i)
        sx(i + 1) = sa*sx(i + 1)
        sx(i + 2) = sa*sx(i + 2)
        sx(i + 3) = sa*sx(i + 3)
        sx(i + 4) = sa*sx(i + 4)
   50 continue
      return
      end

      real*8 function sdot(n,sx,incx,sy,incy)
c
c     forms the dot product of two vectors.
c     uses unrolled loops for increments equal to one.
c     jack dongarra, linpack, 3/11/78.
c
      implicit real*8(A-H,O-Z)
      real*8 sx(1),sy(1),stemp
      integer i,incx,incy,ix,iy,m,mp1,n
c
      stemp = 0.0e0
      sdot = 0.0e0
      if(n.le.0)return
      if(incx.eq.1.and.incy.eq.1)go to 20
c
c        code for unequal increments or equal increments
c          not equal to 1
c
      ix = 1
      iy = 1
      if(incx.lt.0)ix = (-n+1)*incx + 1
      if(incy.lt.0)iy = (-n+1)*incy + 1
      do 10 i = 1,n
        stemp = stemp + sx(ix)*sy(iy)
        ix = ix + incx
        iy = iy + incy
   10 continue
      sdot = stemp
      return
c
c        code for both increments equal to 1
c
c
c        clean-up loop
c
   20 m = mod(n,5)
      if( m .eq. 0 ) go to 40
      do 30 i = 1,m
        stemp = stemp + sx(i)*sy(i)
   30 continue
      if( n .lt. 5 ) go to 60
   40 mp1 = m + 1
      do 50 i = mp1,n,5
        stemp = stemp + sx(i)*sy(i) + sx(i + 1)*sy(i + 1) +
     *   sx(i + 2)*sy(i + 2) + sx(i + 3)*sy(i + 3) + sx(i + 4)*sy(i + 4)
   50 continue
   60 sdot = stemp
      return
      end

      integer function isamax(n,sx,incx)
c
c     finds the index of element having max. absolute value.
c     jack dongarra, linpack, 3/11/78.
c     modified 3/93 to return if incx .le. 0.
c
      implicit real*8(A-H,O-Z)
      real*8 sx(1),smax
      integer i,incx,ix,n
c
      isamax = 0
      if( n.lt.1 .or. incx.le.0 ) return
      isamax = 1
      if(n.eq.1)return
      if(incx.eq.1)go to 20
c
c        code for increment not equal to 1
c
      ix = 1
      smax = abs(sx(1))
      ix = ix + incx
      do 10 i = 2,n
         if(abs(sx(ix)).le.smax) go to 5
         isamax = i
         smax = abs(sx(ix))
    5    ix = ix + incx
   10 continue
      return
c
c        code for increment equal to 1
c
   20 smax = abs(sx(1))
      do 30 i = 2,n
         if(abs(sx(i)).le.smax) go to 30
         isamax = i
         smax = abs(sx(i))
   30 continue
      return
      end

      subroutine saxpy(n,sa,sx,incx,sy,incy)
c
c     constant times a vector plus a vector.
c     uses unrolled loop for increments equal to one.
c     jack dongarra, linpack, 3/11/78.
c
      implicit real*8(A-H,O-Z)
      real*8 sx(1),sy(1),sa
      integer i,incx,incy,ix,iy,m,mp1,n
c
      if(n.le.0)return
      if (sa .eq. 0.0) return
      if(incx.eq.1.and.incy.eq.1)go to 20
c
c        code for unequal increments or equal increments
c          not equal to 1
c
      ix = 1
      iy = 1
      if(incx.lt.0)ix = (-n+1)*incx + 1
      if(incy.lt.0)iy = (-n+1)*incy + 1
      do 10 i = 1,n
        sy(iy) = sy(iy) + sa*sx(ix)
        ix = ix + incx
        iy = iy + incy
   10 continue
      return
c
c        code for both increments equal to 1
c
c
c        clean-up loop
c
   20 m = mod(n,4)
      if( m .eq. 0 ) go to 40
      do 30 i = 1,m
        sy(i) = sy(i) + sa*sx(i)
   30 continue
      if( n .lt. 4 ) return
   40 mp1 = m + 1
      do 50 i = mp1,n,4
        sy(i) = sy(i) + sa*sx(i)
        sy(i + 1) = sy(i + 1) + sa*sx(i + 1)
        sy(i + 2) = sy(i + 2) + sa*sx(i + 2)
        sy(i + 3) = sy(i + 3) + sa*sx(i + 3)
   50 continue
      return
      end

      subroutine sgtsl(n,c,d,e,b,info)
      integer n,info
      real*8 c(*),d(*),e(*),b(*)
c
c     sgtsl given a general tridiagonal matrix and a right hand
c     side will find the solution.
c
c     on entry
c
c        n       integer
c                is the order of the tridiagonal matrix.
c
c        c       real(n)
c                is the subdiagonal of the tridiagonal matrix.
c                c(2) through c(n) should contain the subdiagonal.
c                on output c is destroyed.
c
c        d       real(n)
c                is the diagonal of the tridiagonal matrix.
c                on output d is destroyed.
c
c        e       real(n)
c                is the superdiagonal of the tridiagonal matrix.
c                e(1) through e(n-1) should contain the superdiagonal.
c                on output e is destroyed.
c
c        b       real(n)
c                is the right hand side vector.
c
c     on return
c
c        b       is the solution vector.
c
c        info    integer
c                = 0 normal value.
c                = k if the k-th element of the diagonal becomes
c                    exactly zero.  the subroutine returns when
c                    this is detected.
c
c     linpack. this version dated 08/14/78 .
c     jack dongarra, argonne national laboratory.
c
c     no externals
c     fortran abs
c
c     internal variables
c
      integer k,kb,kp1,nm1,nm2
      real*8 t
c     begin block permitting ...exits to 100
c
         info = 0
         c(1) = d(1)
         nm1 = n - 1
         if (nm1 .lt. 1) go to 40
            d(1) = e(1)
            e(1) = 0.0e0
            e(n) = 0.0e0
c
            do 30 k = 1, nm1
               kp1 = k + 1
c
c              find the largest of the two rows
c
               if (abs(c(kp1)) .lt. abs(c(k))) go to 10
c
c                 interchange row
c
                  t = c(kp1)
                  c(kp1) = c(k)
                  c(k) = t
                  t = d(kp1)
                  d(kp1) = d(k)
                  d(k) = t
                  t = e(kp1)
                  e(kp1) = e(k)
                  e(k) = t
                  t = b(kp1)
                  b(kp1) = b(k)
                  b(k) = t
   10          continue
c
c              zero elements
c
               if (c(k) .ne. 0.0e0) go to 20
                  info = k
c     ............exit
                  go to 100
   20          continue
               t = -c(kp1)/c(k)
               c(kp1) = d(kp1) + t*d(k)
               d(kp1) = e(kp1) + t*e(k)
               e(kp1) = 0.0e0
               b(kp1) = b(kp1) + t*b(k)
   30       continue
   40    continue
         if (c(n) .ne. 0.0e0) go to 50
            info = n
         go to 90
   50    continue
c
c           back solve
c
            nm2 = n - 2
            b(n) = b(n)/c(n)
            if (n .eq. 1) go to 80
               b(nm1) = (b(nm1) - d(nm1)*b(n))/c(nm1)
               if (nm2 .lt. 1) go to 70
               do 60 kb = 1, nm2
                  k = nm2 - kb + 1
                  b(k) = (b(k) - d(k)*b(k+1) - e(k)*b(k+2))/c(k)
   60          continue
   70          continue
   80       continue
   90    continue
  100 continue
c
      return
      end

      subroutine sgbsl(abd,lda,n,ml,mu,ipvt,b,job)
      integer lda,n,ml,mu,ipvt(*),job
      real*8 abd(lda,*),b(*)
c
c     sgbsl solves the real band system
c     a * x = b  or  trans(a) * x = b
c     using the factors computed by sgbco or sgbfa.
c
c     on entry
c
c        abd     real(lda, n)
c                the output from sgbco or sgbfa.
c
c        lda     integer
c                the leading dimension of the array  abd .
c
c        n       integer
c                the order of the original matrix.
c
c        ml      integer
c                number of diagonals below the main diagonal.
c
c        mu      integer
c                number of diagonals above the main diagonal.
c
c        ipvt    integer(n)
c                the pivot vector from sgbco or sgbfa.
c
c        b       real(n)
c                the right hand side vector.
c
c        job     integer
c                = 0         to solve  a*x = b ,
c                = nonzero   to solve  trans(a)*x = b , where
c                            trans(a)  is the transpose.
c
c     on return
c
c        b       the solution vector  x .
c
c     error condition
c
c        a division by zero will occur if the input factor contains a
c        zero on the diagonal.  technically this indicates singularity
c        but it is often caused by improper arguments or improper
c        setting of lda .  it will not occur if the subroutines are
c        called correctly and if sgbco has set rcond .gt. 0.0
c        or sgbfa has set info .eq. 0 .
c
c     to compute  inverse(a) * c  where  c  is a matrix
c     with  p  columns
c           call sgbco(abd,lda,n,ml,mu,ipvt,rcond,z)
c           if (rcond is too small) go to ...
c           do 10 j = 1, p
c              call sgbsl(abd,lda,n,ml,mu,ipvt,c(1,j),0)
c        10 continue
c
c     linpack. this version dated 08/14/78 .
c     cleve moler, university of new mexico, argonne national lab.
c
c     subroutines and functions
c
c     blas saxpy,sdot
c     fortran min0
c
c     internal variables
c
      real*8 sdot,t
      integer k,kb,l,la,lb,lm,m,nm1
c
      m = mu + ml + 1
      nm1 = n - 1
      if (job .ne. 0) go to 50
c
c        job = 0 , solve  a * x = b
c        first solve l*y = b
c
         if (ml .eq. 0) go to 30
         if (nm1 .lt. 1) go to 30
            do 20 k = 1, nm1
               lm = min0(ml,n-k)
               l = ipvt(k)
               t = b(l)
               if (l .eq. k) go to 10
                  b(l) = b(k)
                  b(k) = t
   10          continue
               call saxpy(lm,t,abd(m+1,k),1,b(k+1),1)
   20       continue
   30    continue
c
c        now solve  u*x = y
c
         do 40 kb = 1, n
            k = n + 1 - kb
            b(k) = b(k)/abd(m,k)
            lm = min0(k,m) - 1
            la = m - lm
            lb = k - lm
            t = -b(k)
            call saxpy(lm,t,abd(la,k),1,b(lb),1)
   40    continue
      go to 100
   50 continue
c
c        job = nonzero, solve  trans(a) * x = b
c        first solve  trans(u)*y = b
c
         do 60 k = 1, n
            lm = min0(k,m) - 1
            la = m - lm
            lb = k - lm
            t = sdot(lm,abd(la,k),1,b(lb),1)
            b(k) = (b(k) - t)/abd(m,k)
   60    continue
c
c        now solve trans(l)*x = y
c
         if (ml .eq. 0) go to 90
         if (nm1 .lt. 1) go to 90
            do 80 kb = 1, nm1
               k = n - kb
               lm = min0(ml,n-k)
               b(k) = b(k) + sdot(lm,abd(m+1,k),1,b(k+1),1)
               l = ipvt(k)
               if (l .eq. k) go to 70
                  t = b(l)
                  b(l) = b(k)
                  b(k) = t
   70          continue
   80       continue
   90    continue
  100 continue
      return
      end

      subroutine sgbfa(abd,lda,n,ml,mu,ipvt,info)
      integer lda,n,ml,mu,ipvt(*),info
      real*8 abd(lda,*)
c
c     sgbfa factors a real band matrix by elimination.
c
c     sgbfa is usually called by sgbco, but it can be called
c     directly with a saving in time if  rcond  is not needed.
c
c     on entry
c
c        abd     real(lda, n)
c                contains the matrix in band storage.  the columns
c                of the matrix are stored in the columns of  abd  and
c                the diagonals of the matrix are stored in rows
c                ml+1 through 2*ml+mu+1 of  abd .
c                see the comments below for details.
c
c        lda     integer
c                the leading dimension of the array  abd .
c                lda must be .ge. 2*ml + mu + 1 .
c
c        n       integer
c                the order of the original matrix.
c
c        ml      integer
c                number of diagonals below the main diagonal.
c                0 .le. ml .lt. n .
c
c        mu      integer
c                number of diagonals above the main diagonal.
c                0 .le. mu .lt. n .
c                more efficient if  ml .le. mu .
c     on return
c
c        abd     an upper triangular matrix in band storage and
c                the multipliers which were used to obtain it.
c                the factorization can be written  a = l*u  where
c                l  is a product of permutation and unit lower
c                triangular matrices and  u  is upper triangular.
c
c        ipvt    integer(n)
c                an integer vector of pivot indices.
c
c        info    integer
c                = 0  normal value.
c                = k  if  u(k,k) .eq. 0.0 .  this is not an error
c                     condition for this subroutine, but it does
c                     indicate that sgbsl will divide by zero if
c                     called.  use  rcond  in sgbco for a reliable
c                     indication of singularity.
c
c     band storage
c
c           if  a  is a band matrix, the following program segment
c           will set up the input.
c
c                   ml = (band width below the diagonal)
c                   mu = (band width above the diagonal)
c                   m = ml + mu + 1
c                   do 20 j = 1, n
c                      i1 = max0(1, j-mu)
c                      i2 = min0(n, j+ml)
c                      do 10 i = i1, i2
c                         k = i - j + m
c                         abd(k,j) = a(i,j)
c                10    continue
c                20 continue
c
c           this uses rows  ml+1  through  2*ml+mu+1  of  abd .
c           in addition, the first  ml  rows in  abd  are used for
c           elements generated during the triangularization.
c           the total number of rows needed in  abd  is  2*ml+mu+1 .
c           the  ml+mu by ml+mu  upper left triangle and the
c           ml by ml  lower right triangle are not referenced.
c
c     linpack. this version dated 08/14/78 .
c     cleve moler, university of new mexico, argonne national lab.
c
c     subroutines and functions
c
c     blas saxpy,sscal,isamax
c     fortran max0,min0
c
c     internal variables
c
      real*8 t
      integer i,isamax,i0,j,ju,jz,j0,j1,k,kp1,l,lm,m,mm,nm1
c
c
      m = ml + mu + 1
      info = 0
c
c     zero initial fill-in columns
c
      j0 = mu + 2
      j1 = min0(n,m) - 1
      if (j1 .lt. j0) go to 30
      do 20 jz = j0, j1
         i0 = m + 1 - jz
         do 10 i = i0, ml
            abd(i,jz) = 0.0e0
   10    continue
   20 continue
   30 continue
      jz = j1
      ju = 0
c
c     gaussian elimination with partial pivoting
c
      nm1 = n - 1
      if (nm1 .lt. 1) go to 130
      do 120 k = 1, nm1
         kp1 = k + 1
c
c        zero next fill-in column
c
         jz = jz + 1
         if (jz .gt. n) go to 50
         if (ml .lt. 1) go to 50
            do 40 i = 1, ml
               abd(i,jz) = 0.0e0
   40       continue
   50    continue
c
c        find l = pivot index
c
         lm = min0(ml,n-k)
         l = isamax(lm+1,abd(m,k),1) + m - 1
         ipvt(k) = l + k - m
c
c        zero pivot implies this column already triangularized
c
         if (abd(l,k) .eq. 0.0e0) go to 100
c
c           interchange if necessary
c
            if (l .eq. m) go to 60
               t = abd(l,k)
               abd(l,k) = abd(m,k)
               abd(m,k) = t
   60       continue
c
c           compute multipliers
c
            t = -1.0e0/abd(m,k)
            call sscal(lm,t,abd(m+1,k),1)
c
c           row elimination with column indexing
c
            ju = min0(max0(ju,mu+ipvt(k)),n)
            mm = m
            if (ju .lt. kp1) go to 90
            do 80 j = kp1, ju
               l = l - 1
               mm = mm - 1
               t = abd(l,j)
               if (l .eq. mm) go to 70
                  abd(l,j) = abd(mm,j)
                  abd(mm,j) = t
   70          continue
               call saxpy(lm,t,abd(m+1,k),1,abd(mm+1,j),1)
   80       continue
   90       continue
         go to 110
  100    continue
            info = k
  110    continue
  120 continue
  130 continue
      ipvt(n) = n
      if (abd(m,n) .eq. 0.0e0) info = n
      return
      end


MODULE sspmod

  ! holds SSP input by user and associated variables

  IMPLICIT NONE
  SAVE

  INTEGER, PARAMETER     :: MaxSSP = 20001, MaxMedia = 501
  INTEGER, PRIVATE       :: N, iz, ILoc, Lay
  INTEGER                :: ISSP
  REAL (KIND=8)          :: alphaR = 1500, betaR = 0, alphaI = 0, betaI = 0, rhoR = 1
  REAL (KIND=8), PRIVATE :: h, z, R

  ! SSP
  TYPE SSPStructure
     INTEGER           :: Loc( MaxMedia ), NPts( MaxMedia ), NMedia
     REAL     (KIND=8) :: z( MaxSSP ), alphaR( MaxSSP ), alphaI( MaxSSP ), rho( MaxSSP ), betaR( MaxSSP ), betaI( MaxSSP )
     REAL     (KIND=8) :: Depth( MaxMedia ), sigma( MaxMedia ), beta( MaxMedia ), fT( MaxMedia )
     COMPLEX  (KIND=8) :: cp( MaxSSP ), cs( MaxSSP ), n2( MaxSSP ),  &
                          cpSpline( 4, MaxSSP ), csSpline( 4, MaxSSP ), rhoSpline( 4, MaxSSP )
     COMPLEX  (KIND=8) :: cpCoef( 4, MaxSSP ), csCoef( 4, MaxSSP ), rhoCoef( 4, MaxSSP ), csWork( 4, MaxSSP )   ! for the PCHIP coefficients
     COMPLEX  (KIND=8) :: rhoT( MaxSSP )   ! temporary values for calling PCHIP (ordinate argument must be complex valued!)
     CHARACTER (LEN=1) :: Type
     CHARACTER (LEN=2) :: AttenUnit
     CHARACTER (LEN=8) :: Material( MaxMedia )
  END TYPE SSPStructure

  TYPE( SSPStructure ) :: SSP

  TYPE HSInfo
     CHARACTER (LEN=1) :: BC                            ! Boundary condition type
     REAL    (KIND=8)  :: alphaR, alphaI, betaR, betaI  ! P-wave, S-wave speeds (user units)
     REAL    (KIND=8)  :: beta, fT                      ! power law and transition frequency
     COMPLEX (KIND=8)  :: cP, cS                        ! P-wave, S-wave speeds (neper/m loss)
     REAL    (KIND=8)  :: rho, BumpDensity, eta, xi     ! density, boss parameters
  END TYPE

  TYPE( HSInfo )      :: HSTop, HSBot

CONTAINS

  SUBROUTINE EvaluateSSP( cP, cS, rho, Medium, N1, Freq, Task, ENVFile, PRTFile )

    ! Call the particular SSP routine specified by SSPType
    ! Performs two Tasks:
    !    Task = 'TAB'  then tabulate cP, cS, rho
    !    Task = 'INIT' then initialize
    ! Note that Freq is only needed if Task = 'INIT'

    INTEGER,           INTENT(IN)    :: ENVFile, PRTFile, Medium
    INTEGER,           INTENT(INOUT) :: N1
    REAL     (KIND=8), INTENT(OUT)   :: rho( * )
    REAL     (KIND=8), INTENT(IN)    :: Freq
    COMPLEX  (KIND=8), INTENT(OUT)   :: cP( * ), cS( * )
    CHARACTER (LEN=8), INTENT(IN)    :: Task
    COMPLEX  (KIND=8)                :: cPT, cST

    SELECT CASE ( SSP%Type )
    CASE ( 'A' )  !  Analytic profile option
       IF ( Task( 1 : 4 ) == 'INIT' ) THEN
          N1 = 21

          CALL ANALYT( cP, cS, rho, Medium, N1, Freq, Task )
          h = ( SSP%Depth( Medium + 1 ) - SSP%Depth( Medium ) ) / ( N1 - 1 )

          DO iz = 1, N1
             z   = SSP%Depth( Medium ) + ( iz - 1 ) * h
             cPT =  cP( iz )
             cST =  cS( iz )
             WRITE( PRTFile, FMT="( F10.2, 3X, 2F10.2, 3X, F6.2, 3X, 2F10.4 )" ) &
                  z,  REAL( cPT ),  REAL( cST ), rho( iz ), AIMAG( cPT ), AIMAG( cST )
          END DO
       ELSE
          CALL ANALYT( cP, cS, rho, Medium, N1, Freq, Task )
       ENDIF
    CASE ( 'N' )  !  N2-linear profile option
       CALL n2Linear( cP, cS, rho, Medium, N1, Task, ENVFile, PRTFile )
    CASE ( 'C' )  !  C-linear profile option
       CALL cLinear(  cP, cS, rho, Medium, N1, Task, ENVFile, PRTFile )
    CASE ( 'P' )  !  monotone PCHIP ACS profile option
       CALL cPCHIP(   cP, cS, rho, Medium, N1, Task, ENVFile, PRTFile )
    CASE ( 'S' )  !  Cubic spline profile option
       CALL cCubic(   cP, cS, rho, Medium, N1, Task, ENVFile, PRTFile )
    CASE DEFAULT  !  Non-existent profile option
       WRITE( PRTFile, * ) 'Profile option: ', SSP%Type
       CALL ERROUT( PRTFile, 'F', 'EvaluateSSP', 'Unknown profile option' )
    END SELECT

    RETURN
  END SUBROUTINE EvaluateSSP

  !**********************************************************************!

  SUBROUTINE n2Linear( cP, cS, rho, Medium, N1, Task, ENVFile, PRTFile )

    ! Tabulate cP, cS, rho for specified Medium
    ! Uses N2-linear segments for P and S-wave speeds
    ! Uses rho-linear segments for density

    INTEGER,           INTENT(IN)  :: ENVFile, PRTFile
    INTEGER,           INTENT( INOUT ) :: N1
    INTEGER,           INTENT(IN)  :: Medium
    REAL     (KIND=8), INTENT(OUT) :: rho( * )
    COMPLEX  (KIND=8), INTENT(OUT) :: cP( * ), cS( * )
    CHARACTER (LEN=8), INTENT(IN)  :: Task
    COMPLEX  (KIND=8)              :: N2Bot, N2Top

    ! If Task = 'INIT' then this is the first call and SSP is read.
    ! Any other call is a request for SSP subtabulation.

    IF ( Task( 1 : 4 ) == 'INIT' ) THEN   ! Task 'INIT' for initialization
       CALL ReadSSP( Medium, N1, ENVFile, PRTFile )
    ELSE   ! Task = 'TABULATE'
       ILoc = SSP%Loc( Medium )
       N    = N1 - 1
       h    = ( SSP%z( ILoc + SSP%NPts( Medium ) ) - SSP%z( ILoc + 1 ) ) / N
       Lay  = 1

       DO iz = 1, N1
          z = SSP%z( ILoc + 1 ) + ( iz - 1 ) * h
          IF ( iz == N1 ) z = SSP%z( ILoc + SSP%NPts( Medium ) )   ! Make sure no overshoot

          DO WHILE ( z > SSP%z( ILoc + Lay + 1 ) )
             Lay = Lay + 1
          END DO

          iSSP = ILoc + Lay
          R = ( z - SSP%z( iSSP ) ) / ( SSP%z( iSSP + 1 ) - SSP%z( iSSP ) )

          ! P-wave
          N2Top    = 1.0 / SSP%cp( iSSP     )**2
          N2Bot    = 1.0 / SSP%cp( iSSP + 1 )**2
          cP( iz ) = 1.0 / SQRT( ( 1.0 - R ) * N2Top + R * N2Bot )

          ! S-wave
          IF ( SSP%cs( iSSP ) /= 0.0 ) THEN
             N2Top    = 1.0 / SSP%cs( iSSP     )**2
             N2Bot    = 1.0 / SSP%cs( iSSP + 1 )**2
             cS( iz ) = 1.0 / SQRT( ( 1.0 - R ) * N2Top + R * N2Bot )
          ELSE
             cS( iz ) = 0.0
          ENDIF

          rho( iz ) = ( 1.0 - R ) * SSP%rho( iSSP ) + R * SSP%rho( iSSP + 1 )
       END DO

    ENDIF

    RETURN
  END SUBROUTINE n2Linear

  !**********************************************************************!

  SUBROUTINE cLinear( cP, cS, rho, Medium, N1, Task, ENVFile, PRTFile  )

    ! Tabulate cP, cS, rho for specified Medium
    ! Uses c-linear segments for P and S-wave speeds
    ! Uses rho-linear segments for density

    INTEGER,           INTENT(IN)  :: ENVFile, PRTFile
    INTEGER,           INTENT( INOUT ) :: N1
    INTEGER,           INTENT(IN)  :: Medium
    REAL     (KIND=8), INTENT(OUT) :: rho( * )
    COMPLEX  (KIND=8), INTENT(OUT) :: cP( * ), cS( * )
    CHARACTER (LEN=8), INTENT(IN)  :: Task

    ! If Task = 'INIT' then this is the first call and SSP is read.
    ! Any other call is a request for SSP subtabulation.

    IF ( Task( 1 : 4 ) == 'INIT' ) THEN   ! Task 'INIT' for initialization
       CALL ReadSSP( Medium, N1, ENVFile, PRTFile )
    ELSE   ! Task = 'TABULATE'
       ILoc = SSP%Loc( Medium )
       N    = N1 - 1
       h    = ( SSP%z( ILoc + SSP%NPts( Medium ) ) - SSP%z( ILoc + 1 ) ) / N
       Lay  = 1

       DO iz = 1, N1
          z = SSP%z( ILoc + 1 ) + ( iz - 1 ) * h
          IF ( iz == N1 ) z = SSP%z( ILoc + SSP%NPts( Medium ) )   ! Make sure no overshoot

          DO WHILE ( z > SSP%z( ILoc + Lay + 1 ) )
             Lay = Lay + 1
          END DO

          iSSP = ILoc + Lay
          R = ( z - SSP%z( iSSP ) ) / ( SSP%z( iSSP + 1 ) - SSP%z( iSSP ) )
          cP(  iz ) = ( 1.0 - R ) * SSP%cp(  iSSP ) + R * SSP%cp(  iSSP + 1 )
          cS(  iz ) = ( 1.0 - R ) * SSP%cs(  iSSP ) + R * SSP%cs(  iSSP + 1 )
          rho( iz ) = ( 1.0 - R ) * SSP%rho( iSSP ) + R * SSP%rho( iSSP + 1 )
       END DO
    ENDIF

    RETURN
  END SUBROUTINE cLinear

  !**********************************************************************!

  SUBROUTINE cPCHIP( cP, cS, rho, Medium, N1, Task, ENVFile, PRTFile )

    ! Tabulate cP, cS, rho values for the specified Medium
    ! Uses PCHIP segments for P, S-wave speeds and density rho

    USE pchipMod
    INTEGER,           INTENT(IN)  :: ENVFile, PRTFile
    INTEGER,           INTENT( INOUT ) :: N1
    INTEGER,           INTENT(IN)  :: Medium
    REAL     (KIND=8), INTENT(OUT) :: rho( * )
    COMPLEX  (KIND=8), INTENT(OUT) :: cP( * ), cS( * )
    CHARACTER (LEN=8), INTENT(IN)  :: Task
    REAL     (KIND=8)              :: xt

    ! If Task = 'INIT' then this is the first call and the SSP is read.
    ! Any other call is a request for SSP subtabulation.

    IF ( Task( 1 : 4 ) == 'INIT' ) THEN   ! Task 'INIT' for initialization
       CALL ReadSSP( Medium, N1, ENVFile, PRTFile )
    ELSE   ! Task = 'TABULATE'
       ILoc = SSP%Loc( Medium )
       N    = N1 - 1
       h    = ( SSP%z( ILoc + SSP%NPts( Medium ) ) - SSP%z( ILoc + 1 ) ) / N
       Lay  = 1

       DO iz = 1, N1
          z = SSP%z( ILoc + 1 ) + ( iz - 1 ) * h
          IF ( iz == N1 ) z = SSP%z( ILoc + SSP%NPts( Medium ) )   ! Make sure no overshoot
          DO WHILE ( z > SSP%z( ILoc + Lay + 1 ) )
             Lay = Lay + 1
          END DO

          iSSP = ILoc + Lay
          xt   = z - SSP%z( iSSP )

          cP(  iz ) =       SSP%cpCoef( 1,  iSSP ) &
                        + ( SSP%cpCoef( 2,  iSSP ) &
                        + ( SSP%cpCoef( 3,  iSSP ) &
                        +   SSP%cpCoef( 4,  iSSP ) * xt ) * xt ) * xt
          cS(  iz ) =       SSP%csCoef( 1,  iSSP ) &
                        + ( SSP%csCoef( 2,  iSSP ) &
                        + ( SSP%csCoef( 3,  iSSP ) &
                        +   SSP%csCoef( 4,  iSSP ) * xt ) * xt ) * xt
          rho( iz ) = DBLE( SSP%rhoCoef( 1, iSSP ) &
                        + ( SSP%rhoCoef( 2, iSSP ) &
                        + ( SSP%rhoCoef( 3, iSSP ) &
                        +   SSP%rhoCoef( 4, iSSP ) * xt ) * xt ) * xt )
       END DO
    ENDIF

    RETURN
  END SUBROUTINE cPCHIP

  !**********************************************************************!

  SUBROUTINE cCubic( cP, cS, rho, Medium, N1, Task, ENVFile, PRTFile  )

    ! Tabulate cP, cS, rho for specified Medium
    ! Uses cubic spline for P, S-wave speeds and density rho

    INTEGER,           INTENT(IN)  :: ENVFile, PRTFile
    INTEGER,           INTENT( INOUT ) :: N1
    INTEGER,           INTENT(IN)  :: Medium
    REAL     (KIND=8), INTENT(OUT) :: rho( * )
    COMPLEX  (KIND=8), INTENT(OUT) :: cP( * ), cS( * )
    CHARACTER (LEN=8), INTENT(IN)  :: Task
    REAL     (KIND=8)              :: HSPLNE
    COMPLEX  (KIND=8)              :: SPLINE

    ! If Task = 'INIT' then this is the first call and SSP is read.
    ! Any other call is a request for SSP subtabulation.

    IF ( Task( 1 : 4 ) == 'INIT' ) THEN   ! Task 'INIT' for initialization
       CALL ReadSSP( Medium, N1, ENVFile, PRTFile )
    ELSE   ! Task = 'TABULATE'
       ILoc = SSP%Loc( Medium )
       N    = N1 - 1
       h    = ( SSP%z( ILoc + SSP%NPts( Medium ) ) - SSP%z( ILoc + 1 ) ) / N
       Lay  = 1

       DO iz = 1, N1
          z = SSP%z( ILoc + 1 ) + ( iz - 1 ) * h
          IF ( iz == N1 ) z = SSP%z( ILoc + SSP%NPts( Medium ) )   ! Make sure no overshoot
          DO WHILE ( z > SSP%z( ILoc + Lay + 1 ) )
             Lay = Lay + 1
          END DO

          iSSP = ILoc + Lay
          HSPLNE = z - SSP%z( iSSP )

          cP(  iz ) =       SPLINE( SSP%cpSpline(  1, iSSP ), HSPLNE )
          cS(  iz ) =       SPLINE( SSP%csSpline(  1, iSSP ), HSPLNE )
          rho( iz ) = DBLE( SPLINE( SSP%rhoSpline( 1, iSSP ), HSPLNE ) )

       END DO
    ENDIF

    RETURN
  END SUBROUTINE cCubic

!**********************************************************************!

  SUBROUTINE ReadSSP( Medium, N1, ENVFile, PRTFile )

    ! reads the SSP data from the environmental file for a given medium

    INTEGER, INTENT( IN    ) :: ENVFile, PRTFile
    INTEGER, INTENT( IN    ) :: Medium
    INTEGER, INTENT( INOUT ) :: N1
    INTEGER                  :: iSSP

    SSP%NPts( Medium ) = N1

    ! The variable SSP%Loc( Medium ) points to the starting point for the
    ! data in the arrays z, alpha, beta and rho
    IF ( Medium == 1 ) THEN
       SSP%Loc( Medium ) = 0
    ELSE
       SSP%Loc( Medium ) = SSP%Loc( Medium - 1 ) + SSP%NPts( Medium - 1 )
    ENDIF
    ILoc = SSP%Loc( Medium )

    !  Read in data and convert attenuation to Nepers/m
    N1 = 1
    DO iSSP = 1, MaxSSP
       iz = SSP%Loc( Medium ) + iSSP

       READ(  ENVFile, *    ) SSP%z( iz ), alphaR, betaR, rhoR, alphaI, betaI
       WRITE( PRTFile, FMT="( F10.2,      3X, 2F10.2,       3X, F6.2, 3X, 2F10.4 )" ) &
                              SSP%z( iz ),    alphaR, betaR,    rhoR,     alphaI, betaI

       ! Verify that the depths are monotone increasing
       IF ( iSSP > 1 ) THEN
          IF ( SSP%z( iz ) .LE. SSP%z( iz - 1 ) ) THEN
              WRITE( PRTFile, * ) 'Bad depth in SSP: ', SSP%z( iz )
              CALL ERROUT( PRTFile, 'F', 'ReadSSP', 'The depths in the SSP must be monotone increasing' )
          END IF
       END IF

       SSP%alphaR( iz ) = alphaR
       SSP%alphaI( iz ) = alphaI
       SSP%rho(    iz ) = rhoR
       SSP%betaR(  iz ) = betaR
       SSP%betaI(  iz ) = betaI

       ! Did we read the last point?
       IF ( ABS( SSP%z( iz ) - SSP%Depth( Medium + 1 ) ) < 100. * EPSILON( 1.0e0 ) ) THEN
          SSP%NPts( Medium ) = N1
          IF ( Medium == 1 ) SSP%Depth( 1 ) = SSP%z( 1 )
          IF ( SSP%NPts( Medium ) == 1 ) THEN
              WRITE( PRTFile, * ) '#SSP points: ', SSP%NPts( Medium )
              CALL ERROUT( PRTFile, 'F', 'ReadSSP', 'The SSP must have at least 2 points in each layer' )
          END IF

          RETURN
       ENDIF

       N1 = N1 + 1
    END DO

    ! Fall through means too many points in the profile
    WRITE( PRTFile, * ) 'Max. #SSP points: ', MaxSSP
    CALL ERROUT( PRTFile, 'F', 'ReadSSP', 'Number of SSP points exceeds limit' )

  END SUBROUTINE ReadSSP

  !**********************************************************************!

  SUBROUTINE UpdateSSPLoss( freq, freq0 )
    ! Updates the imaginary part of the sound speed based on the frequency
    ! The depth of the SSP point is also used if there is a bio layer
    USE AttenMod
    USE pchipMod

    REAL     (KIND=8), INTENT(IN) :: freq, freq0   ! freq0 is the reference frequency where dB/m was specified
    INTEGER                       :: Medium
    INTEGER                       :: IBCBeg, IBCEnd

    DO Medium = 1, SSP%NMedia
       ILoc = SSP%Loc( Medium )

       DO iSSP = 1, SSP%NPts( Medium )
          iz = SSP%Loc( Medium ) + iSSP
          SSP%cp( iz ) = CRCI( SSP%z( iz ), SSP%alphaR( iz ),  SSP%alphaI( iz ), freq, freq0, &
             SSP%AttenUnit, SSP%beta( Medium), SSP%ft( Medium ) )
          SSP%cs( iz ) = CRCI( SSP%z( iz ), SSP%betaR(  iz ),  SSP%betaI(  iz ), freq, freq0, &
             SSP%AttenUnit, SSP%beta( Medium), SSP%ft( Medium ) )

          SSP%rhoT( iz ) = SSP%rho( iz )

          SSP%cpSpline(  1, iz ) = SSP%cp(  iz )
          SSP%csSpline(  1, iz ) = SSP%cs(  iz )
          SSP%rhoSpline( 1, iz ) = SSP%rho( iz )
       END DO

       ! Compute std polynomial coefs if PCHIP interpolation has been selected
       IF ( SSP%Type == 'P' ) THEN
          CALL PCHIP( SSP%z( ILoc + 1 ), SSP%cp(   ILoc + 1 ), SSP%NPts( Medium ), SSP%cpCoef(  1, ILoc + 1 ), SSP%csWork  )
          CALL PCHIP( SSP%z( ILoc + 1 ), SSP%cs(   ILoc + 1 ), SSP%NPts( Medium ), SSP%csCoef(  1, ILoc + 1 ), SSP%csWork )
          CALL PCHIP( SSP%z( ILoc + 1 ), SSP%rhoT( ILoc + 1 ), SSP%NPts( Medium ), SSP%rhoCoef( 1, ILoc + 1 ), SSP%csWork )
       END IF

       ! Compute spline coefs if spline interpolation has been selected
       IF ( SSP%Type == 'S' ) THEN
          IBCBeg = 0
          IBCEnd = 0
          CALL CSPLINE( SSP%z( ILoc + 1 ), SSP%cpSpline(  1, ILoc + 1 ), SSP%NPts( Medium ), IBCBeg, IBCEnd, SSP%NPts( Medium ) )
          CALL CSPLINE( SSP%z( ILoc + 1 ), SSP%csSpline(  1, ILoc + 1 ), SSP%NPts( Medium ), IBCBeg, IBCEnd, SSP%NPts( Medium ) )
          CALL CSPLINE( SSP%z( ILoc + 1 ), SSP%rhoSpline( 1, ILoc + 1 ), SSP%NPts( Medium ), IBCBeg, IBCEnd, SSP%NPts( Medium ) )
       END IF
    END DO
  END SUBROUTINE UpdateSSPLoss

END MODULE sspmod


!
! PP_ND
!
! Module containing forward, tangent-linear and adjoint subroutines
! for partial pressure to/from number density units conversion.
!
! CREATION HISTORY:
!       Written by:     Paul van Delst, 25-Sep-2009
!                       paul.vandelst@noaa.gov
!

MODULE PP_ND

  ! -----------------
  ! Environment setup
  ! -----------------
  ! Modules used
  USE Type_Kinds, ONLY: fp
  USE Profile_Utility_Parameters, ONLY: ZERO, ONE, &
                                        MAX_N_MOLECULAR_SPECIES, &
                                        P0, T0, L0, &
                                        PA_TO_HPA, HPA_TO_PA
  ! Disable all implicit typing
  IMPLICIT NONE

  ! ------------
  ! Visibilities
  ! ------------
  PRIVATE
  PUBLIC :: PP_to_ND, PP_to_ND_TL, PP_to_ND_AD
  PUBLIC :: ND_to_PP, ND_to_PP_TL, ND_to_PP_AD

  ! -----------------
  ! Module parameters
  ! -----------------
  CHARACTER(*), PARAMETER :: MODULE_VERSION_ID = &

CONTAINS

!------------------------------------------------------------------------------
!:sdoc+:
! NAME:
!       PP_to_ND
!
! PURPOSE:
!       Elemental subroutine to convert gas concentrations from partial
!       pressure to number density.
!
! CALLING SEQUENCE:
!       CALL PP_to_ND( Temperature     , &  ! Input
!                      Partial_Pressure, &  ! Input
!                      Number_Density    )  ! Output
!
! INPUTS:
!       Temperature:       Atmospheric temperature
!                          UNITS:      Kelvin, K
!                          TYPE:       REAL(fp)
!                          DIMENSION:  Scalar or any rank
!                          ATTRIBUTES: INTENT(IN)
!
!       Partial_Pressure:  Partial pressure of gas.
!                          NOTE: Can be the total atmospheric
!                                pressure to compute the total
!                                air number density.
!                          UNITS:      hectoPascals, hPa
!                          TYPE:       REAL(fp)
!                          DIMENSION:  Same as Temperature
!                          ATTRIBUTES: INTENT(IN)
!
! OUTPUTS:
!       Number_Density:    Number density of gas.
!                          Set to zero for invalid input.
!                          UNITS:      molecules/m^3
!                          TYPE:       REAL(fp)
!                          DIMENSION:  Same as input Temperature
!                          ATTRIBUTES: INTENT(OUT)
!
! PROCEDURE:
!       The ideal gas law is
!
!         p.V = n.R.T
!
!       where,
!         p = Pressure
!         V = volume
!         n = number of moles of the gas,
!         R = molar gas constant,
!         T = Temperature.
!
!       This can be written in terms of the number of molecules, N,
!
!                 N
!         p.V = ---- . R.T                  ..............(1)
!                NA
!
!       where NA = Avogadro's constant (number of molecules in 1 mole.)
!
!       Eqn.(1) can be recast to provide the number of molecules in the
!       volume, the number density, nd,
!
!               N     p.NA
!         nd = --- = ------  molecules/m^3  ..............(2)
!               V     R.T
!
!       At standard Temperature and Pressure (T0=273.15K, p0=101325Pa), this
!       number density is know as the Loschmidt constant, L0, the molecular
!       density of 1 mole of an ideal gas. Thus we have the generic form of
!       eqn.(2) and the STP form,
!
!               p0.NA
!         L0 = -------  molecules/m^3       ..............(3)
!               R.T0
!
!       Taking the ratio of eqns.(2) and (3) gives,
!
!         nd    p.NA     R.T0
!         -- = ------ . -------
!         L0    R.T      p0.NA
!
!       and rearranging gives,
!
!                    p      T0
!         nd = L0 . ---- . ----  molecules/m^3
!                    p0     T
!
!       The value of p0 used in this routine is expressed in pascals (Pa) whereas
!       the input partial Pressure is expected to be hPa (more common unit). Thus
!       there is a factor of 100 to include,
!
!                    100.p     T0
!         nd = L0 . ------- . ----  molecules/m^3
!                     p0       T
!
! CREATION HISTORY:
!       Written by:     Paul van Delst, 15-Nov-2001
!                       paul.vandelst@noaa.gov
!:sdoc-:
!------------------------------------------------------------------------------

  ELEMENTAL SUBROUTINE PP_to_ND( &
    Temperature     , &  ! Input
    Partial_Pressure, &  ! Input
    Number_Density    )  ! Output
    ! Arguments
    REAL(fp), INTENT(IN)  :: Temperature
    REAL(fp), INTENT(IN)  :: Partial_Pressure
    REAL(fp), INTENT(OUT) :: Number_Density
    ! Local variables
    REAL(fp) :: c

    ! Setup
    Number_Density = ZERO
    IF ( Temperature < ZERO .OR. Partial_Pressure < ZERO ) RETURN

    ! Convert partial pressure to number density
    c = HPA_TO_PA * L0 * T0 / P0
    Number_Density = c * Partial_Pressure / Temperature

  END SUBROUTINE PP_to_ND

!------------------------------------------------------------------------------
!:sdoc+:
! NAME:
!       PP_to_ND_TL
!
! PURPOSE:
!       Tangent-linear form of elemental subroutine to convert gas
!       concentrations from partial pressure to number density.
!
! CALLING SEQUENCE:
!       CALL PP_to_ND_TL( Temperature        , &  ! FWD Input
!                         Partial_Pressure   , &  ! FWD Input
!                         Temperature_TL     , &  ! TL  Input
!                         Partial_Pressure_TL, &  ! TL  Input
!                         Number_Density_TL    )  ! TL  Output
!
! INPUTS:
!       Temperature:          Atmospheric temperature
!                             UNITS:      Kelvin, K
!                             TYPE:       REAL(fp)
!                             DIMENSION:  Scalar or any rank
!                             ATTRIBUTES: INTENT(IN)
!
!       Partial_Pressure:     Partial pressure of gas.
!                             NOTE: Can be the total atmospheric
!                                   pressure to compute the total
!                                   air number density.
!                             UNITS:      hectoPascals, hPa
!                             TYPE:       REAL(fp)
!                             DIMENSION:  Same as Temperature
!                             ATTRIBUTES: INTENT(IN)
!
!       Temperature_TL:       Tangent-linear atmospheric temperature
!                             UNITS:      Kelvin, K
!                             TYPE:       REAL(fp)
!                             DIMENSION:  Same as Temperature
!                             ATTRIBUTES: INTENT(IN)
!
!       Partial_Pressure_TL:  Tangent-linear partial pressure of gas.
!                             UNITS:      hectoPascals, hPa
!                             TYPE:       REAL(fp)
!                             DIMENSION:  Same as Temperature
!                             ATTRIBUTES: INTENT(IN)
!
! OUTPUTS:
!       Number_Density_TL:    Tangent-linear number density of gas.
!                             Set to zero for invalid input.
!                             UNITS:      molecules/m^3
!                             TYPE:       REAL(fp)
!                             DIMENSION:  Same as input Temperature
!                             ATTRIBUTES: INTENT(OUT)
!
!       Written by:     Paul van Delst, 25-Sep-2009
!                       paul.vandelst@noaa.gov
!:sdoc-:
!------------------------------------------------------------------------------

  ELEMENTAL SUBROUTINE PP_to_ND_TL( &
    Temperature        , &  ! FWD Input
    Partial_Pressure   , &  ! FWD Input
    Temperature_TL     , &  ! TL  Input
    Partial_Pressure_TL, &  ! TL  Input
    Number_Density_TL    )  ! TL  Output
    ! Arguments
    REAL(fp), INTENT(IN)  :: Temperature
    REAL(fp), INTENT(IN)  :: Partial_Pressure
    REAL(fp), INTENT(IN)  :: Temperature_TL
    REAL(fp), INTENT(IN)  :: Partial_Pressure_TL
    REAL(fp), INTENT(OUT) :: Number_Density_TL
    ! Local variables
    REAL(fp) :: c

    ! Setup
    Number_Density_TL = ZERO
    IF ( Temperature < ZERO .OR. Partial_Pressure < ZERO ) RETURN

    ! Tangent-linear form of partial pressure to number density conversion
    c = HPA_TO_PA * L0 * T0 / P0
    Number_Density_TL = c * ((Temperature * Partial_Pressure_TL) - &
                             (Partial_Pressure * Temperature_TL)) / Temperature**2

  END SUBROUTINE PP_to_ND_TL

!------------------------------------------------------------------------------
!:sdoc+:
! NAME:
!       PP_to_ND_AD
!
! PURPOSE:
!       Adjoint form of elemental subroutine to convert gas
!       concentrations from partial pressure to number density.
!
! CALLING SEQUENCE:
!       CALL PP_to_ND_AD( Temperature        , &  ! FWD Input
!                         Partial_Pressure   , &  ! FWD Input
!                         Number_Density_AD  , &  ! AD  Input
!                         Temperature_AD     , &  ! AD  Output
!                         Partial_Pressure_AD  )  ! AD  Output
!
! INPUTS:
!       Temperature:          Atmospheric temperature
!                             UNITS:      Kelvin, K
!                             TYPE:       REAL(fp)
!                             DIMENSION:  Scalar or any rank
!                             ATTRIBUTES: INTENT(IN)
!
!       Partial_Pressure:     Partial pressure of gas.
!                             NOTE: Can be the total atmospheric
!                                   pressure to compute the total
!                                   air number density.
!                             UNITS:      hectoPascals, hPa
!                             TYPE:       REAL(fp)
!                             DIMENSION:  Same as Temperature
!                             ATTRIBUTES: INTENT(IN)
!
!       Number_Density_AD:    Adjoint number density of gas.
!                             *** SET TO ZERO ON EXIT ***
!                             UNITS:      molecules/m^3
!                             TYPE:       REAL(fp)
!                             DIMENSION:  Same as Temperature
!                             ATTRIBUTES: INTENT(IN OUT)
!
! OUTPUTS:
!       Temperature_AD:       Adjoint atmospheric temperature
!                             *** MUST HAVE VALUE ON ENTRY ***
!                             UNITS:      Kelvin, K
!                             TYPE:       REAL(fp)
!                             DIMENSION:  Same as input Temperature
!                             ATTRIBUTES: INTENT(IN OUT)
!
!       Partial_Pressure_AD:  Adjoint partial pressure of gas.
!                             *** MUST HAVE VALUE ON ENTRY ***
!                             UNITS:      hectoPascals, hPa
!                             TYPE:       REAL(fp)
!                             DIMENSION:  Same as input Temperature
!                             ATTRIBUTES: INTENT(IN OUT)
!
! CREATION HISTORY:
!       Written by:     Paul van Delst, 25-Sep-2009
!                       paul.vandelst@noaa.gov
!:sdoc-:
!------------------------------------------------------------------------------

  ELEMENTAL SUBROUTINE PP_to_ND_AD( &
    Temperature        , &  ! FWD Input
    Partial_Pressure   , &  ! FWD Input
    Number_Density_AD  , &  ! AD  Input
    Temperature_AD     , &  ! AD  Output
    Partial_Pressure_AD  )  ! AD  Output
    ! Arguments
    REAL(fp), INTENT(IN)     :: Temperature
    REAL(fp), INTENT(IN)     :: Partial_Pressure
    REAL(fp), INTENT(IN OUT) :: Number_Density_AD
    REAL(fp), INTENT(IN OUT) :: Temperature_AD
    REAL(fp), INTENT(IN OUT) :: Partial_Pressure_AD
    ! Local variables
    REAL(fp) :: c

    ! Setup
    IF ( Temperature < ZERO .OR. Partial_Pressure < ZERO ) THEN
      Number_Density_AD     = ZERO
      Temperature_AD      = ZERO
      Partial_Pressure_AD = ZERO
      RETURN
    END IF

    ! Adjoint form of partial pressure to number density conversion
    c = HPA_TO_PA * L0 * T0 / P0
    Temperature_AD = Temperature_AD - (c * Partial_Pressure * Number_Density_AD / Temperature**2)
    Partial_Pressure_AD = Partial_Pressure_AD + (c * Number_Density_AD / Temperature)
    Number_Density_AD = ZERO

  END SUBROUTINE PP_to_ND_AD

!------------------------------------------------------------------------------
!:sdoc+:
! NAME:
!       ND_to_PP
!
! PURPOSE:
!       Elemental subroutine to convert gas concentration number density
!       to partial pressure.
!
! CALLING SEQUENCE:
!       CALL ND_to_PP( Temperature     , &  ! Input
!                      Number_Density  , &  ! Input
!                      Partial_Pressure  )  ! Output
!
! INPUTS:
!       Temperature:       Atmospheric temperature
!                          UNITS:      Kelvin, K
!                          TYPE:       REAL(fp)
!                          DIMENSION:  Scalar or any rank
!                          ATTRIBUTES: INTENT(IN)
!
!       Number_Density:    Number density of gas.
!                          NOTE: Can be the total air number
!                                density to compute the total
!                                atmospheric pressure.
!                          UNITS:      molecules/m^3
!                          TYPE:       REAL(fp)
!                          DIMENSION:  Same as Temperature
!                          ATTRIBUTES: INTENT(IN)
!
! OUTPUTS:
!       Partial_Pressure:  Partial pressure of gas.
!                          Set to zero for invalid input.
!                          UNITS:      hectoPascals, hPa
!                          TYPE:       REAL(fp)
!                          DIMENSION:  Same as input Temperature
!                          ATTRIBUTES: INTENT(OUT)
!
! PROCEDURE:
!       The ideal gas law is
!
!         p.V = n.R.T
!
!       where,
!         p = Pressure
!         V = volume
!         n = number of moles of the gas,
!         R = molar gas constant,
!         T = Temperature.
!
!       This can be written in terms of the number of molecules, N,
!
!                 N
!         p.V = ---- . R.T                  ..............(1)
!                NA
!
!       where NA = Avogadro's constant (number of molecules in 1 mole.)
!
!       Recasting eqn.(1) to provide the Pressure,
!
!              nd
!         p = ---- . R.T  Pa                ..............(2)
!              NA
!
!       where nd = the number density in molecules/m^3 = N/V.
!
!       At standard Temperature and Pressure (T0=273.15K, p0=101325Pa), the
!       number density of eqn.(2) is known as the Loschmidt constant, L0,
!       the molecular density of 1 mole of an ideal gas. Thus we have the
!       generic form of eqn.(2) and the STP form,
!
!               L0
!         p0 = ---- . R.T0  Pa              ..............(3)
!               NA
!
!       Taking the ratio of eqns.(2) and (3) gives,
!
!          p      nd     T
!         ---- = ---- . ----  Pa
!          p0     L0     T0
!
!       and rearranging gives,
!
!                   nd      T
!         p = p0 . ---- . ----  Pa
!                   L0     T0
!
!       The value of p0 used in this routine is expressed in pascals (Pa) whereas
!       the output Pressure is returned as hPa (more common unit). Thus there
!       is a factor of 100 to include,
!
!                          nd      T
!         p = 0.01 . p0 . ---- . ----  hPa
!                          L0     T0
!
! CREATION HISTORY:
!       Written by:     Paul van Delst, 15-Nov-2001
!                       paul.vandelst@noaa.gov
!:sdoc-:
!------------------------------------------------------------------------------

  ELEMENTAL SUBROUTINE ND_to_PP( &
    Temperature     , &  ! Input
    Number_Density  , &  ! Input
    Partial_Pressure  )  ! Output
    ! Arguments
    REAL(fp), INTENT(IN)  :: Temperature
    REAL(fp), INTENT(IN)  :: Number_Density
    REAL(fp), INTENT(OUT) :: Partial_Pressure
    ! Local variables
    REAL(fp) :: c

    ! Setup
    Partial_Pressure = ZERO
    IF ( Temperature < ZERO .OR. Number_Density < ZERO ) RETURN

    ! Convert number density to partial pressure
    c = PA_TO_HPA * P0 / ( L0 * T0 )
    Partial_Pressure = c * Number_Density * Temperature

  END SUBROUTINE ND_to_PP

!------------------------------------------------------------------------------
!:sdoc+:
! NAME:
!       ND_to_PP_TL
!
! PURPOSE:
!       Tangent-linear form of elemental subroutine to convert gas
!       concentration number density to partial pressure.
!
! CALLING SEQUENCE:
!       CALL ND_to_PP_TL( Temperature        , &  ! FWD Input
!                         Number_Density     , &  ! FWD Input
!                         Temperature_TL     , &  ! TL  Input
!                         Number_Density_TL  , &  ! TL  Input
!                         Partial_Pressure_TL  )  ! TL  Output
!
! INPUTS:
!       Temperature:          Atmospheric temperature
!                             UNITS:      Kelvin, K
!                             TYPE:       REAL(fp)
!                             DIMENSION:  Scalar or any rank
!                             ATTRIBUTES: INTENT(IN)
!
!       Number_Density:       Number density of gas.
!                             NOTE: Can be the total air number
!                                   density to compute the total
!                                   atmospheric pressure.
!                             UNITS:      molecules/m^3
!                             TYPE:       REAL(fp)
!                             DIMENSION:  Same as Temperature
!                             ATTRIBUTES: INTENT(IN)
!
!       Temperature_TL:       Tangent-linear atmospheric temperature
!                             UNITS:      Kelvin, K
!                             TYPE:       REAL(fp)
!                             DIMENSION:  Same as Temperature
!                             ATTRIBUTES: INTENT(IN)
!
!       Number_Density_TL:    Tangent-linear number density of gas.
!                             UNITS:      molecules/m^3
!                             TYPE:       REAL(fp)
!                             DIMENSION:  Same as Temperature
!                             ATTRIBUTES: INTENT(IN)
!
! OUTPUTS:
!       Partial_Pressure_TL:  Tangent-linear partial pressure of gas.
!                             Set to zero for invalid input.
!                             UNITS:      hectoPascals, hPa
!                             TYPE:       REAL(fp)
!                             DIMENSION:  Same as input Temperature
!                             ATTRIBUTES: INTENT(OUT)
!
! CREATION HISTORY:
!       Written by:     Paul van Delst, 25-Sep-2009
!                       paul.vandelst@noaa.gov
!:sdoc-:
!------------------------------------------------------------------------------

  ELEMENTAL SUBROUTINE ND_to_PP_TL( &
    Temperature        , &  ! FWD Input
    Number_Density     , &  ! FWD Input
    Temperature_TL     , &  ! TL  Input
    Number_Density_TL  , &  ! TL  Input
    Partial_Pressure_TL  )  ! TL  Output
    ! Arguments
    REAL(fp), INTENT(IN)  :: Temperature
    REAL(fp), INTENT(IN)  :: Number_Density
    REAL(fp), INTENT(IN)  :: Temperature_TL
    REAL(fp), INTENT(IN)  :: Number_Density_TL
    REAL(fp), INTENT(OUT) :: Partial_Pressure_TL
    ! Local variables
    REAL(fp) :: c

    ! Setup
    Partial_Pressure_TL = ZERO
    IF ( Temperature < ZERO .OR. Number_Density < ZERO ) RETURN

    ! Tangent-linear form of number density to partial pressure conversion
    c = PA_TO_HPA * P0 / ( L0 * T0 )
    Partial_Pressure_TL = c * ((Number_Density * Temperature_TL) + &
                               (Temperature * Number_Density_TL) )

  END SUBROUTINE ND_to_PP_TL

!------------------------------------------------------------------------------
!:sdoc+:
! NAME:
!       ND_to_PP_AD
!
! PURPOSE:
!       Adjoint form of elemental subroutine to convert gas
!       concentration number density to partial pressure.
!
! CALLING SEQUENCE:
!       CALL ND_to_PP_AD( Temperature        , &  ! FWD Input
!                         Number_Density     , &  ! FWD Input
!                         Partial_Pressure_AD, &  ! AD  Input
!                         Temperature_AD     , &  ! AD  Output
!                         Number_Density_AD    )  ! AD  Output
!
! INPUTS:
!       Temperature:          Atmospheric temperature
!                             UNITS:      Kelvin, K
!                             TYPE:       REAL(fp)
!                             DIMENSION:  Scalar or any rank
!                             ATTRIBUTES: INTENT(IN)
!
!       Number_Density:       Number density of gas.
!                             NOTE: Can be the total air number
!                                   density to compute the total
!                                   atmospheric pressure.
!                             UNITS:      molecules/m^3
!                             TYPE:       REAL(fp)
!                             DIMENSION:  Same as Temperature
!                             ATTRIBUTES: INTENT(IN)
!
!       Partial_Pressure_AD:  Adjoint partial pressure of gas.
!                             *** SET TO ZERO ON EXIT ***
!                             UNITS:      hectoPascals, hPa
!                             TYPE:       REAL(fp)
!                             DIMENSION:  Same as Temperature
!                             ATTRIBUTES: INTENT(IN OUT)
!
! OUTPUTS:
!       Temperature_AD:       Adjoint atmospheric temperature
!                             *** MUST HAVE VALUE ON ENTRY ***
!                             UNITS:      Kelvin, K
!                             TYPE:       REAL(fp)
!                             DIMENSION:  Same as input Temperature
!                             ATTRIBUTES: INTENT(IN OUT)
!
!       Number_Density_AD:    Adjoint number density of gas.
!                             *** MUST HAVE VALUE ON ENTRY ***
!                             UNITS:      molecules/m^3
!                             TYPE:       REAL(fp)
!                             DIMENSION:  Same as input Temperature
!                             ATTRIBUTES: INTENT(IN OUT)
!
! CREATION HISTORY:
!       Written by:     Paul van Delst, 25-Sep-2009
!                       paul.vandelst@noaa.gov
!:sdoc-:
!------------------------------------------------------------------------------

  ELEMENTAL SUBROUTINE ND_to_PP_AD( &
    Temperature        , &  ! FWD Input
    Number_Density     , &  ! FWD Input
    Partial_Pressure_AD, &  ! AD  Input
    Temperature_AD     , &  ! AD  Output
    Number_Density_AD    )  ! AD  Output
    ! Arguments
    REAL(fp), INTENT(IN)     :: Temperature
    REAL(fp), INTENT(IN)     :: Number_Density
    REAL(fp), INTENT(IN OUT) :: Partial_Pressure_AD
    REAL(fp), INTENT(IN OUT) :: Temperature_AD
    REAL(fp), INTENT(IN OUT) :: Number_Density_AD
    ! Local variables
    REAL(fp) :: c

    ! Setup
    IF ( Temperature < ZERO .OR. Number_Density < ZERO ) THEN
      Partial_Pressure_AD = ZERO
      Temperature_AD      = ZERO
      Number_Density_AD     = ZERO
      RETURN
    END IF

    ! Adjoint form of number density to partial pressure conversion
    c = PA_TO_HPA * P0 / ( L0 * T0 )
    Number_Density_AD = Number_Density_AD + (c * Temperature    * Partial_Pressure_AD)
    Temperature_AD    = Temperature_AD    + (c * Number_Density * Partial_Pressure_AD)
    Partial_Pressure_AD = ZERO

  END SUBROUTINE ND_to_PP_AD

END MODULE PP_ND


SUBROUTINE p111(input_file,output_file)
!-------------------------------------------------------------------------
! Program 11.1 Forced vibration analysis of elastic beams using 2-node
!              beam elements. Consistent mass. Newmark time stepping.
!-------------------------------------------------------------------------
 USE main
 USE geom
 IMPLICIT NONE
 CHARACTER(len=60),INTENT(IN) :: input_file
 CHARACTER(len=60),INTENT(OUT) :: output_file
 INTEGER,PARAMETER::iwp=SELECTED_REAL_KIND(15)
 INTEGER::i,iel,j,k,lnode,lsense,ndof=4,nels,neq,nlen,nlf,nn,nod=2,       &
   nodof=2,nof,nlfp,nprops=2,np_types,nr,nstep
 REAL(iwp)::beta,dtim,fk,fm,f1,f2,gamma,one=1.0_iwp,pt5=0.5_iwp,          &
   zero=0.0_iwp
 CHARACTER(LEN=15)::argv
!-----------------------dynamic arrays------------------------------------
 INTEGER,ALLOCATABLE::etype(:),g(:),g_g(:,:),kdiag(:),lf(:),lp(:),nf(:,:),&
   node(:),num(:),sense(:)
 REAL(iwp),ALLOCATABLE::a(:),acc(:,:),al(:,:),a1(:),b1(:),cv(:),d(:),     &
   dis(:,:),ell(:),kd(:),km(:,:),kp(:),kv(:),mc(:),mm(:,:),mv(:),         &
   prop(:,:),rl(:),rt(:),v(:),vc(:),vel(:,:)
!-----------------------input and initialisation--------------------------
 OPEN(10,FILE=input_file)
 OPEN(11,FILE=output_file)
 READ(10,*)nels,np_types
 nn=nels+1
 ALLOCATE(nf(nodof,nn),km(ndof,ndof),mm(ndof,ndof),num(nod),g(ndof),      &
   prop(nprops,np_types),ell(nels),g_g(ndof,nels),etype(nels))
 READ(10,*)prop
 etype=1
 IF(np_types>1)READ(10,*)etype
 READ(10,*)ell,dtim,beta,gamma,fm,fk
 nf=1
 READ(10,*)nr,(k,nf(:,k),i=1,nr)
 CALL formnf(nf)
 neq=MAXVAL(nf)
 ALLOCATE(kdiag(neq),a1(0:neq),b1(0:neq),vc(0:neq),kd(0:neq),a(0:neq),    &
   d(0:neq),v(0:neq))
 kdiag=0
!-----------------------loop the elements to find global array sizes------
 elements_1: DO iel=1,nels
   num=(/iel,iel+1/)
   CALL num_to_g(num,nf,g)
   g_g(:,iel)=g
   CALL fkdiag(kdiag,g)
 END DO elements_1
 DO i=2,neq
   kdiag(i)=kdiag(i)+kdiag(i-1)
 END DO
 ALLOCATE(kv(kdiag(neq)),cv(kdiag(neq)),mv(kdiag(neq)),mc(kdiag(neq)),    &
   kp(kdiag(neq)))
 WRITE(11,'(2(A,I5))')                                                    &
   " There are",neq," equations and the skyline storage is",kdiag(neq)
 kv=zero
 mv=zero
!-----------------------global stiffness and mass matrix assembly---------
 elements_2: DO iel=1,nels
   CALL beam_km(km,prop(1,etype(iel)),ell(iel))
   CALL beam_mm(mm,prop(2,etype(iel)),ell(iel))
   g=g_g(:,iel)
   CALL fsparv(kv,km,g,kdiag)
   CALL fsparv(mv,mm,g,kdiag)
 END DO elements_2
 mc=mv
!-----------------------initial conditions, and load functions------------
 d=zero
 v=zero   !  alternatively READ(10,*)d(1:),v(1:)
 READ(10,*)nlf
 ALLOCATE(lf(nlf))
 DO k=1,nlf
   READ(10,*)lnode,lsense,nlfp
   ALLOCATE(rt(nlfp),rl(nlfp))
   lf(k)=nf(lsense,lnode)
   READ(10,*)(rt(j),rl(j),j=1,nlfp)
   IF(k==1)THEN
     nstep=NINT((rt(nlfp)-rt(1))/dtim)+1
     ALLOCATE(al(nstep,nlf))
   END IF
   CALL interp(k,dtim,rt,rl,al,nstep)
   DEALLOCATE(rt,rl)
 END DO
 f1=beta*dtim**2
 f2=beta*dtim
 cv=fm*mv+fk*kv
 kp=mv/f1+gamma*cv/f2+kv
 CALL sparin(mc,kdiag)
 CALL sparin(kp,kdiag)
 a=zero
 a(lf(:))=al(1,:)
 CALL linmul_sky(cv,v,vc,kdiag)
 CALL linmul_sky(kv,d,kd,kdiag)
 a=a-vc-kd
 CALL spabac(mc,a,kdiag)
 READ(10,*)nof
 ALLOCATE(node(nof),sense(nof),lp(nof),dis(nstep,nof),vel(nstep,nof),     &
   acc(nstep,nof))
 READ(10,*)(node(i),sense(i),i=1,nof)
 DO i=1,nof
   lp(i)=nf(sense(i),node(i))
 END DO
 dis(1,:)=d(lp)
 vel(1,:)=v(lp)
 acc(1,:)=a(lp)
!-----------------------time stepping loop--------------------------------
 DO j=2,nstep
   a1=d/f1+v/f2+a*(pt5/beta-one)
   b1=gamma*d/f2-v*(one-gamma/beta)-dtim*a*(one-pt5*gamma/beta)
   CALL linmul_sky(mv,a1,vc,kdiag)
   CALL linmul_sky(cv,b1,kd,kdiag)
   d=vc+kd
   d(lf(:))=d(lf(:))+al(j,:)
   CALL spabac(kp,d,kdiag)
   v=gamma*d/f2-b1
   a=d/f1-a1
   dis(j,:)=d(lp)
   vel(j,:)=v(lp)
   acc(j,:)=a(lp)
 END DO
 DO i=1,nof
   WRITE(11,'(/,2(A,I3))')" Output at node",node(i),", sense",sense(i)
   WRITE(11,'(A)')"    time        disp        velo        accel"
   DO j=1,nstep
   WRITE(11,'(4E12.4)')(j-1)*dtim,dis(j,i),vel(j,i),acc(j,i)
   END DO
 END DO
END SUBROUTINE p111


*     MB03VD EXAMPLE PROGRAM TEXT
*     Copyright (c) 2002-2020 NICONET e.V.
*
*     .. Parameters ..
      INTEGER          NIN, NOUT
      PARAMETER        ( NIN = 5, NOUT = 6 )
      INTEGER          NMAX, PMAX
      PARAMETER        ( NMAX = 20, PMAX = 20 )
      INTEGER          LDA1, LDA2, LDQ1, LDQ2, LDTAU
      PARAMETER        ( LDA1 = NMAX, LDA2 = NMAX, LDQ1 = NMAX,
     $                   LDQ2 = NMAX, LDTAU = NMAX-1 )
      INTEGER          LDWORK
      PARAMETER        ( LDWORK = NMAX )
      DOUBLE PRECISION ZERO, ONE
      PARAMETER        ( ZERO = 0.0D0, ONE = 1.0D0 )
*     .. Local Scalars ..
      DOUBLE PRECISION SSQ
      INTEGER          I, IHI, ILO, INFO, J, K, KP1, N, P
*     .. Local Arrays ..
      DOUBLE PRECISION A(LDA1,LDA2,PMAX), AS(LDA1,LDA2,PMAX),
     $                 DWORK(LDWORK), Q(LDQ1,LDQ2,PMAX),
     $                 QTA(LDQ1,NMAX), TAU(LDTAU,PMAX)
*     .. External Functions ..
      DOUBLE PRECISION DLANGE, DLAPY2
      EXTERNAL         DLANGE, DLAPY2
*     .. External Subroutines ..
      EXTERNAL         DGEMM, DLACPY, DLASET, MB03VD, MB03VY
*     .. Intrinsic Functions ..
      INTRINSIC        MIN
*     .. Executable Statements ..
      WRITE (NOUT, FMT = 99999 )
*     Skip the heading in the data file and read the data.
      READ ( NIN, FMT = '()' )
      READ ( NIN, FMT = * ) N, P, ILO, IHI
      IF ( N.LT.0 .OR. N.GT.MIN( LDA1, LDA2 ) ) THEN
         WRITE ( NOUT, FMT = 99991 ) N
      ELSE
         IF ( P.LE.0 .OR. P.GT.PMAX ) THEN
            WRITE ( NOUT, FMT = 99990 ) P
         ELSE
*           Read matrices A_1, ..., A_p from the input file.
            DO 10 K = 1, P
               READ ( NIN, FMT = * )
     $            ( ( A(I,J,K), J = 1, N ), I = 1, N )
               CALL DLACPY( 'F', N, N, A(1,1,K), LDA1, AS(1,1,K), LDA1 )
   10       CONTINUE
*           Reduce to the periodic Hessenberg form.
            CALL MB03VD( N, P, ILO, IHI, A, LDA1, LDA2, TAU, LDTAU,
     $                   DWORK, INFO )
            IF ( INFO.NE.0 ) THEN
               WRITE ( NOUT, FMT = 99998 ) INFO
            ELSE
               WRITE ( NOUT, FMT = 99996 )
               DO 30 K = 1, P
                  CALL DLACPY( 'L', N, N, A(1,1,K), LDA1, Q(1,1,K),
     $                         LDQ1 )
                  IF ( N.GT.1 ) THEN
                     IF ( N.GT.2 .AND. K.EQ.1 ) THEN
                        CALL DLASET( 'L', N-2, N-2, ZERO, ZERO,
     $                               A(3,1,K), LDA1 )
                     ELSE IF ( K.GT.1 ) THEN
                        CALL DLASET( 'L', N-1, N-1, ZERO, ZERO,
     $                               A(2,1,K), LDA1 )
                     END IF
                  END IF
                  WRITE ( NOUT, FMT = 99995 ) K
                  DO 20 I = 1, N
                     WRITE ( NOUT, FMT = 99994 ) ( A(I,J,K), J = 1, N )
   20             CONTINUE
   30          CONTINUE
*              Accumulate the transformations.
               CALL MB03VY( N, P, ILO, IHI, Q, LDQ1, LDQ2, TAU, LDTAU,
     $                      DWORK, LDWORK, INFO )
               IF ( INFO.NE.0 ) THEN
                  WRITE ( NOUT, FMT = 99997 ) INFO
               ELSE
                  WRITE ( NOUT, FMT = 99993 )
                  DO 50 K = 1, P
                     WRITE ( NOUT, FMT = 99995 ) K
                     DO 40 I = 1, N
                        WRITE ( NOUT, FMT = 99994 )
     $                        ( Q(I,J,K), J = 1, N )
   40                CONTINUE
   50             CONTINUE
*                 Compute error.
                  SSQ = ZERO
                  DO 60 K = 1, P
                     KP1 = K+1
                     IF( KP1.GT.P ) KP1 = 1
*                    Compute NORM (Z' * A * Z - Aout)
                     CALL DGEMM( 'T', 'N', N, N, N, ONE, Q(1,1,K), LDQ1,
     $                           AS(1,1,K), LDA1, ZERO, QTA, LDQ1 )
                     CALL DGEMM( 'N', 'N', N, N, N, ONE, QTA, LDQ1,
     $                           Q(1,1,KP1), LDQ1, -ONE, A(1,1,K),
     $                           LDA1 )
                     SSQ = DLAPY2( SSQ,
     $                             DLANGE( 'Frobenius', N, N, A(1,1,K),
     $                                     LDA1, DWORK ) )
   60             CONTINUE
                  WRITE ( NOUT, FMT = 99992 ) SSQ
               END IF
            END IF
         END IF
      END IF
      STOP
99999 FORMAT (' MB03VD EXAMPLE PROGRAM RESULTS', /1X)
99998 FORMAT (' INFO on exit from MB03VD = ', I2)
99997 FORMAT (' INFO on exit from MB03VY = ', I2)
99996 FORMAT (' Reduced matrices')
99995 FORMAT (/' K = ', I5)
99994 FORMAT (8F8.4)
99993 FORMAT (/' Transformation matrices')
99992 FORMAT (/,' NORM (Q''*A*Q - Aout) = ', 1PD12.5)
99991 FORMAT (/, ' N is out of range.',/' N = ', I5)
99990 FORMAT (/, ' P is out of range.',/' P = ', I5)
      END


c*************************************************************************
c                          ANAL_JACOBI.F
c*************************************************************************
c Calculates the Jacobi integral of a particle given the position and velocity
c and ang. velocity vector of the Sun and Planet
c
c      Input:
c            msun          ==>   Mass of the Sun (real scalar)
c            mpl           ==>   Mass of the Planet (real scalar)
c            omegax,..y,z  ==>   vector components of planet-sun orbit's
c                                 angular velocity vector(real scalars)
c            xb,yb,zb      ==>   Barycentric position of particle
c                                   (real scalars)
c            vxb,vyb,vzb   ==>   Barycentric vel of particle (real scalars)
c            xsb,ysb,zsb   ==>   Barycentric position of Sun (real scalars)
c            xplb,yplb,zplb ==>  Barycentric position of planet (real scalars)
c
c       Output:
c            jacobi         ==>  Value of the jacobi constant
c
c Remarks:
c Authors:  Martin Duncan
c Date:   April 13/93
c Last revision:  3/4/93 HFL

      subroutine anal_jacobi(msun,mpl,omegax,omegay,omegaz,xb,yb,zb,
     &      vxb,vyb,vzb,xsb,ysb,zsb,xplb,yplb,zplb,jacobi)

      include '../swift.inc'

c...  Inputs:
      real*8 msun,mpl,omegax,omegay,omegaz,xb,yb,zb,vxb,vyb,vzb
      real*8 xsb,ysb,zsb,xplb,yplb,zplb

c...  Outputs:
      real*8 jacobi

c...  Internals
      real*8 rr,jx,jy,jz

c----
c...  Executable code

      jacobi = 0.5d0*(vxb**2 + vyb**2 + vzb**2)

      rr = sqrt((xb-xsb)**2 + (yb-ysb)**2 + (zb-zsb)**2)
      jacobi = jacobi - msun/rr

      rr = sqrt((xb-xplb)**2 + (yb-yplb)**2 + (zb-zplb)**2)
      jacobi = jacobi - mpl/rr

      jx = yb*vzb - zb*vyb
      jy = zb*vxb - xb*vzb
      jz = xb*vyb - yb*vxb

      jacobi = jacobi - omegax*jx - omegay*jy - omegaz*jz

      return
      end       ! anal_jacobi
c-------------------------------------------------------------------------


 	PROGRAM EDECAY
C
C	ELECTROSTATIC DECAY OF LANGMUIR WAVE
C
	REAL K0,K1,K2,K1P,K1M,K2P,K2M
	DATA TWOPI /6.2831865/
C
	FP = 22500.
	EB = 5.			! KEV
   	TE = 10.					! EV
   	TI = 10.					! EV
C	Bardwell and Goldman, Ap.J. 209,912, (1976)
C	Weatherall, Goldman and Nicholson, Ap.J.  (1981)
	FP = 90.E6
	EB = 27.5			! KEV
   	TE = 140.					! EV
   	TI = 140.					! EV
   	VB = SQRT(2.*EB/.511E3)*3.E8			! M/SEC
   	VS = SQRT((TE + 3.*TI)/.511E6/1836.)*3.E8       ! M/SEC
   	VT2 = TE*(3.E8)**2/.511E6
C
  	K0 = TWOPI*FP/VB				! m^-1
  	W02 = (TWOPI*FP)**2 + 3.*VT2*K0**2
   	W0 = SQRT(W02)					! radians/sec
   	print*,'k0,w0',k0,w0
C
C	QUADRATIC FOR K1 = DAUGHTER LANGMUIR WAVE, ONE IS ALWAYS SAME AS K0
C
   	AA = 3.*VT2 - VS**2
   	BB = -2.*VS*(W0 - K0*VS)
  	CC = (TWOPI*FP)**2 - (W0-K0*VS)**2
   	DISC = BB**2 - 4.*AA*CC
   	K1P = .5*(-BB+SQRT(DISC))/AA
   	K1M = .5*(-BB-SQRT(DISC))/AA
C
   	PRINT*,AA,BB,CC,DISC
   	PRINT*,'k1+, k1-',K1P,K1M
   	K2M = K0 - K1M
   	K2P = K0 - K1P
	WPL = VS*K2P
	WMN = VS*K2M
   	PRINT*,'k2+,w+,k2-,w-',K2P,WPL,K2M,WMN
   	STOP
   	END


module MKL_wrapper
    Contains
	subroutine PRINT_MATRIX( DESC, M, N, A, LDA )
        CHARACTER*(*)    DESC
        INTEGER          M, N, LDA
        INTEGER          M1, N1
        COMPLEX          A( LDA, * )

        INTEGER          I, J

        WRITE(*,*)
        WRITE(*,*) DESC
        M1 = M
        N1 = N
        if (M1>5) M1 = 5
        if (N1>5) N1 = 5
        DO I = 1, M1
           WRITE(*,9998) ( A( I, J ), J = 1, N1 )
        END DO

  9998 FORMAT( 11(:,1X,'(',F6.2,',',F6.2,')') )
      end

    subroutine random_z(N, Mat)
    !
    !   Generate Random matrix Z
    !
        implicit none
        integer(4) N
        complex(8), dimension (*):: Mat

        integer, dimension( 4 )  ::	ISEED
        real T1,T2
        print *, 'Init random matrix ', N
        ISEED = (/ 1, 2, 3, 4 /)
       ! call cpu_time(T1)
        call zlarnv(1, ISEED, N, mat)
        !call cpu_time(T2)
        print *, "init matrix time = ", T2-T1
        print *

    end subroutine random_z

    subroutine mkl_le_solver(A, B)
    !
    ! Solve the complex equations A*X = B.
    !
    !     .. Parameters ..
	    INTEGER          N, NRHS
	    PARAMETER        ( NRHS = 1 )
	    INTEGER          LDA, LDB

    !     .. Local Scalars ..
	    INTEGER          INFO

    !     .. Local Arrays ..
	    INTEGER, dimension (:), allocatable ::   IPIV
	    complex(8), dimension (:,:) :: A
	    complex(8), dimension (:,:) :: B

	    integer, dimension( 4 )  ::	ISEED

        N = size(B)
        !print *, N
        LDA = N
        LDB = N

        ISEED = (/ 1, 2, 3, 4 /)

        allocate ( IPIV(N) )

        !CALL PRINT_MATRIX( 'A matrix', N, N, A, LDA )

        !Solve the equations A*X = B.
        CALL ZGESV ( N, NRHS, A, LDA, IPIV, B, LDB, INFO )

        IF( INFO.GT.0 ) THEN
            WRITE(*,*)'The diagonal element of the triangular factor of A,'
            WRITE(*,*)'U(',INFO,',',INFO,') is zero, so that'
            WRITE(*,*)'A is singular; the solution could not be computed.'
            STOP
        END IF

    end subroutine mkl_le_solver

 end module MKL_wrapper


program demo_textang
   use :: M_draw

   !! set up drawing environment
   call prefsize(600,600)
   call vinit(' ') ! start graphics using device $M_draw_DEVICE
   call ortho2(-100.0,100.0,-100.0,100.0)
   call textsize(7.0,7.0)
   call linewidth(20)
   call color(D_BLACK)
   call clear()

   do i=1,30
      !! draw radial lines
      call color(D_RED)
      call move2(0.0,0.0)
      call draw2(100.0*cosd(i*12.0),100.0*sind(i*12.0))
      !! draw rotated text
      call color(D_WHITE)
      call move2(30.0*cosd(i*12.0),30.0*sind(i*12.0))
      call textang(i*12.0)
      call drawstr('angled text')
   enddo

   ipaws=getkey()

   call vexit()

contains
   elemental real function sind(angle_in_degrees)
      doubleprecision,parameter :: PI= 3.14159265358979323846264338327950288419716939937510d0
      doubleprecision,parameter :: degrees_to_radians = PI / 180.0D+00
      real,intent(in) :: angle_in_degrees
      sind=sin(angle_in_degrees*degrees_to_radians)
   end function sind
   elemental real function cosd(angle_in_degrees)
      doubleprecision,parameter :: PI= 3.14159265358979323846264338327950288419716939937510d0
      doubleprecision,parameter :: degrees_to_radians = PI / 180.0D+00
      real,intent(in) :: angle_in_degrees
      cosd=cos(angle_in_degrees*degrees_to_radians)
   end function cosd
end program demo_textang


! gfortran elemental_demo.f90 && ./a.out

program elemental_demo
  real, dimension(3) :: x, y

  x = [1.0, 2.0, 3.0]
  y = f(x)
  print *, x
  print *, y

contains

  elemental function f(x)
    real, intent(in) :: x
    real :: f

    f = x**3 -  x + 0.25
  end function
end program elemental_demo


C subroutine to take a step in the Metropolis algorithm
       SUBROUTINE METROP(X1,X2,WEIGHT,DELTA)
       EXTERNAL WEIGHT
       INTEGER SEED
       DATA SEED/39249187/

       X1T=X1+DELTA*(2*RAN(SEED)-1)
       X2T=X2+DELTA*(2*RAN(SEED)-1)
       RATIO=WEIGHT(X1T,X2T)/WEIGHT(X1,X2)

       IF (RATIO .GT. RAN(SEED)) THEN
           X1=X1T
           X2=X2T
       END IF

       RETURN
       END


program main
    use plantFEM
    implicit none

    real(real64)   :: CO2, O2, C
    real(real64)   :: dt,t
    integer(int32) :: i
    type(Reactor_) :: reactor
    type(Logger_)  :: Logger
    type(Console_) :: console

    CO2 = 0.0d0 ! mol
    C   = 1.0d0 ! mol
    O2  = 1.0d0 ! mol

    ! initalize reactor
    call reactor%init()
    call reactor%put("CO2", CO2)
    call reactor%put("C"  ,   C)
    call reactor%put("O2" ,  O2)
    ! define reactor with reaction coefficient (in here, = 1.0)
    call reactor%define([str("C"),str("O2")],[str("CO2")],0.10d0)
    ! If (a/=1 or b/=1 or c/=1) and  (nA/=1 or nB/=1 or nC/=1) and
    !  a*[A] + b*[B] -> c*[C]
    ! - d A/dt = k[A]^nA*[B]^nB
    ! then please add args
    !  mol_rate=[a,b,c],reaction_order=[nA,nB])

    ! initialize data-logger
    call logger%set("CO2",CO2)
    call logger%set("C",C  )
    call logger%set("O2", O2)
    call logger%start()

    t = 0.0d0
    do
      ! read values from console
      call console%log("Type [exit] to exit/if not, type [continue]>>>")
      call console%read()

      if(console%asChar()=="exit") exit

      call console%log("How much C (mol/L) do you add?>>>")
      call console%read()
      C = C + console%asReal()
      call console%log("How much O2 (mol/L) do you add?>>>")
      call console%read()
      O2 = O2 + console%asReal()
      call console%log("How much CO2 (mol/L) do you add?>>>")
      call console%read()
      CO2 = CO2 + console%asReal()

      dt = 0.010d0
      ! run t=0.0 to 10.0s
      do i=1,1000
        t = t+dt
        call reactor%run(dt=dt)
        ! save data
        call logger%save(t = t)
      enddo

    enddo

  end program main


MODULE ccs

  implicit none

CONTAINS

  subroutine perm(n,p)

    ! ARGUMENTS
    integer :: n
    integer :: p(n)

    ! LOCAL ARRAYS
    integer :: t(n)

    ! LOCAL SCALARS
    integer :: sizet,i,r
    real(8) :: rd

    do i = 1,n
       t(i) = i
    end do

    sizet = n

    do i = 1,n
       call RANDOM_NUMBER(rd)
       r = int(1 + sizet * rd)
       p(i) = t(r)
       t(r) = t(sizet)
       sizet = sizet - 1
    end do

  end subroutine perm

  subroutine serialccs(m1,n,M,b,x,r,iter,eps,maxit)

    ! SCALAR ARGUMENTS
    integer :: n,iter,m1,maxit
    real(8) :: eps,r

    ! ARRAY ARGUMENTS
    real(8) :: M(n,n),b(n),x(n)

    intent(in   ) :: M,b,n,eps,maxit
    intent(out  ) :: r,iter
    intent(inout) :: x

    ! LOCAL SCALARS
    integer :: i,j,k,curr,delay
    real(8) :: s,rd

    ! LOCAL ARRAYS
    integer :: p(m1)
    real(8) :: back(n,m1)

    r = 0
    do i = 1,n
       s = b(i)
       do j = 1,n
          s = s - M(i,j) * x(j)
       end do
       r = max(r,abs(s))
    end do

    iter = 0

    do j = 1,m1
       do i = 1,n
          back(i,j) = x(i)
       end do
    end do

    do while (r .gt. eps)

       call perm(n,p)

       do i = n+1,m1
          call RANDOM_NUMBER(rd)
	  p(i) = INT(1 + n * rd)
       end do

       ! UPDATING X

       do k = 1,m1

          curr = 1 + mod(iter,m1)

          do i = 1,n
             back(i,curr) = x(i)
          end do

          call RANDOM_NUMBER(rd)

          delay = int(1 + m1 * rd)

          call updatexh(p(k),p(k),n,M,b,back(:,1+mod(m1 + curr - delay,m1)),x)

          ! STOPPING CRITERIUM

          r = 0
          do i = 1,n
             s = b(i)
             do j = 1,n
                s = s - M(i,j) * x(j)
             end do

             r = max(r,abs(s))
             if (r > eps) then
                exit
             end if
          end do

          iter = iter + 1

          if (r .le. eps) then
             exit
          end if

       end do

    end do

  end subroutine serialccs

  subroutine updatexh(start,end,n,M,b,x,xout)

    ! This subroutine applies a Jacobi step in a subset of the rows
    ! and variables of the system. The input vector considered is 'x'
    ! and the output vector is 'xout'.

    ! ARGUMENTS
    integer :: start,end,n
    real(8) :: M(n,n),b(n),x(n),xout(n),tmp(start:end)

    intent(in   ) :: start,end,n,M,b
    intent(inout) :: xout

    ! LOCAL SCALARS
    integer :: i,j
    real(8) :: s

    do i = start,end
       s = b(i)
       do j = 1,n
          if (i .ne. j) then
             s = s - M(i,j) * x(j)
          end if
       end do
       tmp(i) = s / M(i,i)
    end do

    do i = start,end
       xout(i) = tmp(i)
    end do

  end subroutine updatexh

END MODULE ccs


      SUBROUTINE dampin(neq,damp,veloc,dtime)
!****************************************************************
!
!     includes damping diminishing the velocities
!
!****************************************************************
!$ USE omp_lib
      IMPLICIT NONE

      INTEGER (kind=4),INTENT(IN) :: neq
      REAL (kind=8),INTENT(IN) :: dtime,damp(:)
      REAL (kind=8),INTENT(IN OUT) :: veloc(:)

      INTEGER (kind=4) :: ieq
      REAL    (kind=8) :: factor

 !$OMP DO PRIVATE(factor)
      DO ieq=1,neq
        factor = 1d0 - 2d0*damp(ieq)*dtime
        veloc(ieq) = factor*veloc(ieq)
      END DO
 !$OMP END DO

      RETURN
      END SUBROUTINE dampin


submodule(euler_interface_m) euler_prob_0057_m
    ! use euler_mi_m
    use euler_multiprecision_m
    implicit none

contains

    module character(len=20) function euler0057()
        write (euler0057, "(i20)") ans(1000)
    end function euler0057

    integer function ans(u_bound)
        integer, intent(in) :: u_bound
        integer :: i, k
        type(multiprecision_int_t) :: a, b, c

        i = 1; k = 0
        a = '1'; b = '2'

        do
            if (i == u_bound) exit

            a = a + b*2
            call swap_long(a, b)
            c = a + b
            if (size(c%arr) > size(b%arr)) k = k + 1
            i = i + 1
        end do
        ans = k
    end function ans

    subroutine swap_long(a, b)
        type(multiprecision_int_t), intent(inout) :: a, b
        type(multiprecision_int_t) :: tmp

        call move_alloc(a%arr, tmp%arr)
        call move_alloc(b%arr, a%arr)
        call move_alloc(tmp%arr, b%arr)
    end subroutine swap_long

end submodule euler_prob_0057_m