!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
!	model.f90
!
!	Written by Josh Allen (jwallen@mit.edu)
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

module ModelModule

    use NetworkModule

    implicit none

contains

    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
    !
    ! Subroutine: fitChebyshevModel()
    !
    ! Fits a set of rate coefficients k(T, P) fitted at multiple temperatures
    ! and pressures to a model of the form
    !
    !		log k(T, P) = sum_i sum_j alpha_ij * phi_i(Tred) * phi_j(Pred)
    !
    ! where
    !
    !		Tred = (2/T - 1/Tmin - 1/Tmax) / (1/Tmax - 1/Tmin)
    !		Pred = (2 log P - log Pmin - log Pmax) / (log Pmax - log Pmin)
    !
    ! and phi_n(x) is the nth Chebyshev polynomial evaluated at x.
    !
    ! Parameters:
    !		K - Matrix of phenomenological rate coefficients.
    !		Tlist - Vector of absolute temperatures in K.
    !		Plist - Vector of pressures in bar.
    !		nChebT - Number of temperatures to use to fit Chebyshev polynomials
    !		nChebP - Number of pressures to use to fit Chebyshev polynomials
    !		alpha - Matrix of coefficients.
    subroutine fitChebyshevModel(K, Tlist, Plist, Tmin, Tmax, Pmin, Pmax, nChebT, nChebP, alpha)

        real(8), dimension(:,:), intent(in) :: K
        real(8), dimension(:), intent(in) :: Tlist
        real(8), dimension(:), intent(in) :: Plist
        real(8), intent(in) :: Tmin, Tmax, Pmin, Pmax
        integer, intent(in) :: nChebT
        integer, intent(in) :: nChebP
        real(8), dimension(:,:), intent(inout) :: alpha

        real(8), dimension(:), allocatable :: Tred
        real(8), dimension(:), allocatable :: Pred

        real(8), dimension(:,:), allocatable :: A
        real(8), dimension(:,:), allocatable :: b

        integer nT, nP, t, p, t1, p1, t2, p2
        real(8) phiT, phiP

        ! Variables for BLAS and LAPACK
        integer :: info
        integer, dimension(:), allocatable :: work
        integer :: one
        character :: N

        ! Determine number of temperatures and pressures used
        nT = size(Tlist)
        nP = size(Plist)

        allocate( Tred(1:nT), Pred(1:nP) )
        allocate( A(1:nT*nP, 1:nChebT*nChebP), b(1:nT*nP,1) )

        ! Calculate reduced temperatures and pressures
        do t = 1, nT
            Tred(t) = (2.0 / Tlist(t) - 1.0 / Tmin - 1.0 / Tmax) / &
                (1.0 / Tmax - 1.0 / Tmin)
        end do
        do p = 1, nP
            Pred(p) = (2.0 * log(Plist(p)) - log(Pmin) - log(Pmax)) / &
                (log(Pmax) - log(Pmin))
        end do

        ! Populate A matrix and b vector
        ! A_ij = phi_j1(T_i) * phi_j2(P_i)
        ! b_i = log10(k(T_i, P_i))
        do t1 = 1, nT
            do p1 = 1, nP
                do t2 = 1, nChebT
                    do p2 = 1, nChebP
                        call chebyshev(t2-1, Tred(t1), phiT)
                        call chebyshev(p2-1, Pred(p1), phiP)
                        A((p1-1)*nT+t1, (p2-1)*nChebT+t2) = phiT * phiP
                    end do
                end do
            b((p1-1)*nT+t1,1) = log10(K(t1,p1))
            end do
        end do

        ! Solve Ax = b to determine coefficients alpha_ij
        allocate( work(1:8*nChebT*nChebP) )
        one = 1
        N = 'N'
        call DGELS(N, nT*nP, nChebT*nChebP, one, A, nT*nP, b, nT*nP, work, 8*nChebT*nChebP, info)
        if (info > 0) then
            write (*,*), "Chebyshev fit matrix is singular!"
            stop
        end if
        do t = 1, nChebT
            do p = 1, nChebP
                alpha(t,p) = b((p-1)*nChebT+t,1)
            end do
        end do

        ! Clean up
        deallocate( Tred, Pred, A, b, work )

    end subroutine

    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
    !
    ! Subroutine: fitPDepArrheniusModel()
    !
    ! Fits a set of rate coefficients k(T, P) fitted at multiple temperatures
    ! and pressures to a model of the form
    !
    !		log k(T, P) = A(P) * T**n(P) * exp( - Ea(P) / (R * T) )
    !
    ! Parameters:
    !		K - Matrix of phenomenological rate coefficients.
    !		Tlist - Vector of absolute temperatures in K.
    !		Plist - Vector of pressures in bar.
    !		arrhenius - Matrix of coefficients.
    subroutine fitPDepArrheniusModel(K, Tlist, Plist, arrhenius)

        real(8), dimension(:,:), intent(in) :: K
        real(8), dimension(:), intent(in) :: Tlist
        real(8), dimension(:), intent(in) :: Plist
        type(ArrheniusKinetics), dimension(:), intent(inout) :: arrhenius

        real(8), dimension(:,:), allocatable :: A
        real(8), dimension(:), allocatable :: b

        integer t, p, nT, nP
        real(8) R

        ! Variables for BLAS and LAPACK
        integer :: info
        integer, dimension(:), allocatable :: work
        integer :: one
        character :: N

        R = 8.314472    ! [=] J/mol*K

        nT = size(Tlist)
        nP = size(Plist)

        allocate( A(1:nT, 1:3), b(1:nT) )
        allocate( work(1:8*nT) )

        ! At each pressure, fit a modified Arrhenius kinetics model
        do p = 1, nP

            ! Populate A matrix and b vector for linear least-squares fit
            do t = 1, nT
                A(t,1) = 1.0
                A(t,2) = log(Tlist(t))
                A(t,3) = -1.0 / (R * Tlist(t))
                b(t) = log(K(t,p))
            end do

            ! Solve Ax = b to determine Arrhenius coefficients
            one = 1
            N = 'N'
            call DGELS(N, nT, 3, one, A, nT, b, nT, work, 8*nT, info)
            if (info > 0) then
                write (*,*), "Log P interpolate fit matrix is singular!"
                stop
            end if

            ! Extract Arrhenius coefficients
            arrhenius(p)%A = exp(b(1))
            arrhenius(p)%n = b(2)
            arrhenius(p)%Ea = b(3)

        end do

        ! Clean up
        deallocate( work, A, b )

    end subroutine

    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
    !
    ! Subroutine: chebyshev()
    !
    ! Evaluates the nth Chebyshev polynomial of the first kind at the value x.
    !
    ! Parameters:
    !		n - Index of Chebyshev polynomial
    !		x - Value to evaluate the polynomial at.
    !		phi - Index of nth Chebyshev polynomial
    subroutine chebyshev(n, x, phi)

        integer, intent(in) :: n
        real(8), intent(in) :: x
        real(8), intent(out) :: phi

        phi = cos(n * acos(x));

    end subroutine

end module


program modecoupmat_inside

!  compute the convolution matrix due to a mask inside a square patch
!   inf: input file of mask field [1:ni,1:nj] (real)
!   outf: output field of mode coupling matrix of EE, BB, EB power
!          [1:npmax*3,1:npmax*3] (real)

  use fieldinfo_
  use sub_
  implicit none

  integer :: i,j,i1,j1,id,jd,id1,jd1,im,jm,nn(2),np1,np2
  real, pointer :: mask(:,:)
  real ::  num(npmax),fmask(ni*2,nj)
  real ::  l,area,cellarea,pbl,qbl,powm,lnyq
  real ::  l1,l2,l3,g1,g2,g3,cosj,cosj2,sinj,sinj2,l2x,l2y
  double precision ::  mmat(npmax2,npmax2),dmmat_auto,dmmat_cros
  character :: inf*100,outf*100

  call getarg(1,inf)
  call getarg(2,outf)

  call binninginit
  call readmask(inf,mask)

  nn(1)=ni
  nn(2)=nj
  area=rad1*rad2
  cellarea=area/float(ni)/float(nj)

  fmask=0.
  do j=1,nj
     do i=1,ni
        fmask(2*i-1,j)=mask(i,j)*cellarea
     enddo
  enddo

  deallocate(mask)

  call fourn(fmask,nn,2,-1)

  num=0.
  mmat=0.d0

  lnyq=2.*pi/rad1*(float(ni)/2.)

  write(*,*) 'start calculation of mode coupling matrix due to the simulated mask'
  do j=1,nj
     write(*,*) j,'/',nj
     j1 = j-1
     if (j1>nj/2)  j1 = j1 - nj
     do i=1,ni/2+1
        i1 = i-1

        g1=sqrt(float(i1*i1+j1*j1))
        l1=g1/rad1*(2.*pi)
        if (l1<llowbin(1)) cycle
        if (l1>=llowbin(npmax+1)) cycle
        pbl=l1*l1/(2.*pi)

        np1=1
        do while (l1>=llowbin(np1))
           np1=np1+1
        enddo
        np1=np1-1

        if ((i1==0).or.(i1==ni/2)) then
           num(np1)=num(np1)+1.
        else
           num(np1)=num(np1)+2.
        endif

        do jd=1,nj
           jd1 = jd-1
           if (jd1>nj/2)  jd1 = jd1 - nj
           do id=1,ni
              id1 = id-1
              if (id1>ni/2)  id1 = id1 - ni

              l2x=float(id1)/rad1*2.*pi
              l2y=float(jd1)/rad2*2.*pi
              g2=sqrt(float(id1*id1+jd1*jd1))
              l2=g2/rad1*(2.*pi)
              if (l2<llowbin(1)) cycle
              if (l2>=llowbin(npmax+1)) cycle
              qbl=(2.*pi)/l2/l2

              np2=1
              do while (l2>=llowbin(np2))
                 np2=np2+1
              enddo
              np2=np2-1

              im=i1-id1
              jm=j1-jd1
!
!!! comment out if aliasing effect is included
!
!              if (abs(im)>ni/2) cycle
!              if (abs(jm)>nj/2) cycle

              im=mod(im+ni,ni)+1
              jm=mod(jm+nj,nj)+1

              powm=(fmask(2*im-1,jm)**2+fmask(2*im,jm)**2)/area

              cosj=(i1*id1+j1*jd1)/g1/g2
              cosj2=2.*cosj*cosj-1.
              sinj=(i1*jd1-j1*id1)/g1/g2
              sinj2=2.*sinj*cosj

              dmmat_auto=pbl*qbl*powm*cosj2*cosj2
              dmmat_cros=pbl*qbl*powm*sinj2*sinj2

              if ((i1>0).and.(i1<ni/2)) then
                 dmmat_auto=dmmat_auto*2
                 dmmat_cros=dmmat_cros*2
              endif

              mmat(np1,np2)=mmat(np1,np2)+dmmat_auto
              mmat(np1+npmax,np2+npmax)=mmat(np1+npmax,np2+npmax)+dmmat_auto
              mmat(np1,np2+npmax)=mmat(np1,np2+npmax)+dmmat_cros
              mmat(np1+npmax,np2)=mmat(np1+npmax,np2)+dmmat_cros
           enddo
        enddo
     enddo
  enddo

  do np2=1,npmax2
     do np1=1,npmax
        if (num(np1)>0.) then
           mmat(np1,np2)=mmat(np1,np2)/num(np1)/area
           mmat(np1+npmax,np2)=mmat(np1+npmax,np2)/num(np1)/area
        else
           if (np2==np1) mmat(np1,np2)=1.d0
           if (np2/=np1) mmat(np1,np2)=0.d0
        endif
     enddo
  enddo

  open(2,file=outf,status='unknown')
  do np2=1,npmax3
     do np1=1,npmax3
        if ((np1.le.npmax2).and.(np2.le.npmax2)) then
           write(2,*) np1,np2,mmat(np1,np2)
        elseif ((np1>npmax2).and.(np2>npmax2)) then
           i=mod(np1-1,npmax)+1
           j=mod(np2-1,npmax)+1
           write(2,*) np1,np2,mmat(i,j)-mmat(i+npmax,j)
        else
           write(2,*) np1,np2,0.d0
        endif
     enddo
     write(2,*)
  enddo
  close(2)

contains

  subroutine readmask(inf,mask)

    use fieldinfo_
    use sub_
    implicit none

    real, pointer :: mask(:,:)
    character :: inf*100

    allocate(mask(ni,nj))
    open(1,file=inf,status='old',form='unformatted')
    read(1) mask
    close(1)

  end subroutine readmask

end program modecoupmat_inside


subroutine  STOMRS
  use simsphere_mod

!       INCLUDE 'modvars.h'

!  This program calculates stomatal resistance coefficients are
!  initialized in stmcof.for

  if ( TF .GT. MINTEMP .AND. TF .LT. MAXTEMP ) then
    if ( PSISUP.GT. PSIWC ) then
      FPSIE = 1 + B1 * PSIE
    else
      FPSIE = 1 + B1 * PSICE + B2 * ( PSICE - PSIE )
    end if
  else
    RS = 5000
    PRINT*, 'TEMPERATURE IS LESS THAN OR GREATER THAN THE'
    PRINT*, 'CRITICAL TEMPERATURE -- STOMATAL RESISTANCE '
    PRINT*, 'SET EQUAL TO 5000 S M-1'
    return

  end if

  RS = RMIN * FS * FPSIE * FT

  return
end


!========================================================================
!
!                   S P E C F E M 2 D  Version 7 . 0
!                   --------------------------------
!
!     Main historical authors: Dimitri Komatitsch and Jeroen Tromp
!                              CNRS, France
!                       and Princeton University, USA
!                 (there are currently many more authors!)
!                           (c) October 2017
!
! This software is a computer program whose purpose is to solve
! the two-dimensional viscoelastic anisotropic or poroelastic wave equation
! using a spectral-element method (SEM).
!
! This program is free software; you can redistribute it and/or modify
! it under the terms of the GNU General Public License as published by
! the Free Software Foundation; either version 3 of the License, or
! (at your option) any later version.
!
! This program is distributed in the hope that it will be useful,
! but WITHOUT ANY WARRANTY; without even the implied warranty of
! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
! GNU General Public License for more details.
!
! You should have received a copy of the GNU General Public License along
! with this program; if not, write to the Free Software Foundation, Inc.,
! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
!
! The full text of the license is available in file "LICENSE".
!
!========================================================================

  subroutine compute_arrays_source(ispec_selected_source,xi_source,gamma_source,sourcearray, &
                                   Mxx,Mzz,Mxz,xix,xiz,gammax,gammaz,xigll,zigll,nspec)

  use constants, only: CUSTOM_REAL,NGLLX,NGLLZ,NGLJ,NDIM,ZERO

  use specfem_par, only: AXISYM,is_on_the_axis,xiglj

  implicit none

  integer,intent(in) :: ispec_selected_source
  integer,intent(in) :: nspec

  double precision,intent(in) :: xi_source,gamma_source
  double precision,intent(in) :: Mxx,Mzz,Mxz

  real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLZ,nspec) :: xix,xiz,gammax,gammaz

  real(kind=CUSTOM_REAL), dimension(NDIM,NGLLX,NGLLZ) :: sourcearray

  double precision :: xixd,xizd,gammaxd,gammazd

! Gauss-Lobatto-Legendre points of integration and weights
  double precision, dimension(NGLLX) :: xigll
  double precision, dimension(NGLLZ) :: zigll

! source arrays
  double precision, dimension(NGLLX) :: hxis,hpxis
  double precision, dimension(NGLLZ) :: hgammas,hpgammas

  integer :: k,m

  double precision :: hlagrange
  double precision :: dsrc_dx,dsrc_dz
  double precision :: dxis_dx,dgammas_dx
  double precision :: dxis_dz,dgammas_dz

! compute Lagrange polynomials at the source location
! the source does not necessarily correspond to a Gauss-Lobatto point
  if (AXISYM) then
    if (is_on_the_axis(ispec_selected_source)) then ! TODO verify if we have to add : .and. myrank == islice_selected_source(i)
      call lagrange_any(xi_source,NGLJ,xiglj,hxis,hpxis)
    else
      call lagrange_any(xi_source,NGLLX,xigll,hxis,hpxis)
    endif
  else
    call lagrange_any(xi_source,NGLLX,xigll,hxis,hpxis)
  endif
  call lagrange_any(gamma_source,NGLLZ,zigll,hgammas,hpgammas)

  dxis_dx = ZERO
  dxis_dz = ZERO
  dgammas_dx = ZERO
  dgammas_dz = ZERO

  do m = 1,NGLLZ
    do k = 1,NGLLX

        xixd    = xix(k,m,ispec_selected_source)
        xizd    = xiz(k,m,ispec_selected_source)
        gammaxd = gammax(k,m,ispec_selected_source)
        gammazd = gammaz(k,m,ispec_selected_source)

        hlagrange = hxis(k) * hgammas(m)

        dxis_dx = dxis_dx + hlagrange * xixd
        dxis_dz = dxis_dz + hlagrange * xizd
        dgammas_dx = dgammas_dx + hlagrange * gammaxd
        dgammas_dz = dgammas_dz + hlagrange * gammazd

    enddo
  enddo

! calculate source array
  sourcearray(:,:,:) = ZERO

  do m = 1,NGLLZ
    do k = 1,NGLLX

        dsrc_dx = (hpxis(k)*dxis_dx)*hgammas(m) + hxis(k)*(hpgammas(m)*dgammas_dx)
        dsrc_dz = (hpxis(k)*dxis_dz)*hgammas(m) + hxis(k)*(hpgammas(m)*dgammas_dz)

        sourcearray(1,k,m) = sourcearray(1,k,m) + real(Mxx*dsrc_dx + Mxz*dsrc_dx,kind=CUSTOM_REAL)
        sourcearray(2,k,m) = sourcearray(2,k,m) + real(Mxz*dsrc_dx + Mzz*dsrc_dz,kind=CUSTOM_REAL)

    enddo
  enddo

  end subroutine compute_arrays_source

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

  subroutine read_adj_source(irec_local,adj_source_file)

! reads in adjoint source file

  use constants, only: IIN,MAX_STRING_LEN,CUSTOM_REAL,NDIM,mygroup

!  use specfem_par, only: myrank,NSTEP,P_SV,seismotype,source_adjoint

   use specfem_par

  implicit none

  integer,intent(in) :: irec_local

  character(len=MAX_STRING_LEN),intent(in) :: adj_source_file

  ! local parameters
  integer :: icomp, itime
  integer :: ier
  double precision :: junk
  double precision,dimension(NSTEP,3) :: adj_src_s

  character(len=3) :: comp(3)
  character(len=MAX_STRING_LEN) :: filename, path_to_add

  ! initializes temporary array
  ! note: we need to explicitly initialize the full array,
  !       otherwise it can lead to a floating overflow problem (with intel compiler 15.x)
  !       when copying the temporary array into the actual storage array adj_sourcearray
  adj_src_s(:,:) = 0.d0

  if (seismotype == 1 .or. seismotype == 2 .or. seismotype == 3) then
    ! displacement/velocity/acceleration
    comp = (/"BXX","BXY","BXZ"/)

    ! reads corresponding components
    do icomp = 1,3
      ! skips unnecessary components
      if (P_SV) then
        ! P_SV-case: skips BXY component
        if (icomp == 2) cycle
      else
        ! SH-case: skips BXX and BXZ components
        if (icomp == 1 .or. icomp == 3) cycle
      endif

      ! reads in ascii adjoint source files **.adj
      filename = 'SEM/'//trim(adj_source_file) // '.'// comp(icomp) // '.adj'

      !-----------------------------------------------------------------------------
      ! this section added by dj 12/11/2018
      ! see if we are running several independent runs in parallel
      ! if so, add the right directory for that run
      ! (group numbers start at zero, but directory names start at run0001, thus we add one)
      ! a negative value for "mygroup" is a convention that indicates that groups (i.e. sub-communicators, one per run) are off

      if (NUMBER_OF_SIMULTANEOUS_RUNS > 1 .and. mygroup >= 0) then
        write(path_to_add,"('run',i4.4,'/')") mygroup + 1
        filename = path_to_add(1:len_trim(path_to_add))//filename(1:len_trim(filename))
      endif

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

      open(unit = IIN, file = trim(filename), iostat = ier)
      if (ier /= 0) then
        print *,'Error: could not find adjoint source file ',trim(filename)
        print *,'Please check if file exists...'
        call exit_MPI(myrank,'file '//trim(filename)//' does not exist')
      endif

      do itime = 1, NSTEP
        read(IIN,*) junk, adj_src_s(itime,icomp)
      enddo
      close(IIN)
    enddo

  else if (seismotype == 4) then
    ! pressure
    ! reads in ascii adjoint source files **.PRE.adj
    filename = 'SEM/'//trim(adj_source_file) // '.PRE.adj'
    open(unit = IIN, file = trim(filename), iostat = ier)
    if (ier /= 0) call exit_MPI(myrank,'file '//trim(filename)//' does not exist')

    ! reads only single component
    do itime = 1, NSTEP
      read(IIN,*) junk, adj_src_s(itime,1)
    enddo
    close(IIN)

  else if (seismotype == 6) then
    ! potential
    ! reads in ascii adjoint source files **.POT.adj
    filename = 'SEM/'//trim(adj_source_file) // '.POT.adj'
    open(unit = IIN, file = trim(filename), iostat = ier)
    if (ier /= 0) call exit_MPI(myrank,'file '//trim(filename)//' does not exist')

    ! reads only single component
    do itime = 1, NSTEP
      read(IIN,*) junk, adj_src_s(itime,1)
    enddo
    close(IIN)

  endif

  if (P_SV) then
    ! P_SV-case
    source_adjoint(irec_local,:,1) = real(adj_src_s(:,1),kind=CUSTOM_REAL)
    source_adjoint(irec_local,:,2) = real(adj_src_s(:,3),kind=CUSTOM_REAL)
  else
    ! SH-case
    source_adjoint(irec_local,:,1) = real(adj_src_s(:,2),kind=CUSTOM_REAL)
  endif

  end subroutine read_adj_source

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

  subroutine read_adj_source_SU(seismotype)

! reads in all adjoint sources in SU-file format

  use constants, only: CUSTOM_REAL,MAX_STRING_LEN,NDIM,mygroup

  use specfem_par, only: myrank, NSTEP, nrec, &
                         islice_selected_rec, P_SV,source_adjoint,NUMBER_OF_SIMULTANEOUS_RUNS

  implicit none

  integer,intent(in) :: seismotype

  ! local parameters
  integer :: irec, irec_local, ier
  character(len=MAX_STRING_LEN) :: filename, path_to_add

  ! SU
  integer(kind=4) :: r4head(60)
  integer(kind=2) :: header2(2)

  real(kind=4),dimension(:,:),allocatable :: adj_src_s

  ! opens adjoint source files in SU format
  if (seismotype == 4 .or. seismotype == 6) then
    ! pressure/potential type
    write(filename, "('./SEM/Up_file_single.su.adj')")
    open(111,file=trim(filename),access='direct',recl=240+4*NSTEP,iostat = ier)
    if (ier /= 0) call exit_MPI(myrank,'file '//trim(filename)//' does not exist')
  else
    ! displacement/velocity/acceleration type
    if (P_SV) then
      ! P_SV-case
      write(filename, "('./SEM/Ux_file_single.su.adj')")

      !----------------------------------------------------
      ! added by dj 12/11/2018, see above for comments

      if (NUMBER_OF_SIMULTANEOUS_RUNS > 1 .and. mygroup >= 0) then
        write(path_to_add,"('run',i4.4,'/')") mygroup + 1
        filename = path_to_add(1:len_trim(path_to_add))//filename(1:len_trim(filename))
      endif

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

      open(111,file=trim(filename),access='direct',recl=240+4*NSTEP,iostat = ier)
      if (ier /= 0) call exit_MPI(myrank,'file '//trim(filename)//' does not exist')

      write(filename, "('./SEM/Uz_file_single.su.adj')")

      !----------------------------------------------------
      ! added by dj 12/11/2018, see above for comments

      if (NUMBER_OF_SIMULTANEOUS_RUNS > 1 .and. mygroup >= 0) then
        write(path_to_add,"('run',i4.4,'/')") mygroup + 1
        filename = path_to_add(1:len_trim(path_to_add))//filename(1:len_trim(filename))
      endif

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

      open(113,file=trim(filename),access='direct',recl=240+4*NSTEP,iostat = ier)
      if (ier /= 0) call exit_MPI(myrank,'file '//trim(filename)//' does not exist')
    else
      ! SH-case
      write(filename, "('./SEM/Uy_file_single.su.adj')")

      !--------------------------------------------------
      ! added by dj 12/11/2018, see above for comments

      if (NUMBER_OF_SIMULTANEOUS_RUNS > 1 .and. mygroup >= 0) then
        write(path_to_add,"('run',i4.4,'/')") mygroup + 1
        filename = path_to_add(1:len_trim(path_to_add))//filename(1:len_trim(filename))
      endif

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

      open(112,file=trim(filename),access='direct',recl=240+4*NSTEP,iostat = ier)
      if (ier /= 0) call exit_MPI(myrank,'file '//trim(filename)//' does not exist')
    endif

  endif

  ! allocates temporary array
  allocate(adj_src_s(NSTEP,NDIM))

  irec_local = 0
  do irec = 1, nrec

    ! only process/slice holding receiver
    if (myrank == islice_selected_rec(irec)) then
      irec_local = irec_local + 1

      adj_src_s(:,:) = 0.0

      if (seismotype == 4 .or. seismotype == 6) then
        ! pressure/potential
        ! single component
        read(111,rec=irec,iostat=ier) r4head, adj_src_s(:,1)
        if (ier /= 0) call exit_MPI(myrank,'file '//trim(filename)//' read error')
      else
        ! displacement/velocity/acceleration
        if (P_SV) then
          ! P_SV-case
          read(111,rec=irec,iostat=ier) r4head, adj_src_s(:,1)
          if (ier /= 0) call exit_MPI(myrank,'file '//trim(filename)//' read error')

          read(113,rec=irec,iostat=ier) r4head, adj_src_s(:,2)
          if (ier /= 0) call exit_MPI(myrank,'file '//trim(filename)//' read error')
        else
          ! SH-case
          read(112,rec=irec,iostat=ier) r4head, adj_src_s(:,1)
          if (ier /= 0) call exit_MPI(myrank,'file '//trim(filename)//' read error')
        endif
      endif

      header2 = int(r4head(29), kind=2)

      if (P_SV) then
        ! P_SV-case
        source_adjoint(irec_local,:,1) = real(adj_src_s(:,1),kind=CUSTOM_REAL)
        source_adjoint(irec_local,:,2) = real(adj_src_s(:,2),kind=CUSTOM_REAL)
      else
        ! SH-case
        source_adjoint(irec_local,:,1) = real(adj_src_s(:,1),kind=CUSTOM_REAL)
      endif

    endif !  if (myrank == islice_selected_rec(irec))
  enddo ! irec

  ! closes files
  if (seismotype == 4) then
    close(111)
  else
    if (P_SV) then
      ! P_SV-case
      close(111)
      close(113)
    else
      ! SH-case
      close(112)
    endif
  endif

  ! frees memory
  deallocate(adj_src_s)

  end subroutine read_adj_source_SU


program main
    use sim
    implicit none

    type(FEMDomain_),target :: domain
    type(MaterialProp_) :: Permiability
    type(Boundary_) :: Dirichlet,Initial1,Initial2
    type(DiffusionEq_) :: Solver
    integer(int32) :: i

    call domain%create(meshtype="rectangular3D",x_num=20,y_num=20,z_num=10,&
        x_len=50.0d0,y_len=50.0d0,z_len=10.0d0)

    !call domain%create(meshtype="Sphere3D",x_num=10,y_num=10,z_num=10,&
    !    x_len=50.0d0,y_len=20.0d0,z_len=10.0d0)
    !call domain%gmsh(Name="test")

    call Permiability%create(Name="Permiability",ParaValue=0.10d0,Layer=1)
    call Dirichlet%create(Category="Dirichlet",BoundValue=1.0d0,x_max=1.0d0,x_min=-1.0d0,Layer=1)
    call Dirichlet%create(Category="Dirichlet",BoundValue=5.0d0,x_max=51.0d0,x_min=49.0d0,Layer=1)
    call Initial2%create(Category="Time",BoundValue=-10.0d0,x_max=20.0d0,x_min=40.0d0,z_min=7.0d0,Layer=1)

    call domain%import(Materials=.true. , Material=Permiability)
    call domain%import(Boundaries=.true. , Boundary=Dirichlet)
    !call domain%import(Boundaries=.true. , Boundary=Initial1)
    call domain%import(Boundaries=.true. , Boundary=Initial2)

    call domain%bake(template="DiffusionEq_" )

    solver%FEMDomain => domain

    solver%dt=1.0d0

    call solver%setup()
    call solver%solve(solvertype="BiCGSTAB")
    call solver%display(Name="res",optionalstep=0,displaymode="gmsh")
    do i=1,10
        call solver%update()
        call solver%solve(solvertype="BiCGSTAB")
        call solver%display(Name="res",optionalstep=i,displaymode="gmsh")
    enddo

end program main


C
C     file blktri.f
C
C     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
C     *                                                               *
C     *                  copyright (c) 1999 by UCAR                   *
C     *                                                               *
C     *       UNIVERSITY CORPORATION for ATMOSPHERIC RESEARCH         *
C     *                                                               *
C     *                      all rights reserved                      *
C     *                                                               *
C     *                      FISHPACK version 4.1                     *
C     *                                                               *
C     *     A PACKAGE OF FORTRAN SUBPROGRAMS FOR THE SOLUTION OF      *
C     *                                                               *
C     *      SEPARABLE ELLIPTIC PARTIAL DIFFERENTIAL EQUATIONS        *
C     *                                                               *
C     *                             BY                                *
C     *                                                               *
C     *        JOHN ADAMS, PAUL SWARZTRAUBER AND ROLAND SWEET         *
C     *                                                               *
C     *                             OF                                *
C     *                                                               *
C     *         THE NATIONAL CENTER FOR ATMOSPHERIC RESEARCH          *
C     *                                                               *
C     *                BOULDER, COLORADO  (80307)  U.S.A.             *
C     *                                                               *
C     *                   WHICH IS SPONSORED BY                       *
C     *                                                               *
C     *              THE NATIONAL SCIENCE FOUNDATION                  *
C     *                                                               *
C     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
C
C
      SUBROUTINE BLKTRI (IFLG,NP,N,AN,BN,CN,MP,M,AM,BM,CM,IDIMY,Y,
     +                   IERROR,W)
C
C
C DIMENSION OF           AN(N),BN(N),CN(N),AM(M),BM(M),CM(M),Y(IDIMY,N),
C ARGUMENTS              W(SEE ARGUMENT LIST)
C
C LATEST REVISION        NOVEMBER 1988
C
C USAGE                  CALL BLKTRI (IFLG,NP,N,AN,BN,CN,MP,M,AM,BM,
C                                     CM,IDIMY,Y,IERROR,W)
C
C PURPOSE                BLKTRI SOLVES A SYSTEM OF LINEAR EQUATIONS
C                        OF THE FORM
C
C                        AN(J)*X(I,J-1) + AM(I)*X(I-1,J) +
C                        (BN(J)+BM(I))*X(I,J) + CN(J)*X(I,J+1) +
C                        CM(I)*X(I+1,J) = Y(I,J)
C
C                        FOR I = 1,2,...,M  AND  J = 1,2,...,N.
C
C                        I+1 AND I-1 ARE EVALUATED MODULO M AND
C                        J+1 AND J-1 MODULO N, I.E.,
C
C                        X(I,0) = X(I,N),  X(I,N+1) = X(I,1),
C                        X(0,J) = X(M,J),  X(M+1,J) = X(1,J).
C
C                        THESE EQUATIONS USUALLY RESULT FROM THE
C                        DISCRETIZATION OF SEPARABLE ELLIPTIC
C                        EQUATIONS.  BOUNDARY CONDITIONS MAY BE
C                        DIRICHLET, NEUMANN, OR PERIODIC.
C
C ARGUMENTS
C
C ON INPUT               IFLG
C
C                          = 0  INITIALIZATION ONLY.
C                               CERTAIN QUANTITIES THAT DEPEND ON NP,
C                               N, AN, BN, AND CN ARE COMPUTED AND
C                               STORED IN THE WORK ARRAY W.
C
C                          = 1  THE QUANTITIES THAT WERE COMPUTED
C                               IN THE INITIALIZATION ARE USED
C                               TO OBTAIN THE SOLUTION X(I,J).
C
C                               NOTE:
C                               A CALL WITH IFLG=0 TAKES
C                               APPROXIMATELY ONE HALF THE TIME
C                               AS A CALL WITH IFLG = 1.
C                               HOWEVER, THE INITIALIZATION DOES
C                               NOT HAVE TO BE REPEATED UNLESS NP,
C                               N, AN, BN, OR CN CHANGE.
C
C                        NP
C                          = 0  IF AN(1) AND CN(N) ARE NOT ZERO,
C                               WHICH CORRESPONDS TO PERIODIC
C                               BOUNARY CONDITIONS.
C
C                          = 1  IF AN(1) AND CN(N) ARE ZERO.
C
C                        N
C                          THE NUMBER OF UNKNOWNS IN THE J-DIRECTION.
C                          N MUST BE GREATER THAN 4.
C                          THE OPERATION COUNT IS PROPORTIONAL TO
C                          MNLOG2(N), HENCE N SHOULD BE SELECTED
C                          LESS THAN OR EQUAL TO M.
C
C                        AN,BN,CN
C                          ONE-DIMENSIONAL ARRAYS OF LENGTH N
C                          THAT SPECIFY THE COEFFICIENTS IN THE
C                          LINEAR EQUATIONS GIVEN ABOVE.
C
C                        MP
C                          = 0  IF AM(1) AND CM(M) ARE NOT ZERO,
C                               WHICH CORRESPONDS TO PERIODIC
C                               BOUNDARY CONDITIONS.
C
C                          = 1  IF AM(1) = CM(M) = 0  .
C
C                        M
C                          THE NUMBER OF UNKNOWNS IN THE I-DIRECTION.
C                           M MUST BE GREATER THAN 4.
C
C                        AM,BM,CM
C                          ONE-DIMENSIONAL ARRAYS OF LENGTH M THAT
C                          SPECIFY THE COEFFICIENTS IN THE LINEAR
C                          EQUATIONS GIVEN ABOVE.
C
C                        IDIMY
C                          THE ROW (OR FIRST) DIMENSION OF THE
C                          TWO-DIMENSIONAL ARRAY Y AS IT APPEARS
C                          IN THE PROGRAM CALLING BLKTRI.
C                          THIS PARAMETER IS USED TO SPECIFY THE
C                          VARIABLE DIMENSION OF Y.
C                          IDIMY MUST BE AT LEAST M.
C
C                        Y
C                          A TWO-DIMENSIONAL ARRAY THAT SPECIFIES
C                          THE VALUES OF THE RIGHT SIDE OF THE LINEAR
C                          SYSTEM OF EQUATIONS GIVEN ABOVE.
C                          Y MUST BE DIMENSIONED AT LEAST M*N.
C
C                        W
C                          A ONE-DIMENSIONAL ARRAY THAT MUST BE
C                          PROVIDED BY THE USER FOR WORK SPACE.
C                          IF NP=1 DEFINE K=INT(LOG2(N))+1 AND
C                          SET L=2**(K+1) THEN W MUST HAVE DIMENSION
C                          (K-2)*L+K+5+MAX(2N,6M)
C
C                          IF NP=0 DEFINE K=INT(LOG2(N-1))+1 AND
C                          SET L=2**(K+1) THEN W MUST HAVE DIMENSION
C                          (K-2)*L+K+5+2N+MAX(2N,6M)
C
C                          **IMPORTANT**
C                          FOR PURPOSES OF CHECKING, THE REQUIRED
C                          DIMENSION OF W IS COMPUTED BY BLKTRI AND
C                          STORED IN W(1) IN FLOATING POINT FORMAT.
C
C ARGUMENTS
C
C ON OUTPUT              Y
C                          CONTAINS THE SOLUTION X.
C
C                        IERROR
C                          AN ERROR FLAG THAT INDICATES INVALID
C                          INPUT PARAMETERS.  EXCEPT FOR NUMBER ZER0,
C                          A SOLUTION IS NOT ATTEMPTED.
C
C                        = 0  NO ERROR.
C                        = 1  M IS LESS THAN 5
C                        = 2  N IS LESS THAN 5
C                        = 3  IDIMY IS LESS THAN M.
C                        = 4  BLKTRI FAILED WHILE COMPUTING RESULTS
C                             THAT DEPEND ON THE COEFFICIENT ARRAYS
C                             AN, BN, CN.  CHECK THESE ARRAYS.
C                        = 5  AN(J)*CN(J-1) IS LESS THAN 0 FOR SOME J.
C
C                             POSSIBLE REASONS FOR THIS CONDITION ARE
C                             1. THE ARRAYS AN AND CN ARE NOT CORRECT
C                             2. TOO LARGE A GRID SPACING WAS USED
C                                IN THE DISCRETIZATION OF THE ELLIPTIC
C                                EQUATION.
C                             3. THE LINEAR EQUATIONS RESULTED FROM A
C                                PARTIAL DIFFERENTIAL EQUATION WHICH
C                                WAS NOT ELLIPTIC.
C
C                        W
C                           CONTAINS INTERMEDIATE VALUES THAT MUST
C                           NOT BE DESTROYED IF BLKTRI WILL BE CALLED
C                           AGAIN WITH IFLG=1. W(1) CONTAINS THE
C                           NUMBER OF LOCATIONS REQUIRED BY W IN
C                           FLOATING POINT FORMAT.
C
C
C SPECIAL CONDITIONS     THE ALGORITHM MAY FAIL IF ABS(BM(I)+BN(J))
C                        IS LESS THAN ABS(AM(I))+ABS(AN(J))+
C                        ABS(CM(I))+ABS(CN(J))
C                        FOR SOME I AND J. THE ALGORITHM WILL ALSO
C                        FAIL IF AN(J)*CN(J-1) IS LESS THAN ZERO FOR
C                        SOME J.
C                        SEE THE DESCRIPTION OF THE OUTPUT PARAMETER
C                        IERROR.
C
C I/O                    NONE
C
C PRECISION              SINGLE
C
C REQUIRED LIBRARY       COMF FROM FISHPACK
C FILES
C
C LANGUAGE               FORTRAN
C
C HISTORY                WRITTEN BY PAUL SWARZTRAUBER AT NCAR IN THE
C                        EARLY 1970'S.  REWRITTEN AND RELEASED IN
C                        JANUARY, 1980.
C
C ALGORITHM              GENERALIZED CYCLIC REDUCTION
C
C PORTABILITY            FORTRAN 77.  APPROXIMATE MACHINE ACCURACY
C                        IS COMPUTED IN FUNCTION EPMACH.
C
C REFERENCES             SWARZTRAUBER,P. AND R. SWEET, 'EFFICIENT
C                        FORTRAN SUBPROGRAMS FOR THE SOLUTION OF
C                        ELLIPTIC EQUATIONS'
C                        NCAR TN/IA-109, JULY, 1975, 138 PP.
C
C                        SWARZTRAUBER P. N.,A DIRECT METHOD FOR
C                        THE DISCRETE SOLUTION OF SEPARABLE
C                        ELLIPTIC EQUATIONS, S.I.A.M.
C                        J. NUMER. ANAL.,11(1974) PP. 1136-1150.
C***********************************************************************
      DIMENSION       AN(*)      ,BN(*)      ,CN(*)      ,AM(*)      ,
     1                BM(*)      ,CM(*)      ,Y(IDIMY,1) ,W(*)
      EXTERNAL        PROD       ,PRODP      ,CPROD      ,CPRODP
      COMMON /CBLKT/  NPP        ,K          ,EPS        ,CNV        ,
     1                NM         ,NCMPLX     ,IK
C
C TEST M AND N FOR THE PROPER FORM
C
      NM = N
      IERROR = 0
      IF (M-5) 101,102,102
  101 IERROR = 1
      GO TO 119
  102 IF (NM-3) 103,104,104
  103 IERROR = 2
      GO TO 119
  104 IF (IDIMY-M) 105,106,106
  105 IERROR = 3
      GO TO 119
  106 NH = N
      NPP = NP
      IF (NPP) 107,108,107
  107 NH = NH+1
  108 IK = 2
      K = 1
  109 IK = IK+IK
      K = K+1
      IF (NH-IK) 110,110,109
  110 NL = IK
      IK = IK+IK
      NL = NL-1
      IWAH = (K-2)*IK+K+6
      IF (NPP) 111,112,111
C
C     DIVIDE W INTO WORKING SUB ARRAYS
C
  111 IW1 = IWAH
      IWBH = IW1+NM
      W(1) = FLOAT(IW1-1+MAX0(2*NM,6*M))
      GO TO 113
  112 IWBH = IWAH+NM+NM
      IW1 = IWBH
      W(1) = FLOAT(IW1-1+MAX0(2*NM,6*M))
      NM = NM-1
C
C SUBROUTINE COMP B COMPUTES THE ROOTS OF THE B POLYNOMIALS
C
  113 IF (IERROR) 119,114,119
  114 IW2 = IW1+M
      IW3 = IW2+M
      IWD = IW3+M
      IWW = IWD+M
      IWU = IWW+M
      IF (IFLG) 116,115,116
  115 CALL COMPB (NL,IERROR,AN,BN,CN,W(2),W(IWAH),W(IWBH))
      GO TO 119
  116 IF (MP) 117,118,117
C
C SUBROUTINE BLKTR1 SOLVES THE LINEAR SYSTEM
C
  117 CALL BLKTR1 (NL,AN,BN,CN,M,AM,BM,CM,IDIMY,Y,W(2),W(IW1),W(IW2),
     1             W(IW3),W(IWD),W(IWW),W(IWU),PROD,CPROD)
      GO TO 119
  118 CALL BLKTR1 (NL,AN,BN,CN,M,AM,BM,CM,IDIMY,Y,W(2),W(IW1),W(IW2),
     1             W(IW3),W(IWD),W(IWW),W(IWU),PRODP,CPRODP)
  119 CONTINUE
      RETURN
      END
      SUBROUTINE BLKTR1 (N,AN,BN,CN,M,AM,BM,CM,IDIMY,Y,B,W1,W2,W3,WD,
     1                   WW,WU,PRDCT,CPRDCT)
C
C BLKTR1 SOLVES THE LINEAR SYSTEM
C
C B  CONTAINS THE ROOTS OF ALL THE B POLYNOMIALS
C W1,W2,W3,WD,WW,WU  ARE ALL WORKING ARRAYS
C PRDCT  IS EITHER PRODP OR PROD DEPENDING ON WHETHER THE BOUNDARY
C CONDITIONS IN THE M DIRECTION ARE PERIODIC OR NOT
C CPRDCT IS EITHER CPRODP OR CPROD WHICH ARE THE COMPLEX VERSIONS
C OF PRODP AND PROD. THESE ARE CALLED IN THE EVENT THAT SOME
C OF THE ROOTS OF THE B SUB P POLYNOMIAL ARE COMPLEX
C
C
      DIMENSION       AN(*)      ,BN(*)      ,CN(*)      ,AM(*)      ,
     1                BM(*)      ,CM(*)      ,B(*)       ,W1(*)      ,
     2                W2(*)      ,W3(*)      ,WD(*)      ,WW(*)      ,
     3                WU(*)      ,Y(IDIMY,1)
      COMMON /CBLKT/  NPP        ,K          ,EPS        ,CNV        ,
     1                NM         ,NCMPLX     ,IK
C
C BEGIN REDUCTION PHASE
C
      KDO = K-1
      DO 109 L=1,KDO
         IR = L-1
         I2 = 2**IR
         I1 = I2/2
         I3 = I2+I1
         I4 = I2+I2
         IRM1 = IR-1
         CALL INDXB (I2,IR,IM2,NM2)
         CALL INDXB (I1,IRM1,IM3,NM3)
         CALL INDXB (I3,IRM1,IM1,NM1)
         CALL PRDCT (NM2,B(IM2),NM3,B(IM3),NM1,B(IM1),0,DUM,Y(1,I2),W3,
     1               M,AM,BM,CM,WD,WW,WU)
         IF = 2**K
         DO 108 I=I4,IF,I4
            IF (I-NM) 101,101,108
  101       IPI1 = I+I1
            IPI2 = I+I2
            IPI3 = I+I3
            CALL INDXC (I,IR,IDXC,NC)
            IF (I-IF) 102,108,108
  102       CALL INDXA (I,IR,IDXA,NA)
            CALL INDXB (I-I1,IRM1,IM1,NM1)
            CALL INDXB (IPI2,IR,IP2,NP2)
            CALL INDXB (IPI1,IRM1,IP1,NP1)
            CALL INDXB (IPI3,IRM1,IP3,NP3)
            CALL PRDCT (NM1,B(IM1),0,DUM,0,DUM,NA,AN(IDXA),W3,W1,M,AM,
     1                  BM,CM,WD,WW,WU)
            IF (IPI2-NM) 105,105,103
  103       DO 104 J=1,M
               W3(J) = 0.
               W2(J) = 0.
  104       CONTINUE
            GO TO 106
  105       CALL PRDCT (NP2,B(IP2),NP1,B(IP1),NP3,B(IP3),0,DUM,
     1                  Y(1,IPI2),W3,M,AM,BM,CM,WD,WW,WU)
            CALL PRDCT (NP1,B(IP1),0,DUM,0,DUM,NC,CN(IDXC),W3,W2,M,AM,
     1                  BM,CM,WD,WW,WU)
  106       DO 107 J=1,M
               Y(J,I) = W1(J)+W2(J)+Y(J,I)
  107       CONTINUE
  108    CONTINUE
  109 CONTINUE
      IF (NPP) 132,110,132
C
C     THE PERIODIC CASE IS TREATED USING THE CAPACITANCE MATRIX METHOD
C
  110 IF = 2**K
      I = IF/2
      I1 = I/2
      CALL INDXB (I-I1,K-2,IM1,NM1)
      CALL INDXB (I+I1,K-2,IP1,NP1)
      CALL INDXB (I,K-1,IZ,NZ)
      CALL PRDCT (NZ,B(IZ),NM1,B(IM1),NP1,B(IP1),0,DUM,Y(1,I),W1,M,AM,
     1            BM,CM,WD,WW,WU)
      IZR = I
      DO 111 J=1,M
         W2(J) = W1(J)
  111 CONTINUE
      DO 113 LL=2,K
         L = K-LL+1
         IR = L-1
         I2 = 2**IR
         I1 = I2/2
         I = I2
         CALL INDXC (I,IR,IDXC,NC)
         CALL INDXB (I,IR,IZ,NZ)
         CALL INDXB (I-I1,IR-1,IM1,NM1)
         CALL INDXB (I+I1,IR-1,IP1,NP1)
         CALL PRDCT (NP1,B(IP1),0,DUM,0,DUM,NC,CN(IDXC),W1,W1,M,AM,BM,
     1               CM,WD,WW,WU)
         DO 112 J=1,M
            W1(J) = Y(J,I)+W1(J)
  112    CONTINUE
         CALL PRDCT (NZ,B(IZ),NM1,B(IM1),NP1,B(IP1),0,DUM,W1,W1,M,AM,
     1               BM,CM,WD,WW,WU)
  113 CONTINUE
      DO 118 LL=2,K
         L = K-LL+1
         IR = L-1
         I2 = 2**IR
         I1 = I2/2
         I4 = I2+I2
         IFD = IF-I2
         DO 117 I=I2,IFD,I4
            IF (I-I2-IZR) 117,114,117
  114       IF (I-NM) 115,115,118
  115       CALL INDXA (I,IR,IDXA,NA)
            CALL INDXB (I,IR,IZ,NZ)
            CALL INDXB (I-I1,IR-1,IM1,NM1)
            CALL INDXB (I+I1,IR-1,IP1,NP1)
            CALL PRDCT (NM1,B(IM1),0,DUM,0,DUM,NA,AN(IDXA),W2,W2,M,AM,
     1                  BM,CM,WD,WW,WU)
            DO 116 J=1,M
               W2(J) = Y(J,I)+W2(J)
  116       CONTINUE
            CALL PRDCT (NZ,B(IZ),NM1,B(IM1),NP1,B(IP1),0,DUM,W2,W2,M,
     1                  AM,BM,CM,WD,WW,WU)
            IZR = I
            IF (I-NM) 117,119,117
  117    CONTINUE
  118 CONTINUE
  119 DO 120 J=1,M
         Y(J,NM+1) = Y(J,NM+1)-CN(NM+1)*W1(J)-AN(NM+1)*W2(J)
  120 CONTINUE
      CALL INDXB (IF/2,K-1,IM1,NM1)
      CALL INDXB (IF,K-1,IP,NP)
      IF (NCMPLX) 121,122,121
  121 CALL CPRDCT (NM+1,B(IP),NM1,B(IM1),0,DUM,0,DUM,Y(1,NM+1),
     1             Y(1,NM+1),M,AM,BM,CM,W1,W3,WW)
      GO TO 123
  122 CALL PRDCT (NM+1,B(IP),NM1,B(IM1),0,DUM,0,DUM,Y(1,NM+1),
     1            Y(1,NM+1),M,AM,BM,CM,WD,WW,WU)
  123 DO 124 J=1,M
         W1(J) = AN(1)*Y(J,NM+1)
         W2(J) = CN(NM)*Y(J,NM+1)
         Y(J,1) = Y(J,1)-W1(J)
         Y(J,NM) = Y(J,NM)-W2(J)
  124 CONTINUE
      DO 126 L=1,KDO
         IR = L-1
         I2 = 2**IR
         I4 = I2+I2
         I1 = I2/2
         I = I4
         CALL INDXA (I,IR,IDXA,NA)
         CALL INDXB (I-I2,IR,IM2,NM2)
         CALL INDXB (I-I2-I1,IR-1,IM3,NM3)
         CALL INDXB (I-I1,IR-1,IM1,NM1)
         CALL PRDCT (NM2,B(IM2),NM3,B(IM3),NM1,B(IM1),0,DUM,W1,W1,M,AM,
     1               BM,CM,WD,WW,WU)
         CALL PRDCT (NM1,B(IM1),0,DUM,0,DUM,NA,AN(IDXA),W1,W1,M,AM,BM,
     1               CM,WD,WW,WU)
         DO 125 J=1,M
            Y(J,I) = Y(J,I)-W1(J)
  125    CONTINUE
  126 CONTINUE
C
      IZR = NM
      DO 131 L=1,KDO
         IR = L-1
         I2 = 2**IR
         I1 = I2/2
         I3 = I2+I1
         I4 = I2+I2
         IRM1 = IR-1
         DO 130 I=I4,IF,I4
            IPI1 = I+I1
            IPI2 = I+I2
            IPI3 = I+I3
            IF (IPI2-IZR) 127,128,127
  127       IF (I-IZR) 130,131,130
  128       CALL INDXC (I,IR,IDXC,NC)
            CALL INDXB (IPI2,IR,IP2,NP2)
            CALL INDXB (IPI1,IRM1,IP1,NP1)
            CALL INDXB (IPI3,IRM1,IP3,NP3)
            CALL PRDCT (NP2,B(IP2),NP1,B(IP1),NP3,B(IP3),0,DUM,W2,W2,M,
     1                  AM,BM,CM,WD,WW,WU)
            CALL PRDCT (NP1,B(IP1),0,DUM,0,DUM,NC,CN(IDXC),W2,W2,M,AM,
     1                  BM,CM,WD,WW,WU)
            DO 129 J=1,M
               Y(J,I) = Y(J,I)-W2(J)
  129       CONTINUE
            IZR = I
            GO TO 131
  130    CONTINUE
  131 CONTINUE
C
C BEGIN BACK SUBSTITUTION PHASE
C
  132 DO 144 LL=1,K
         L = K-LL+1
         IR = L-1
         IRM1 = IR-1
         I2 = 2**IR
         I1 = I2/2
         I4 = I2+I2
         IFD = IF-I2
         DO 143 I=I2,IFD,I4
            IF (I-NM) 133,133,143
  133       IMI1 = I-I1
            IMI2 = I-I2
            IPI1 = I+I1
            IPI2 = I+I2
            CALL INDXA (I,IR,IDXA,NA)
            CALL INDXC (I,IR,IDXC,NC)
            CALL INDXB (I,IR,IZ,NZ)
            CALL INDXB (IMI1,IRM1,IM1,NM1)
            CALL INDXB (IPI1,IRM1,IP1,NP1)
            IF (I-I2) 134,134,136
  134       DO 135 J=1,M
               W1(J) = 0.
  135       CONTINUE
            GO TO 137
  136       CALL PRDCT (NM1,B(IM1),0,DUM,0,DUM,NA,AN(IDXA),Y(1,IMI2),
     1                  W1,M,AM,BM,CM,WD,WW,WU)
  137       IF (IPI2-NM) 140,140,138
  138       DO 139 J=1,M
               W2(J) = 0.
  139       CONTINUE
            GO TO 141
  140       CALL PRDCT (NP1,B(IP1),0,DUM,0,DUM,NC,CN(IDXC),Y(1,IPI2),
     1                  W2,M,AM,BM,CM,WD,WW,WU)
  141       DO 142 J=1,M
               W1(J) = Y(J,I)+W1(J)+W2(J)
  142       CONTINUE
            CALL PRDCT (NZ,B(IZ),NM1,B(IM1),NP1,B(IP1),0,DUM,W1,Y(1,I),
     1                  M,AM,BM,CM,WD,WW,WU)
  143    CONTINUE
  144 CONTINUE
      RETURN
      END
      FUNCTION BSRH (XLL,XRR,IZ,C,A,BH,F,SGN)
      DIMENSION       A(*)       ,C(*)       ,BH(*)
      COMMON /CBLKT/  NPP        ,K          ,EPS        ,CNV        ,
     1                NM         ,NCMPLX     ,IK
      XL = XLL
      XR = XRR
      DX = .5*ABS(XR-XL)
  101 X = .5*(XL+XR)
      IF (SGN*F(X,IZ,C,A,BH)) 103,105,102
  102 XR = X
      GO TO 104
  103 XL = X
  104 DX = .5*DX
      IF (DX-CNV) 105,105,101
  105 BSRH = .5*(XL+XR)
      RETURN
      END
      SUBROUTINE COMPB (N,IERROR,AN,BN,CN,B,AH,BH)
C
C     COMPB COMPUTES THE ROOTS OF THE B POLYNOMIALS USING SUBROUTINE
C     TEVLS WHICH IS A MODIFICATION THE EISPACK PROGRAM TQLRAT.
C     IERROR IS SET TO 4 IF EITHER TEVLS FAILS OR IF A(J+1)*C(J) IS
C     LESS THAN ZERO FOR SOME J.  AH,BH ARE TEMPORARY WORK ARRAYS.
C
      DIMENSION       AN(*)      ,BN(*)      ,CN(*)      ,B(*)       ,
     1                AH(*)      ,BH(*)
      COMMON /CBLKT/  NPP        ,K          ,EPS        ,CNV        ,
     1                NM         ,NCMPLX     ,IK
      EPS = EPMACH(DUM)
      BNORM = ABS(BN(1))
      DO 102 J=2,NM
         BNORM = AMAX1(BNORM,ABS(BN(J)))
         ARG = AN(J)*CN(J-1)
         IF (ARG) 119,101,101
  101    B(J) = SIGN(SQRT(ARG),AN(J))
  102 CONTINUE
      CNV = EPS*BNORM
      IF = 2**K
      KDO = K-1
      DO 108 L=1,KDO
         IR = L-1
         I2 = 2**IR
         I4 = I2+I2
         IPL = I4-1
         IFD = IF-I4
         DO 107 I=I4,IFD,I4
            CALL INDXB (I,L,IB,NB)
            IF (NB) 108,108,103
  103       JS = I-IPL
            JF = JS+NB-1
            LS = 0
            DO 104 J=JS,JF
               LS = LS+1
               BH(LS) = BN(J)
               AH(LS) = B(J)
  104       CONTINUE
            CALL TEVLS (NB,BH,AH,IERROR)
            IF (IERROR) 118,105,118
  105       LH = IB-1
            DO 106 J=1,NB
               LH = LH+1
               B(LH) = -BH(J)
  106       CONTINUE
  107    CONTINUE
  108 CONTINUE
      DO 109 J=1,NM
         B(J) = -BN(J)
  109 CONTINUE
      IF (NPP) 117,110,117
  110 NMP = NM+1
      NB = NM+NMP
      DO 112 J=1,NB
         L1 = MOD(J-1,NMP)+1
         L2 = MOD(J+NM-1,NMP)+1
         ARG = AN(L1)*CN(L2)
         IF (ARG) 119,111,111
  111    BH(J) = SIGN(SQRT(ARG),-AN(L1))
         AH(J) = -BN(L1)
  112 CONTINUE
      CALL TEVLS (NB,AH,BH,IERROR)
      IF (IERROR) 118,113,118
  113 CALL INDXB (IF,K-1,J2,LH)
      CALL INDXB (IF/2,K-1,J1,LH)
      J2 = J2+1
      LH = J2
      N2M2 = J2+NM+NM-2
  114 D1 = ABS(B(J1)-B(J2-1))
      D2 = ABS(B(J1)-B(J2))
      D3 = ABS(B(J1)-B(J2+1))
      IF ((D2 .LT. D1) .AND. (D2 .LT. D3)) GO TO 115
      B(LH) = B(J2)
      J2 = J2+1
      LH = LH+1
      IF (J2-N2M2) 114,114,116
  115 J2 = J2+1
      J1 = J1+1
      IF (J2-N2M2) 114,114,116
  116 B(LH) = B(N2M2+1)
      CALL INDXB (IF,K-1,J1,J2)
      J2 = J1+NMP+NMP
      CALL PPADD (NM+1,IERROR,AN,CN,B(J1),B(J1),B(J2))
  117 RETURN
  118 IERROR = 4
      RETURN
  119 IERROR = 5
      RETURN
      END
      SUBROUTINE CPROD (ND,BD,NM1,BM1,NM2,BM2,NA,AA,X,YY,M,A,B,C,D,W,Y)
C
C PROD APPLIES A SEQUENCE OF MATRIX OPERATIONS TO THE VECTOR X AND
C STORES THE RESULT IN YY           (COMPLEX CASE)
C AA   ARRAY CONTAINING SCALAR MULTIPLIERS OF THE VECTOR X
C ND,NM1,NM2 ARE THE LENGTHS OF THE ARRAYS BD,BM1,BM2 RESPECTIVELY
C BD,BM1,BM2 ARE ARRAYS CONTAINING ROOTS OF CERTIAN B POLYNOMIALS
C NA IS THE LENGTH OF THE ARRAY AA
C X,YY THE MATRIX OPERATIONS ARE APPLIED TO X AND THE RESULT IS YY
C A,B,C  ARE ARRAYS WHICH CONTAIN THE TRIDIAGONAL MATRIX
C M  IS THE ORDER OF THE MATRIX
C D,W,Y ARE WORKING ARRAYS
C ISGN  DETERMINES WHETHER OR NOT A CHANGE IN SIGN IS MADE
C
      COMPLEX         Y          ,D          ,W          ,BD         ,
     1                CRT        ,DEN        ,Y1         ,Y2
      DIMENSION       A(*)       ,B(*)       ,C(*)       ,X(*)       ,
     1                Y(*)       ,D(*)       ,W(*)       ,BD(*)      ,
     2                BM1(*)     ,BM2(*)     ,AA(*)      ,YY(*)
      DO 101 J=1,M
         Y(J) = CMPLX(X(J),0.)
  101 CONTINUE
      MM = M-1
      ID = ND
      M1 = NM1
      M2 = NM2
      IA = NA
  102 IFLG = 0
      IF (ID) 109,109,103
  103 CRT = BD(ID)
      ID = ID-1
C
C BEGIN SOLUTION TO SYSTEM
C
      D(M) = A(M)/(B(M)-CRT)
      W(M) = Y(M)/(B(M)-CRT)
      DO 104 J=2,MM
         K = M-J
         DEN = B(K+1)-CRT-C(K+1)*D(K+2)
         D(K+1) = A(K+1)/DEN
         W(K+1) = (Y(K+1)-C(K+1)*W(K+2))/DEN
  104 CONTINUE
      DEN = B(1)-CRT-C(1)*D(2)
      IF (CABS(DEN)) 105,106,105
  105 Y(1) = (Y(1)-C(1)*W(2))/DEN
      GO TO 107
  106 Y(1) = (1.,0.)
  107 DO 108 J=2,M
         Y(J) = W(J)-D(J)*Y(J-1)
  108 CONTINUE
  109 IF (M1) 110,110,112
  110 IF (M2) 121,121,111
  111 RT = BM2(M2)
      M2 = M2-1
      GO TO 117
  112 IF (M2) 113,113,114
  113 RT = BM1(M1)
      M1 = M1-1
      GO TO 117
  114 IF (ABS(BM1(M1))-ABS(BM2(M2))) 116,116,115
  115 RT = BM1(M1)
      M1 = M1-1
      GO TO 117
  116 RT = BM2(M2)
      M2 = M2-1
  117 Y1 = (B(1)-RT)*Y(1)+C(1)*Y(2)
      IF (MM-2) 120,118,118
C
C MATRIX MULTIPLICATION
C
  118 DO 119 J=2,MM
         Y2 = A(J)*Y(J-1)+(B(J)-RT)*Y(J)+C(J)*Y(J+1)
         Y(J-1) = Y1
         Y1 = Y2
  119 CONTINUE
  120 Y(M) = A(M)*Y(M-1)+(B(M)-RT)*Y(M)
      Y(M-1) = Y1
      IFLG = 1
      GO TO 102
  121 IF (IA) 124,124,122
  122 RT = AA(IA)
      IA = IA-1
      IFLG = 1
C
C SCALAR MULTIPLICATION
C
      DO 123 J=1,M
         Y(J) = RT*Y(J)
  123 CONTINUE
  124 IF (IFLG) 125,125,102
  125 DO 126 J=1,M
         YY(J) = REAL(Y(J))
  126 CONTINUE
      RETURN
      END
      SUBROUTINE CPRODP (ND,BD,NM1,BM1,NM2,BM2,NA,AA,X,YY,M,A,B,C,D,U,Y)
C
C PRODP APPLIES A SEQUENCE OF MATRIX OPERATIONS TO THE VECTOR X AND
C STORES THE RESULT IN YY       PERIODIC BOUNDARY CONDITIONS
C AND  COMPLEX  CASE
C
C BD,BM1,BM2 ARE ARRAYS CONTAINING ROOTS OF CERTIAN B POLYNOMIALS
C ND,NM1,NM2 ARE THE LENGTHS OF THE ARRAYS BD,BM1,BM2 RESPECTIVELY
C AA   ARRAY CONTAINING SCALAR MULTIPLIERS OF THE VECTOR X
C NA IS THE LENGTH OF THE ARRAY AA
C X,YY THE MATRIX OPERATIONS ARE APPLIED TO X AND THE RESULT IS YY
C A,B,C  ARE ARRAYS WHICH CONTAIN THE TRIDIAGONAL MATRIX
C M  IS THE ORDER OF THE MATRIX
C D,U,Y ARE WORKING ARRAYS
C ISGN  DETERMINES WHETHER OR NOT A CHANGE IN SIGN IS MADE
C
      COMPLEX         Y          ,D          ,U          ,V          ,
     1                DEN        ,BH         ,YM         ,AM         ,
     2                Y1         ,Y2         ,YH         ,BD         ,
     3                CRT
      DIMENSION       A(*)       ,B(*)       ,C(*)       ,X(*)       ,
     1                Y(*)       ,D(*)       ,U(*)       ,BD(*)      ,
     2                BM1(*)     ,BM2(*)     ,AA(*)      ,YY(*)
      DO 101 J=1,M
         Y(J) = CMPLX(X(J),0.)
  101 CONTINUE
      MM = M-1
      MM2 = M-2
      ID = ND
      M1 = NM1
      M2 = NM2
      IA = NA
  102 IFLG = 0
      IF (ID) 111,111,103
  103 CRT = BD(ID)
      ID = ID-1
      IFLG = 1
C
C BEGIN SOLUTION TO SYSTEM
C
      BH = B(M)-CRT
      YM = Y(M)
      DEN = B(1)-CRT
      D(1) = C(1)/DEN
      U(1) = A(1)/DEN
      Y(1) = Y(1)/DEN
      V = CMPLX(C(M),0.)
      IF (MM2-2) 106,104,104
  104 DO 105 J=2,MM2
         DEN = B(J)-CRT-A(J)*D(J-1)
         D(J) = C(J)/DEN
         U(J) = -A(J)*U(J-1)/DEN
         Y(J) = (Y(J)-A(J)*Y(J-1))/DEN
         BH = BH-V*U(J-1)
         YM = YM-V*Y(J-1)
         V = -V*D(J-1)
  105 CONTINUE
  106 DEN = B(M-1)-CRT-A(M-1)*D(M-2)
      D(M-1) = (C(M-1)-A(M-1)*U(M-2))/DEN
      Y(M-1) = (Y(M-1)-A(M-1)*Y(M-2))/DEN
      AM = A(M)-V*D(M-2)
      BH = BH-V*U(M-2)
      YM = YM-V*Y(M-2)
      DEN = BH-AM*D(M-1)
      IF (CABS(DEN)) 107,108,107
  107 Y(M) = (YM-AM*Y(M-1))/DEN
      GO TO 109
  108 Y(M) = (1.,0.)
  109 Y(M-1) = Y(M-1)-D(M-1)*Y(M)
      DO 110 J=2,MM
         K = M-J
         Y(K) = Y(K)-D(K)*Y(K+1)-U(K)*Y(M)
  110 CONTINUE
  111 IF (M1) 112,112,114
  112 IF (M2) 123,123,113
  113 RT = BM2(M2)
      M2 = M2-1
      GO TO 119
  114 IF (M2) 115,115,116
  115 RT = BM1(M1)
      M1 = M1-1
      GO TO 119
  116 IF (ABS(BM1(M1))-ABS(BM2(M2))) 118,118,117
  117 RT = BM1(M1)
      M1 = M1-1
      GO TO 119
  118 RT = BM2(M2)
      M2 = M2-1
C
C MATRIX MULTIPLICATION
C
  119 YH = Y(1)
      Y1 = (B(1)-RT)*Y(1)+C(1)*Y(2)+A(1)*Y(M)
      IF (MM-2) 122,120,120
  120 DO 121 J=2,MM
         Y2 = A(J)*Y(J-1)+(B(J)-RT)*Y(J)+C(J)*Y(J+1)
         Y(J-1) = Y1
         Y1 = Y2
  121 CONTINUE
  122 Y(M) = A(M)*Y(M-1)+(B(M)-RT)*Y(M)+C(M)*YH
      Y(M-1) = Y1
      IFLG = 1
      GO TO 102
  123 IF (IA) 126,126,124
  124 RT = AA(IA)
      IA = IA-1
      IFLG = 1
C
C SCALAR MULTIPLICATION
C
      DO 125 J=1,M
         Y(J) = RT*Y(J)
  125 CONTINUE
  126 IF (IFLG) 127,127,102
  127 DO 128 J=1,M
         YY(J) = REAL(Y(J))
  128 CONTINUE
      RETURN
      END
      SUBROUTINE INDXA (I,IR,IDXA,NA)
      COMMON /CBLKT/  NPP        ,K          ,EPS        ,CNV        ,
     1                NM         ,NCMPLX     ,IK
      NA = 2**IR
      IDXA = I-NA+1
      IF (I-NM) 102,102,101
  101 NA = 0
  102 RETURN
      END
      SUBROUTINE INDXB (I,IR,IDX,IDP)
C
C B(IDX) IS THE LOCATION OF THE FIRST ROOT OF THE B(I,IR) POLYNOMIAL
C
      COMMON /CBLKT/  NPP        ,K          ,EPS        ,CNV        ,
     1                NM         ,NCMPLX     ,IK
      IDP = 0
      IF (IR) 107,101,103
  101 IF (I-NM) 102,102,107
  102 IDX = I
      IDP = 1
      RETURN
  103 IZH = 2**IR
      ID = I-IZH-IZH
      IDX = ID+ID+(IR-1)*IK+IR+(IK-I)/IZH+4
      IPL = IZH-1
      IDP = IZH+IZH-1
      IF (I-IPL-NM) 105,105,104
  104 IDP = 0
      RETURN
  105 IF (I+IPL-NM) 107,107,106
  106 IDP = NM+IPL-I+1
  107 RETURN
      END
      SUBROUTINE INDXC (I,IR,IDXC,NC)
      COMMON /CBLKT/  NPP        ,K          ,EPS        ,CNV        ,
     1                NM         ,NCMPLX     ,IK
      NC = 2**IR
      IDXC = I
      IF (IDXC+NC-1-NM) 102,102,101
  101 NC = 0
  102 RETURN
      END
      SUBROUTINE PPADD (N,IERROR,A,C,CBP,BP,BH)
C
C     PPADD COMPUTES THE EIGENVALUES OF THE PERIODIC TRIDIAGONAL MATRIX
C     WITH COEFFICIENTS AN,BN,CN
C
C N IS THE ORDER OF THE BH AND BP POLYNOMIALS
C     ON OUTPUT BP CONTIANS THE EIGENVALUES
C CBP IS THE SAME AS BP EXCEPT TYPE COMPLEX
C BH IS USED TO TEMPORARILY STORE THE ROOTS OF THE B HAT POLYNOMIAL
C WHICH ENTERS THROUGH BP
C
      COMPLEX         CF         ,CX         ,FSG        ,HSG        ,
     1                DD         ,F          ,FP         ,FPP        ,
     2                CDIS       ,R1         ,R2         ,R3         ,
     3                CBP
      DIMENSION       A(*)       ,C(*)       ,BP(*)      ,BH(*)      ,
     1                CBP(*)
      COMMON /CBLKT/  NPP        ,K          ,EPS        ,CNV        ,
     1                NM         ,NCMPLX     ,IK
      EXTERNAL        PSGF       ,PPSPF      ,PPSGF
      SCNV = SQRT(CNV)
      IZ = N
      IZM = IZ-1
      IZM2 = IZ-2
      IF (BP(N)-BP(1)) 101,142,103
  101 DO 102 J=1,N
         NT = N-J
         BH(J) = BP(NT+1)
  102 CONTINUE
      GO TO 105
  103 DO 104 J=1,N
         BH(J) = BP(J)
  104 CONTINUE
  105 NCMPLX = 0
      MODIZ = MOD(IZ,2)
      IS = 1
      IF (MODIZ) 106,107,106
  106 IF (A(1)) 110,142,107
  107 XL = BH(1)
      DB = BH(3)-BH(1)
  108 XL = XL-DB
      IF (PSGF(XL,IZ,C,A,BH)) 108,108,109
  109 SGN = -1.
      CBP(1) = CMPLX(BSRH(XL,BH(1),IZ,C,A,BH,PSGF,SGN),0.)
      IS = 2
  110 IF = IZ-1
      IF (MODIZ) 111,112,111
  111 IF (A(1)) 112,142,115
  112 XR = BH(IZ)
      DB = BH(IZ)-BH(IZ-2)
  113 XR = XR+DB
      IF (PSGF(XR,IZ,C,A,BH)) 113,114,114
  114 SGN = 1.
      CBP(IZ) = CMPLX(BSRH(BH(IZ),XR,IZ,C,A,BH,PSGF,SGN),0.)
      IF = IZ-2
  115 DO 136 IG=IS,IF,2
         XL = BH(IG)
         XR = BH(IG+1)
         SGN = -1.
         XM = BSRH(XL,XR,IZ,C,A,BH,PPSPF,SGN)
         PSG = PSGF(XM,IZ,C,A,BH)
         IF (ABS(PSG)-EPS) 118,118,116
  116    IF (PSG*PPSGF(XM,IZ,C,A,BH)) 117,118,119
C
C     CASE OF A REAL ZERO
C
  117    SGN = 1.
         CBP(IG) = CMPLX(BSRH(BH(IG),XM,IZ,C,A,BH,PSGF,SGN),0.)
         SGN = -1.
         CBP(IG+1) = CMPLX(BSRH(XM,BH(IG+1),IZ,C,A,BH,PSGF,SGN),0.)
         GO TO 136
C
C     CASE OF A MULTIPLE ZERO
C
  118    CBP(IG) = CMPLX(XM,0.)
         CBP(IG+1) = CMPLX(XM,0.)
         GO TO 136
C
C     CASE OF A COMPLEX ZERO
C
  119    IT = 0
         ICV = 0
         CX = CMPLX(XM,0.)
  120    FSG = (1.,0.)
         HSG = (1.,0.)
         FP = (0.,0.)
         FPP = (0.,0.)
         DO 121 J=1,IZ
            DD = 1./(CX-BH(J))
            FSG = FSG*A(J)*DD
            HSG = HSG*C(J)*DD
            FP = FP+DD
            FPP = FPP-DD*DD
  121    CONTINUE
         IF (MODIZ) 123,122,123
  122    F = (1.,0.)-FSG-HSG
         GO TO 124
  123    F = (1.,0.)+FSG+HSG
  124    I3 = 0
         IF (CABS(FP)) 126,126,125
  125    I3 = 1
         R3 = -F/FP
  126    I2 = 0
         IF (CABS(FPP)) 132,132,127
  127    I2 = 1
         CDIS = CSQRT(FP**2-2.*F*FPP)
         R1 = CDIS-FP
         R2 = -FP-CDIS
         IF (CABS(R1)-CABS(R2)) 129,129,128
  128    R1 = R1/FPP
         GO TO 130
  129    R1 = R2/FPP
  130    R2 = 2.*F/FPP/R1
         IF (CABS(R2) .LT. CABS(R1)) R1 = R2
         IF (I3) 133,133,131
  131    IF (CABS(R3) .LT. CABS(R1)) R1 = R3
         GO TO 133
  132    R1 = R3
  133    CX = CX+R1
         IT = IT+1
         IF (IT .GT. 50) GO TO 142
         IF (CABS(R1) .GT. SCNV) GO TO 120
         IF (ICV) 134,134,135
  134    ICV = 1
         GO TO 120
  135    CBP(IG) = CX
         CBP(IG+1) = CONJG(CX)
  136 CONTINUE
      IF (CABS(CBP(N))-CABS(CBP(1))) 137,142,139
  137 NHALF = N/2
      DO 138 J=1,NHALF
         NT = N-J
         CX = CBP(J)
         CBP(J) = CBP(NT+1)
         CBP(NT+1) = CX
  138 CONTINUE
  139 NCMPLX = 1
      DO 140 J=2,IZ
         IF (AIMAG(CBP(J))) 143,140,143
  140 CONTINUE
      NCMPLX = 0
      DO 141 J=2,IZ
         BP(J) = REAL(CBP(J))
  141 CONTINUE
      GO TO 143
  142 IERROR = 4
  143 CONTINUE
      RETURN
      END
      SUBROUTINE PROD (ND,BD,NM1,BM1,NM2,BM2,NA,AA,X,Y,M,A,B,C,D,W,U)
C
C PROD APPLIES A SEQUENCE OF MATRIX OPERATIONS TO THE VECTOR X AND
C STORES THE RESULT IN Y
C BD,BM1,BM2 ARE ARRAYS CONTAINING ROOTS OF CERTIAN B POLYNOMIALS
C ND,NM1,NM2 ARE THE LENGTHS OF THE ARRAYS BD,BM1,BM2 RESPECTIVELY
C AA   ARRAY CONTAINING SCALAR MULTIPLIERS OF THE VECTOR X
C NA IS THE LENGTH OF THE ARRAY AA
C X,Y  THE MATRIX OPERATIONS ARE APPLIED TO X AND THE RESULT IS Y
C A,B,C  ARE ARRAYS WHICH CONTAIN THE TRIDIAGONAL MATRIX
C M  IS THE ORDER OF THE MATRIX
C D,W,U ARE WORKING ARRAYS
C IS  DETERMINES WHETHER OR NOT A CHANGE IN SIGN IS MADE
C
      DIMENSION       A(*)       ,B(*)       ,C(*)       ,X(*)       ,
     1                Y(*)       ,D(*)       ,W(*)       ,BD(*)      ,
     2                BM1(*)     ,BM2(*)     ,AA(*)      ,U(*)
      DO 101 J=1,M
         W(J) = X(J)
         Y(J) = W(J)
  101 CONTINUE
      MM = M-1
      ID = ND
      IBR = 0
      M1 = NM1
      M2 = NM2
      IA = NA
  102 IF (IA) 105,105,103
  103 RT = AA(IA)
      IF (ND .EQ. 0) RT = -RT
      IA = IA-1
C
C SCALAR MULTIPLICATION
C
      DO 104 J=1,M
         Y(J) = RT*W(J)
  104 CONTINUE
  105 IF (ID) 125,125,106
  106 RT = BD(ID)
      ID = ID-1
      IF (ID .EQ. 0) IBR = 1
C
C BEGIN SOLUTION TO SYSTEM
C
      D(M) = A(M)/(B(M)-RT)
      W(M) = Y(M)/(B(M)-RT)
      DO 107 J=2,MM
         K = M-J
         DEN = B(K+1)-RT-C(K+1)*D(K+2)
         D(K+1) = A(K+1)/DEN
         W(K+1) = (Y(K+1)-C(K+1)*W(K+2))/DEN
  107 CONTINUE
      DEN = B(1)-RT-C(1)*D(2)
      W(1) = 1.
      IF (DEN) 108,109,108
  108 W(1) = (Y(1)-C(1)*W(2))/DEN
  109 DO 110 J=2,M
         W(J) = W(J)-D(J)*W(J-1)
  110 CONTINUE
      IF (NA) 113,113,102
  111 DO 112 J=1,M
         Y(J) = W(J)
  112 CONTINUE
      IBR = 1
      GO TO 102
  113 IF (M1) 114,114,115
  114 IF (M2) 111,111,120
  115 IF (M2) 117,117,116
  116 IF (ABS(BM1(M1))-ABS(BM2(M2))) 120,120,117
  117 IF (IBR) 118,118,119
  118 IF (ABS(BM1(M1)-BD(ID))-ABS(BM1(M1)-RT)) 111,119,119
  119 RT = RT-BM1(M1)
      M1 = M1-1
      GO TO 123
  120 IF (IBR) 121,121,122
  121 IF (ABS(BM2(M2)-BD(ID))-ABS(BM2(M2)-RT)) 111,122,122
  122 RT = RT-BM2(M2)
      M2 = M2-1
  123 DO 124 J=1,M
         Y(J) = Y(J)+RT*W(J)
  124 CONTINUE
      GO TO 102
  125 RETURN
      END
      SUBROUTINE PRODP (ND,BD,NM1,BM1,NM2,BM2,NA,AA,X,Y,M,A,B,C,D,U,W)
C
C PRODP APPLIES A SEQUENCE OF MATRIX OPERATIONS TO THE VECTOR X AND
C STORES THE RESULT IN Y        PERIODIC BOUNDARY CONDITIONS
C
C BD,BM1,BM2 ARE ARRAYS CONTAINING ROOTS OF CERTIAN B POLYNOMIALS
C ND,NM1,NM2 ARE THE LENGTHS OF THE ARRAYS BD,BM1,BM2 RESPECTIVELY
C AA   ARRAY CONTAINING SCALAR MULTIPLIERS OF THE VECTOR X
C NA IS THE LENGTH OF THE ARRAY AA
C X,Y  THE MATRIX OPERATIONS ARE APPLIED TO X AND THE RESULT IS Y
C A,B,C  ARE ARRAYS WHICH CONTAIN THE TRIDIAGONAL MATRIX
C M  IS THE ORDER OF THE MATRIX
C D,U,W ARE WORKING ARRAYS
C IS  DETERMINES WHETHER OR NOT A CHANGE IN SIGN IS MADE
C
      DIMENSION       A(*)       ,B(*)       ,C(*)       ,X(*)       ,
     1                Y(*)       ,D(*)       ,U(*)       ,BD(*)      ,
     2                BM1(*)     ,BM2(*)     ,AA(*)      ,W(*)
      DO 101 J=1,M
         Y(J) = X(J)
         W(J) = Y(J)
  101 CONTINUE
      MM = M-1
      MM2 = M-2
      ID = ND
      IBR = 0
      M1 = NM1
      M2 = NM2
      IA = NA
  102 IF (IA) 105,105,103
  103 RT = AA(IA)
      IF (ND .EQ. 0) RT = -RT
      IA = IA-1
      DO 104 J=1,M
         Y(J) = RT*W(J)
  104 CONTINUE
  105 IF (ID) 128,128,106
  106 RT = BD(ID)
      ID = ID-1
      IF (ID .EQ. 0) IBR = 1
C
C BEGIN SOLUTION TO SYSTEM
C
      BH = B(M)-RT
      YM = Y(M)
      DEN = B(1)-RT
      D(1) = C(1)/DEN
      U(1) = A(1)/DEN
      W(1) = Y(1)/DEN
      V = C(M)
      IF (MM2-2) 109,107,107
  107 DO 108 J=2,MM2
         DEN = B(J)-RT-A(J)*D(J-1)
         D(J) = C(J)/DEN
         U(J) = -A(J)*U(J-1)/DEN
         W(J) = (Y(J)-A(J)*W(J-1))/DEN
         BH = BH-V*U(J-1)
         YM = YM-V*W(J-1)
         V = -V*D(J-1)
  108 CONTINUE
  109 DEN = B(M-1)-RT-A(M-1)*D(M-2)
      D(M-1) = (C(M-1)-A(M-1)*U(M-2))/DEN
      W(M-1) = (Y(M-1)-A(M-1)*W(M-2))/DEN
      AM = A(M)-V*D(M-2)
      BH = BH-V*U(M-2)
      YM = YM-V*W(M-2)
      DEN = BH-AM*D(M-1)
      IF (DEN) 110,111,110
  110 W(M) = (YM-AM*W(M-1))/DEN
      GO TO 112
  111 W(M) = 1.
  112 W(M-1) = W(M-1)-D(M-1)*W(M)
      DO 113 J=2,MM
         K = M-J
         W(K) = W(K)-D(K)*W(K+1)-U(K)*W(M)
  113 CONTINUE
      IF (NA) 116,116,102
  114 DO 115 J=1,M
         Y(J) = W(J)
  115 CONTINUE
      IBR = 1
      GO TO 102
  116 IF (M1) 117,117,118
  117 IF (M2) 114,114,123
  118 IF (M2) 120,120,119
  119 IF (ABS(BM1(M1))-ABS(BM2(M2))) 123,123,120
  120 IF (IBR) 121,121,122
  121 IF (ABS(BM1(M1)-BD(ID))-ABS(BM1(M1)-RT)) 114,122,122
  122 RT = RT-BM1(M1)
      M1 = M1-1
      GO TO 126
  123 IF (IBR) 124,124,125
  124 IF (ABS(BM2(M2)-BD(ID))-ABS(BM2(M2)-RT)) 114,125,125
  125 RT = RT-BM2(M2)
      M2 = M2-1
  126 DO 127 J=1,M
         Y(J) = Y(J)+RT*W(J)
  127 CONTINUE
      GO TO 102
  128 RETURN
      END
      SUBROUTINE TEVLS (N,D,E2,IERR)
C
      INTEGER         I          ,J          ,L          ,M          ,
     1                N          ,II         ,L1         ,MML        ,
     2                IERR
      REAL            D(N)       ,E2(N)
      REAL            B          ,C          ,F          ,G          ,
     1                H          ,P          ,R          ,S          ,
     2                MACHEP
C
C     REAL SQRT,ABS,SIGN
C
      COMMON /CBLKT/  NPP        ,K          ,MACHEP     ,CNV        ,
     1                NM         ,NCMPLX     ,IK
C
C     THIS SUBROUTINE IS A MODIFICATION OF THE EISPACK SUBROUTINE TQLRAT
C     ALGORITHM 464, COMM. ACM 16, 689(1973) BY REINSCH.
C
C     THIS SUBROUTINE FINDS THE EIGENVALUES OF A SYMMETRIC
C     TRIDIAGONAL MATRIX BY THE RATIONAL QL METHOD.
C
C     ON INPUT-
C
C        N IS THE ORDER OF THE MATRIX,
C
C        D CONTAINS THE DIAGONAL ELEMENTS OF THE INPUT MATRIX,
C
C        E2 CONTAINS THE                SUBDIAGONAL ELEMENTS OF THE
C          INPUT MATRIX IN ITS LAST N-1 POSITIONS.  E2(1) IS ARBITRARY.
C
C      ON OUTPUT-
C
C        D CONTAINS THE EIGENVALUES IN ASCENDING ORDER.  IF AN
C          ERROR EXIT IS MADE, THE EIGENVALUES ARE CORRECT AND
C          ORDERED FOR INDICES 1,2,...IERR-1, BUT MAY NOT BE
C          THE SMALLEST EIGENVALUES,
C
C        E2 HAS BEEN DESTROYED,
C
C        IERR IS SET TO
C          ZERO       FOR NORMAL RETURN,
C          J          IF THE J-TH EIGENVALUE HAS NOT BEEN
C                     DETERMINED AFTER 30 ITERATIONS.
C
C     QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO B. S. GARBOW,
C     APPLIED MATHEMATICS DIVISION, ARGONNE NATIONAL LABORATORY
C
C
C     ********** MACHEP IS A MACHINE DEPENDENT PARAMETER SPECIFYING
C                THE RELATIVE PRECISION OF FLOATING POINT ARITHMETIC.
C
C                **********
C
      IERR = 0
      IF (N .EQ. 1) GO TO 115
C
      DO 101 I=2,N
         E2(I-1) = E2(I)*E2(I)
  101 CONTINUE
C
      F = 0.0
      B = 0.0
      E2(N) = 0.0
C
      DO 112 L=1,N
         J = 0
         H = MACHEP*(ABS(D(L))+SQRT(E2(L)))
         IF (B .GT. H) GO TO 102
         B = H
         C = B*B
C
C     ********** LOOK FOR SMALL SQUARED SUB-DIAGONAL ELEMENT **********
C
  102    DO 103 M=L,N
            IF (E2(M) .LE. C) GO TO 104
C
C     ********** E2(N) IS ALWAYS ZERO, SO THERE IS NO EXIT
C                THROUGH THE BOTTOM OF THE LOOP **********
C
  103    CONTINUE
C
  104    IF (M .EQ. L) GO TO 108
  105    IF (J .EQ. 30) GO TO 114
         J = J+1
C
C     ********** FORM SHIFT **********
C
         L1 = L+1
         S = SQRT(E2(L))
         G = D(L)
         P = (D(L1)-G)/(2.0*S)
         R = SQRT(P*P+1.0)
         D(L) = S/(P+SIGN(R,P))
         H = G-D(L)
C
         DO 106 I=L1,N
            D(I) = D(I)-H
  106    CONTINUE
C
         F = F+H
C
C     ********** RATIONAL QL TRANSFORMATION **********
C
         G = D(M)
         IF (G .EQ. 0.0) G = B
         H = G
         S = 0.0
         MML = M-L
C
C     ********** FOR I=M-1 STEP -1 UNTIL L DO -- **********
C
         DO 107 II=1,MML
            I = M-II
            P = G*H
            R = P+E2(I)
            E2(I+1) = S*R
            S = E2(I)/R
            D(I+1) = H+S*(H+D(I))
            G = D(I)-E2(I)/G
            IF (G .EQ. 0.0) G = B
            H = G*P/R
  107    CONTINUE
C
         E2(L) = S*G
         D(L) = H
C
C     ********** GUARD AGAINST UNDERFLOWED H **********
C
         IF (H .EQ. 0.0) GO TO 108
         IF (ABS(E2(L)) .LE. ABS(C/H)) GO TO 108
         E2(L) = H*E2(L)
         IF (E2(L) .NE. 0.0) GO TO 105
  108    P = D(L)+F
C
C     ********** ORDER EIGENVALUES **********
C
         IF (L .EQ. 1) GO TO 110
C
C     ********** FOR I=L STEP -1 UNTIL 2 DO -- **********
C
         DO 109 II=2,L
            I = L+2-II
            IF (P .GE. D(I-1)) GO TO 111
            D(I) = D(I-1)
  109    CONTINUE
C
  110    I = 1
  111    D(I) = P
  112 CONTINUE
C
      IF (ABS(D(N)) .GE. ABS(D(1))) GO TO 115
      NHALF = N/2
      DO 113 I=1,NHALF
         NTOP = N-I
         DHOLD = D(I)
         D(I) = D(NTOP+1)
         D(NTOP+1) = DHOLD
  113 CONTINUE
      GO TO 115
C
C     ********** SET ERROR -- NO CONVERGENCE TO AN
C                EIGENVALUE AFTER 30 ITERATIONS **********
C
  114 IERR = L
  115 RETURN
C
C     ********** LAST CARD OF TQLRAT **********
C
C
C REVISION HISTORY---
C
C SEPTEMBER 1973    VERSION 1
C APRIL     1976    VERSION 2
C JANUARY   1978    VERSION 3
C DECEMBER  1979    VERSION 3.1
C FEBRUARY  1985    DOCUMENTATION UPGRADE
C NOVEMBER  1988    VERSION 3.2, FORTRAN 77 CHANGES
C-----------------------------------------------------------------------
      END


!    Copyright (C) 2012 The SPEED FOUNDATION
!    Author: Ilario Mazzieri
!
!    This file is part of SPEED.
!
!    SPEED is free software; you can redistribute it and/or modify it
!    under the terms of the GNU Affero General Public License as
!    published by the Free Software Foundation, either version 3 of the
!    License, or (at your option) any later version.
!
!    SPEED is distributed in the hope that it will be useful, but
!    WITHOUT ANY WARRANTY; without even the implied warranty of
!    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
!    Affero General Public License for more details.
!
!    You should have received a copy of the GNU Affero General Public License
!    along with SPEED.  If not, see <http://www.gnu.org/licenses/>.

!> @brief Computes spatial derivatives of displacement.
!! @author Ilario Mazzieri
!> @date September, 2013
!> @version 1.0
!> @param[in] nn number of 1-D Legendre nodes
!> @param[in] ct GLL nodes
!> @param[in] ww GLL weights
!> @param[in] dd matrix of spectral derivatives
!> @param[in] ux x-displacement
!> @param[in] uy y-displacement
!> @param[in] uy z-displacement
!> @param[in] alfa11 costant for the bilinear map
!> @param[in] alfa12 costant for the bilinear map
!> @param[in] alfa13 costant for the bilinear map
!> @param[in] alfa21 costant for the bilinear map
!> @param[in] alfa22 costant for the bilinear map
!> @param[in] alfa23 costant for the bilinear map
!> @param[in] alfa31 costant for the bilinear map
!> @param[in] alfa32 costant for the bilinear map
!> @param[in] alfa33 costant for the bilinear map
!> @param[in] beta11 costant for the bilinear map
!> @param[in] beta12 costant for the bilinear map
!> @param[in] beta13 costant for the bilinear map
!> @param[in] beta21 costant for the bilinear map
!> @param[in] beta22 costant for the bilinear map
!> @param[in] beta23 costant for the bilinear map
!> @param[in] beta31 costant for the bilinear map
!> @param[in] beta32 costant for the bilinear map
!> @param[in] beta33 costant for the bilinear map
!> @param[in] gamma1  costant for the bilinear map
!> @param[in] gamma2  costant for the bilinear map
!> @param[in] gamma3  costant for the bilinear map
!> @param[in] delta1  costant for the bilinear map
!> @param[in] delta2  costant for the bilinear map
!> @param[in] delta3  costant for the bilinear map
!> @param[out] duxdx nodal values for spatial derivatives of the displacement
!> @param[out] duydx nodal values for spatial derivatives of the displacement
!> @param[out] duzdx nodal values for spatial derivatives of the displacement
!> @param[out] duxdy nodal values for spatial derivatives of the displacement
!> @param[out] duydy nodal values for spatial derivatives of the displacement
!> @param[out] duzdy nodal values for spatial derivatives of the displacement
!> @param[out] duxdz nodal values for spatial derivatives of the displacement
!> @param[out] duydz nodal values for spatial derivatives of the displacement
!> @param[out] duzdz nodal values for spatial derivatives of the displacement

      subroutine MAKE_STRAIN_TENSOR(nn,ct,ww,dd,&
                               alfa11,alfa12,alfa13,alfa21,alfa22,alfa23,&
                               alfa31,alfa32,alfa33,beta11,beta12,beta13,&
                               beta21,beta22,beta23,beta31,beta32,beta33,&
                               gamma1,gamma2,gamma3,delta1,delta2,delta3,&
                               ux,uy,uz,&
                               duxdx,duydx,duzdx,&
                               duxdy,duydy,duzdy,&
                               duxdz,duydz,duzdz)

      implicit none

      integer*4 :: nn
      integer*4 :: i,j,k,p,q,r

      real*8 :: alfa11,alfa12,alfa13,alfa21,alfa22,alfa23,alfa31,alfa32,alfa33
      real*8 :: beta11,beta12,beta13,beta21,beta22,beta23,beta31,beta32,beta33
      real*8 :: gamma1,gamma2,gamma3,delta1,delta2,delta3
      real*8 :: dxdx,dxdy,dxdz,dydx,dydy,dydz,dzdx,dzdy,dzdz,det_j
      real*8 :: t1ux,t2ux,t3ux,t1uy,t2uy,t3uy,t1uz,t2uz,t3uz

      real*8, dimension(nn) :: ct,ww
      real*8, dimension(nn,nn) :: dd

      real*8, dimension(nn,nn,nn) :: ux,uy,uz
      real*8, dimension(nn,nn,nn) :: duxdx,duxdy,duxdz,duydx,duydy,duydz,duzdx,duzdy,duzdz

!     STRAIN CALCULATION

      do r = 1,nn
         do q = 1,nn
            do p = 1,nn
               t1ux = 0.d0
               t1uy = 0.d0
               t1uz = 0.d0
               t2ux = 0.d0
               t2uy = 0.d0
               t2uz = 0.d0
               t3ux = 0.d0
               t3uy = 0.d0
               t3uz = 0.d0

               dxdx = alfa11 + beta12*ct(r) + beta13*ct(q) &
                    + gamma1*ct(q)*ct(r)
               dydx = alfa21 + beta22*ct(r) + beta23*ct(q) &
                    + gamma2*ct(q)*ct(r)
               dzdx = alfa31 + beta32*ct(r) + beta33*ct(q) &
                    + gamma3*ct(q)*ct(r)

               dxdy = alfa12 + beta11*ct(r) + beta13*ct(p) &
                    + gamma1*ct(r)*ct(p)
               dydy = alfa22 + beta21*ct(r) + beta23*ct(p) &
                    + gamma2*ct(r)*ct(p)
               dzdy = alfa32 + beta31*ct(r) + beta33*ct(p) &
                    + gamma3*ct(r)*ct(p)

               dxdz = alfa13 + beta11*ct(q) + beta12*ct(p) &
                    + gamma1*ct(p)*ct(q)
               dydz = alfa23 + beta21*ct(q) + beta22*ct(p) &
                    + gamma2*ct(p)*ct(q)
               dzdz = alfa33 + beta31*ct(q) + beta32*ct(p) &
                    + gamma3*ct(p)*ct(q)

               det_j = dxdz * (dydx*dzdy - dzdx*dydy) &
                     - dydz * (dxdx*dzdy - dzdx*dxdy) &
                     + dzdz * (dxdx*dydy - dydx*dxdy)

               do i = 1,nn
                  t1ux = t1ux + ux(i,q,r) * dd(p,i)
                  t1uy = t1uy + uy(i,q,r) * dd(p,i)
                  t1uz = t1uz + uz(i,q,r) * dd(p,i)
               enddo

               do j = 1,nn
                  t2ux = t2ux + ux(p,j,r) * dd(q,j)
                  t2uy = t2uy + uy(p,j,r) * dd(q,j)
                  t2uz = t2uz + uz(p,j,r) * dd(q,j)
               enddo

               do k = 1,nn
                  t3ux = t3ux + ux(p,q,k) * dd(r,k)
                  t3uy = t3uy + uy(p,q,k) * dd(r,k)
                  t3uz = t3uz + uz(p,q,k) * dd(r,k)
               enddo

               duxdx(p,q,r) = 1.0d0 / det_j *(&
                    ((dydy*dzdz - dydz*dzdy) * t1ux) + &
                    ((dydz*dzdx - dydx*dzdz) * t2ux) + &
                    ((dydx*dzdy - dydy*dzdx) * t3ux))

               duydx(p,q,r) = 1.0d0 / det_j *(&
                    ((dydy*dzdz - dydz*dzdy) * t1uy) + &
                    ((dydz*dzdx - dydx*dzdz) * t2uy) + &
                    ((dydx*dzdy - dydy*dzdx) * t3uy))

               duzdx(p,q,r) = 1.0d0 / det_j *(&
                    ((dydy*dzdz - dydz*dzdy) * t1uz) + &
                    ((dydz*dzdx - dydx*dzdz) * t2uz) + &
                    ((dydx*dzdy - dydy*dzdx) * t3uz))

               duxdy(p,q,r) = 1.0d0 / det_j *(&
                    ((dzdy*dxdz - dzdz*dxdy) * t1ux) + &
                    ((dzdz*dxdx - dzdx*dxdz) * t2ux) + &
                    ((dzdx*dxdy - dzdy*dxdx) * t3ux))

               duydy(p,q,r) = 1.0d0 / det_j *(&
                    ((dzdy*dxdz - dzdz*dxdy) * t1uy) + &
                    ((dzdz*dxdx - dzdx*dxdz) * t2uy) + &
                    ((dzdx*dxdy - dzdy*dxdx) * t3uy))

               duzdy(p,q,r) = 1.0d0 / det_j *(&
                    ((dzdy*dxdz - dzdz*dxdy) * t1uz) + &
                    ((dzdz*dxdx - dzdx*dxdz) * t2uz) + &
                    ((dzdx*dxdy - dzdy*dxdx) * t3uz))

               duxdz(p,q,r) = 1.0d0 / det_j *(&
                    ((dxdy*dydz - dxdz*dydy) * t1ux) + &
                    ((dxdz*dydx - dxdx*dydz) * t2ux) + &
                    ((dxdx*dydy - dxdy*dydx) * t3ux))

               duydz(p,q,r) = 1.0d0 / det_j *(&
                    ((dxdy*dydz - dxdz*dydy) * t1uy) + &
                    ((dxdz*dydx - dxdx*dydz) * t2uy) + &
                    ((dxdx*dydy - dxdy*dydx) * t3uy))

               duzdz(p,q,r) = 1.0d0 / det_j *(&
                    ((dxdy*dydz - dxdz*dydy) * t1uz) + &
                    ((dxdz*dydx - dxdx*dydz) * t2uz) + &
                    ((dxdx*dydy - dxdy*dydx) * t3uz))

            enddo
         enddo
      enddo

      return

      end subroutine MAKE_STRAIN_TENSOR


cdis    Forecast Systems Laboratory
cdis    NOAA/OAR/ERL/FSL
cdis    325 Broadway
cdis    Boulder, CO     80303
cdis
cdis    Forecast Research Division
cdis    Local Analysis and Prediction Branch
cdis    LAPS
cdis
cdis    This software and its documentation are in the public domain and
cdis    are furnished "as is."  The United States government, its
cdis    instrumentalities, officers, employees, and agents make no
cdis    warranty, express or implied, as to the usefulness of the software
cdis    and documentation for any purpose.  They assume no responsibility
cdis    (1) for the use of the software and documentation; or (2) to provide
cdis     technical support to users.
cdis
cdis    Permission to use, copy, modify, and distribute this software is
cdis    hereby granted, provided that the entire disclaimer notice appears
cdis    in all copies.  All modifications to this software must be clearly
cdis    documented, and are solely the responsibility of the agent making
cdis    the modifications.  If significant modifications or enhancements
cdis    are made to this software, the FSL Software Policy Manager
cdis    (softwaremgr@fsl.noaa.gov) should be notified.
cdis
cdis
cdis
cdis
cdis
cdis
cdis

        subroutine radar_to_latlon_old(lat_grid,lon_grid,height_grid
     1                  ,azimuth,slant_range,elev
     1                  ,rlat_radar,rlon_radar,rheight_radar)

        include 'trigd.inc'
        implicit real (a-z)

        if(rlat_radar .eq. 0.0)then
            write(6,*)' Warning, Radar Coords NOT Initialized'
        endif

        rpd = 3.141592653589/180.
        mpd = 111194.
        radius_earth = 6371.e3
        radius_earth_8_thirds = 6371.e3 * 2.6666666

        hor_dist = slant_range * cosd(elev)

        curvature = hor_dist **2 / radius_earth_8_thirds
        height_grid =
     1  slant_range * sind(elev) + curvature + rheight_radar

        height_factor =
     1   (radius_earth + 0.5 * (rheight_radar + height_grid))
     1  /radius_earth

        delta_x = sind(azimuth) * hor_dist / height_factor
        delta_y = cosd(azimuth) * hor_dist / height_factor

        delta_lat = delta_y / mpd

        lat_grid = rlat_radar + delta_lat

        cos_factor =  cosd( 0.5 * (rlat_radar + lat_grid ) )

        delta_lon = delta_x / mpd / cos_factor

        lon_grid = rlon_radar + delta_lon

        return

        end

        subroutine radar_to_latlon(lat_grid,lon_grid,height_grid
     1                  ,azimuth,slant_range,elev
     1                  ,rlat_radar,rlon_radar,rheight_radar)

cdoc    Calculate radar echo location given radar location and az/ran/elev
cdoc    of radar echo

        include 'trigd.inc'
        implicit real (a-z)

        real rlat_radar             ! I    (Degrees)
        real rlon_radar             ! I    (Degrees)
        real rheight_radar          ! I    (Meters)
        real azimuth                ! I    (Degrees)
        real slant_range            ! I    (Meters)
        real elev                   ! I    (Degrees)
        real lat_grid               ! O    (Degrees)
        real lon_grid               ! O    (Degrees)
        real height_grid            ! O    (Meters)

        integer i_status

        if(rlat_radar .eq. 0.0)then
            write(6,*)' Warning, Radar Coords NOT Initialized'
        endif

        rpd = 3.141592653589/180.
        mpd = 111194.
        radius_earth = 6371.e3
        radius_earth_8_thirds = 6371.e3 * 2.6666666

        hor_dist = slant_range * cosd(elev)

        curvature = hor_dist **2 / radius_earth_8_thirds
        height_grid =
     1  slant_range * sind(elev) + curvature + rheight_radar

        height_factor =
     1   (radius_earth + 0.5 * (rheight_radar + height_grid))
     1  /radius_earth

        r_range = hor_dist / height_factor * .001

!       write(12,*)r_range,azimuth

        call razm_lat_lon_gm(
     1          rlat_radar,                                           ! I
     1          rlon_radar,                                           ! I
     1          r_range,                                              ! I
     1          azimuth,                                              ! I
     1          lat_grid,                                             ! O
     1          lon_grid,                                             ! O
     1          i_status )                                            ! O

        if(i_status .ne. 1)then
            write(6,*)
     1         ' ERROR: Status check failed after razm_lat_lon_gm call'

            difflat = lat_grid - rlat_radar
            difflon = lon_grid - rlon_radar
            if(r_range .gt. 10000. .and. abs(difflat) .lt. .01
     1                             .and. abs(difflon) .lt. .01)then
                write(6,*)
     1           ' ERROR: QC check failed after razm_lat_lon_gm call'
                write(6,*)'difflat,difflon,r_range'
     1                    ,difflat,difflon,r_range
                write(6,*)'azimuth,rlat_radar,rlon_radar'
     1                    ,azimuth,rlat_radar,rlon_radar
            endif

            stop
        endif

        return

        end


      subroutine lcm(i, j, k)
        integer*8 i, j, k, a
        call gcd(i, j, a)
        if (a.ne.0) then
           k = i*j / a
        else
           k = a
        end if
        return
      end


c========================================================================
c
c     subroutine OPVAR
c
c     Computing optimization for ALLOCVAR - Value-at-Risk constraint
c
c-----------------------------------------------------------------------
      SUBROUTINE opvar ( n, cov, rho, neq, nin, ccst, bcst,
     &                   cinf, csup, vrimax, conflp, maxdic, epsdic,
     &                   iwork, dwork, wopt, vriopt, info )
c-----------------------------------------------------------------------
c
c     INPUT
c            n      : number of assets                           integer
c            cov    : covariance matrix (n*n)                     double
c            rho    : mean returns vector (n)                     double
c            neq    : number of initial equality constraints     integer
c            nin    : number of initial inequality constraints   integer
c            ccst   : matrix of constraints (n*(neq+nin))         double
c            bcst   : vector of constraints  vector(neq+nin)      double
c            cinf   : lower bounds (n)                            double
c            csup   : upper bounds (n)                            double
c            vrimax : Value-at-Risk constraint                    double
c            conflp : confidence level parameter ( 0<conflp<1 )   double
c            maxdic : maximum of dichotomy iterations            integer
c            epsdic : precision of dichotomy                      double
c
c     WORKSPACE
c            iwork  : 3*n + neq + 2*nin + 3                      integer
c            dwork  : n*(n + neq + nin + 10) + 2*neq + 4*nin + 4  double
c
c     OUTPUT
c            wopt   : optimal portfolio (n)                       double
c            vriopt : optimal Value-at-Risk                       double
c            info   : diagnostic argument                        integer
c
c     CALL
c            EVBOR  : computing the minimum and maximum of a vector
c            OPMV   : computing optimization for ALLOCMV
c            WZERO  : put zero at the values of a vector less than eps
c                     and increase the greatest element with residual
c            YV     : copy a vector in a vector
c            XV     : computing scalar product of two vectors = V1'*V2
c            OVTMCV : computing V'*M*V = scalar
c                    ( M vectorized square matrix(n*n), V vector(n) )
c
c-----------------------------------------------------------------------
c
      IMPLICIT NONE
c
c     arguments i/o
      INTEGER n, neq, nin, maxdic, info
      DOUBLE PRECISION vrimax, conflp, epsdic, vriopt
      DOUBLE PRECISION cov(*), rho(*), cinf(*), csup(*),
     &                 ccst(*), bcst(*), wopt(*)
c
c     workspaces
      INTEGER iwork(*)
      DOUBLE PRECISION dwork(*)
c
c     local variables
      INTEGER niter, infmax, infqua, piwo, pdwopt, pdwo
      DOUBLE PRECISION p, q, zc, rhopt, optmean, optvar, volat, vrisav,
     &                 rhomin, rhomax, epsvri, xvri, eps, ornumber
      PARAMETER ( eps = 1.0E-15 )
c
c     external subroutines
      EXTERNAL EVBOR, opmv, WZERO, YV, XV, OVTMCV, dinvnr
      DOUBLE PRECISION dinvnr
c
c     intrinsic functions
      INTRINSIC sqrt, min, max, abs
c
c-----------------------------------------------------------------------
c
c     initializations
      info = 0
c
c     pointers for integer work space : iwork
c     ---------------------------------------
      piwo = 1
c     piwo  : pointer for OPMV ( 3*n + neq + 2*nin + 3 )
c
c     Total size of iwork array = ( 3*n + neq + 2*nin + 3 )
c
c     pointers for double precision work space  : dwork
c     -------------------------------------------------
      pdwopt = 1
c     pdwopt : pointer for wopt save vector(n)
      pdwo   = pdwopt + ( n )
c     pdwo   : pointer for internal workspace of OPMV
c              ( n*( n + neq + nin + 9 ) + 2*neq + 4*nin + 4  )
c
c     Total so size of dwork array = n
c                                  + n*(n+neq+nin+9)
c                                  + 2*neq + 4*nin + 4
c         = n*(n + neq + nin + 10) + 2*neq + 4*nin + 4
c
c-----------------------------------------------------------------------
c
c     rdt min/max (rhomin and rhomax)
      CALL EVBOR ( n, rho, rhomin, rhomax )
c
c     research optimal performance subject to Value-at-Risk constraint
c     (upper bound VaR) by dichotomy
c
c     initializations
      vrisav = 0.
      rhopt  = rhomax
      epsvri = 2.*epsdic
      vriopt = -1.0
      infmax = -107
      infqua = 0
      niter  = 0
      xvri   = -1.0
c
c     or number
      ornumber = 2.0/(1.0 + SQRT(5.0))
c
c     loop dichotomy search
      DO WHILE ( ( (niter .LE. maxdic).AND.(epsvri .GT. epsdic) ) .AND.
     &           ( (vrimax .GT. xvri) .OR. (niter .NE. 1) ) )
         niter = niter + 1
c
c        Mean-Variance allocation (Markowitz)
         CALL opmv ( n, cov, rho, rhopt,
     &               neq, nin, ccst, bcst, cinf, csup,
     &               iwork(piwo), dwork(pdwo), wopt, info )
c
c        if wopt(i)< eps then wopt(i) = 0
c        the residual increase max[wopt(i)]
         CALL WZERO ( n, wopt, eps )
c
c        error management
         IF (info .NE. 0) THEN
            IF (info .NE. 1001) THEN
                RETURN
            ELSE
                infqua = 1001
            ENDIF
         ELSE
            infqua = 0
            CALL YV ( n, wopt, dwork(pdwopt) )
         ENDIF
c
c        optimal portfolio ex-ante variance = w'*cov*w
         CALL OVTMCV ( n, cov, wopt, optvar )
c
c        optimal portfolio ex-ante volatility = sqrt(w'*cov*w)
         volat = sqrt(optvar)
c
c        optimal ex-ante mean return = w'*rmean
         CALL XV ( n, wopt, rho, optmean )
c
c        inverse of the N(0,1) cumulative distribution
c        call dinvnr(p,q)
         p  = conflp
         q  = 1. - p
         zc = dinvnr(p,q)
c
c     write p, q, zc
c      open(unit=1,file='zc.txt',status='unknown')
c	write(1,*) p
c	write(1,*) q
c	write(1,*) zc
c	close(unit=1)
c
c        ex-ante Value-at-Risk (upper bound)
c         xvri = - volat * sqrt( conflp/(1.-conflp) )
c         xvri = - volat * sqrt( conflp/(1.-conflp) ) + emret
c
c        ex-ante Normal Value-at-Risk
         xvri = - volat * zc
c         xvri = - volat * zc + emret
c
c     write VaR
c      open(unit=1,file='VaR.txt',status='unknown')
c	write(1,*)  xvri
c	close(unit=1)
c
c        impose that VaR in [-100%, 100%]
         xvri = MIN(xvri, 1.)
         xvri = MAX(xvri, -1.)
c
c        save the last best result
         IF (infqua .EQ. 0) THEN
            vrisav = xvri
         ELSE
            IF (niter .EQ. 1) THEN
               vrisav = xvri
               CALL YV ( n, wopt, dwork(pdwopt) )
               infqua = 0
               info   = 0
            ENDIF
         ENDIF
c
c        stop test
         epsvri = abs(xvri - vriopt)
         vriopt = xvri
c
c        dichotomy (objective return)
         IF (vrimax.lt.vriopt) THEN
            rhomin = rhopt
            infmax = 0
         ELSE
            rhomax = rhopt
         ENDIF
         rhopt = ( rhomax + rhomin ) / 2.
c          rhopt = ornumber * ( rhomax + rhomin )
      ENDDO
c
c     output management
      IF (niter.gt.maxdic) info = 106
      IF (infmax.ne.0) info = -infmax
      IF (infqua.ne.0) THEN
         info = infqua
         CALL YV ( n, dwork(pdwopt), wopt )
         vriopt = vrisav
      ENDIF
c
      RETURN
      END


      SUBROUTINE MB04OD( UPLO, N, M, P, R, LDR, A, LDA, B, LDB, C, LDC,
     $                   TAU, DWORK )
C
C     SLICOT RELEASE 5.7.
C
C     Copyright (c) 2002-2020 NICONET e.V.
C
C     PURPOSE
C
C     To calculate a QR factorization of the first block column and
C     apply the orthogonal transformations (from the left) also to the
C     second block column of a structured matrix, as follows
C                          _   _
C            [ R   B ]   [ R   B ]
C       Q' * [       ] = [     _ ]
C            [ A   C ]   [ 0   C ]
C                 _
C     where R and R are upper triangular. The matrix A can be full or
C     upper trapezoidal/triangular. The problem structure is exploited.
C
C     ARGUMENTS
C
C     Mode Parameters
C
C     UPLO    CHARACTER*1
C             Indicates if the matrix A is or not triangular as follows:
C             = 'U':  Matrix A is upper trapezoidal/triangular;
C             = 'F':  Matrix A is full.
C
C     Input/Output Parameters
C
C     N       (input) INTEGER                 _
C             The order of the matrices R and R.  N >= 0.
C
C     M       (input) INTEGER
C             The number of columns of the matrices B and C.  M >= 0.
C
C     P       (input) INTEGER
C             The number of rows of the matrices A and C.  P >= 0.
C
C     R       (input/output) DOUBLE PRECISION array, dimension (LDR,N)
C             On entry, the leading N-by-N upper triangular part of this
C             array must contain the upper triangular matrix R.
C             On exit, the leading N-by-N upper triangular part of this
C                                                        _
C             array contains the upper triangular matrix R.
C             The strict lower triangular part of this array is not
C             referenced.
C
C     LDR     INTEGER
C             The leading dimension of array R.  LDR >= MAX(1,N).
C
C     A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
C             On entry, if UPLO = 'F', the leading P-by-N part of this
C             array must contain the matrix A. If UPLO = 'U', the
C             leading MIN(P,N)-by-N part of this array must contain the
C             upper trapezoidal (upper triangular if P >= N) matrix A,
C             and the elements below the diagonal are not referenced.
C             On exit, the leading P-by-N part (upper trapezoidal or
C             triangular, if UPLO = 'U') of this array contains the
C             trailing components (the vectors v, see Method) of the
C             elementary reflectors used in the factorization.
C
C     LDA     INTEGER
C             The leading dimension of array A.  LDA >= MAX(1,P).
C
C     B       (input/output) DOUBLE PRECISION array, dimension (LDB,M)
C             On entry, the leading N-by-M part of this array must
C             contain the matrix B.
C             On exit, the leading N-by-M part of this array contains
C                                 _
C             the computed matrix B.
C
C     LDB     INTEGER
C             The leading dimension of array B.  LDB >= MAX(1,N).
C
C     C       (input/output) DOUBLE PRECISION array, dimension (LDC,M)
C             On entry, the leading P-by-M part of this array must
C             contain the matrix C.
C             On exit, the leading P-by-M part of this array contains
C                                 _
C             the computed matrix C.
C
C     LDC     INTEGER
C             The leading dimension of array C.  LDC >= MAX(1,P).
C
C     TAU     (output) DOUBLE PRECISION array, dimension (N)
C             The scalar factors of the elementary reflectors used.
C
C     Workspace
C
C     DWORK   DOUBLE PRECISION array, dimension (MAX(N-1,M))
C
C     METHOD
C
C     The routine uses N Householder transformations exploiting the zero
C     pattern of the block matrix.  A Householder matrix has the form
C
C                                     ( 1 )
C        H  = I - tau *u *u',    u  = ( v ),
C         i          i  i  i      i   (  i)
C
C     where v  is a P-vector, if UPLO = 'F', or a min(i,P)-vector, if
C            i
C     UPLO = 'U'.  The components of v  are stored in the i-th column
C                                     i
C     of A, and tau  is stored in TAU(i).
C                  i
C     In-line code for applying Householder transformations is used
C     whenever possible (see MB04OY routine).
C
C     NUMERICAL ASPECTS
C
C     The algorithm is backward stable.
C
C     CONTRIBUTORS
C
C     V. Sima, Katholieke Univ. Leuven, Belgium, Feb. 1997.
C
C     REVISIONS
C
C     Dec. 1997.
C
C     KEYWORDS
C
C     Elementary reflector, QR factorization, orthogonal transformation.
C
C     ******************************************************************
C
C     .. Scalar Arguments ..
      CHARACTER         UPLO
      INTEGER           LDA, LDB, LDC, LDR, M, N, P
C     .. Array Arguments ..
      DOUBLE PRECISION  A(LDA,*), B(LDB,*), C(LDC,*), DWORK(*),
     $                  R(LDR,*), TAU(*)
C     .. Local Scalars ..
      LOGICAL           LUPLO
      INTEGER           I, IM
C     .. External Functions ..
      LOGICAL           LSAME
      EXTERNAL          LSAME
C     .. External Subroutines ..
      EXTERNAL          DLARFG, MB04OY
C     .. Intrinsic Functions ..
      INTRINSIC         MIN
C     .. Executable Statements ..
C
C     For efficiency reasons, the parameters are not checked.
C
      IF( MIN( N, P ).EQ.0 )
     $   RETURN
C
      LUPLO = LSAME( UPLO, 'U' )
      IF ( LUPLO ) THEN
C
         DO 10 I = 1, N
C
C           Annihilate the I-th column of A and apply the
C           transformations to the entire block matrix, exploiting
C           its structure.
C
            IM = MIN( I, P )
            CALL DLARFG( IM+1, R(I,I), A(1,I), 1, TAU(I) )
C
C           Compute
C                           [ R(I,I+1:N)    ]
C           w := [ 1 v' ] * [               ],
C                           [ A(1:IM,I+1:N) ]
C
C           [ R(I,I+1:N)    ]    [ R(I,I+1:N)    ]         [ 1 ]
C           [               ] := [               ] - tau * [   ] * w .
C           [ A(1:IM,I+1:N) ]    [ A(1:IM,I+1:N) ]         [ v ]
C
            IF ( N-I.GT.0 )
     $         CALL MB04OY( IM, N-I, A(1,I), TAU(I), R(I,I+1), LDR,
     $                      A(1,I+1), LDA, DWORK )
C
C           Compute
C                           [  B(I,:)   ]
C           w := [ 1 v' ] * [           ],
C                           [ C(1:IM,:) ]
C
C           [   B(I,:)  ]    [  B(I,:)   ]         [ 1 ]
C           [           ] := [           ] - tau * [   ] * w.
C           [ C(1:IM,:) ]    [ C(1:IM,:) ]         [ v ]
C
C
            IF ( M.GT.0 )
     $         CALL MB04OY( IM, M, A(1,I), TAU(I), B(I,1), LDB, C, LDC,
     $                      DWORK )
   10    CONTINUE
C
      ELSE
C
         DO 20 I = 1, N - 1
C
C           Annihilate the I-th column of A and apply the
C           transformations to the first block column, exploiting its
C           structure.
C
            CALL DLARFG( P+1, R(I,I), A(1,I), 1, TAU(I) )
C
C           Compute
C                           [ R(I,I+1:N) ]
C           w := [ 1 v' ] * [            ],
C                           [ A(:,I+1:N) ]
C
C           [ R(I,I+1:N) ]    [ R(I,I+1:N) ]         [ 1 ]
C           [            ] := [            ] - tau * [   ] * w .
C           [ A(:,I+1:N) ]    [ A(:,I+1:N) ]         [ v ]
C
            CALL MB04OY( P, N-I, A(1,I), TAU(I), R(I,I+1), LDR,
     $                   A(1,I+1), LDA, DWORK )
   20    CONTINUE
C
         CALL DLARFG( P+1, R(N,N), A(1,N), 1, TAU(N) )
         IF ( M.GT.0 ) THEN
C
C           Apply the transformations to the second block column.
C
            DO 30 I = 1, N
C
C              Compute
C                              [ B(I,:) ]
C              w := [ 1 v' ] * [        ],
C                              [   C    ]
C
C              [ B(I,:) ]    [ B(I,:) ]         [ 1 ]
C              [        ] := [        ] - tau * [   ] * w.
C              [   C    ]    [   C    ]         [ v ]
C
               CALL MB04OY( P, M, A(1,I), TAU(I), B(I,1), LDB, C, LDC,
     $                      DWORK )
   30       CONTINUE
C
         END IF
      END IF
      RETURN
C *** Last line of MB04OD ***
      END


! { dg-do compile }
! { dg-options "-fdump-tree-original" }
!
! PR fortran/56650
! PR fortran/36437
!
module m
  use iso_c_binding, only: c_sizeof, c_int
  implicit none

  integer(c_int), bind(C) :: MPI_Status_C_obj
  integer,parameter :: MPI_STATUS_SIZE = c_sizeof(MPI_Status_C_obj)
end module m

module m2
  use iso_c_binding, only: c_sizeof, c_int
  implicit none

  integer(c_int), bind(C) :: MPI_Status_C_obj2
  integer,parameter :: MPI_STATUS_SIZE2 &
                    = c_sizeof(MPI_Status_C_obj2)*8/bit_size(0)
end module m2

subroutine test()
  use m
  use m2
  integer :: m1test, m2test
  m1test = MPI_STATUS_SIZE
  m2test = MPI_STATUS_SIZE2
end subroutine test

type t
  character(len=20) :: str
end type t
type(t):: x(5)
integer :: iii, jjj
iii = sizeof (x)       ! 5*20 (whole size in bytes)
jjj = storage_size (x) ! 8*20 (element size in bits)
end

! { dg-final { scan-tree-dump-times "m1test = 4;" 1 "original" } }
! { dg-final { scan-tree-dump-times "m2test = 1;" 1 "original" } }
! { dg-final { scan-tree-dump-times "iii = 100;" 1 "original" } }
! { dg-final { scan-tree-dump-times "jjj = 160;" 1 "original" } }