! libRQZ
! author: daan. camps@cs.kuleuven.be
! Description:
!   Deflation monitoring
! ___________________________________________________________________
module d_deflations

use u_activeparts
use u_parameters
use d_ctransformations
use d_memorymgmt
use d_computepoles

implicit none
private
public d_check_interior_deflations, d_start_deflation_single, &
       d_start_deflation_double, d_stop_deflation_single, &
       d_stop_deflation_double
contains

  subroutine d_check_interior_deflations(defl,A, B, compAB, apC, apT, &
              Q, compQ, qcol, Z, compZ, zcol)
  ! DESCRIPTION
  !___________________________________________________________________________
  ! Check for interior deflations in active part defined by apC.
  ! When deflated poles are encountered, the pencil is updated,
  ! i.e., these poles are explicitly set to zero, and the active
  ! parts list apC is updated.The boolean defl returns true when
  ! at least 1 deflation is found.
  !
  ! ARGUMENTS
  !___________________________________________________________________________
  ! defl    boolean [OUT]
  !           Deflation indicator
  ! A       double array [INOUT]
  !           Upper block-Hessenberg matrix A
  ! B       double array [INOUT]
  !           Upper block-Hessenberg matrix B
  ! compAB  boolean [IN]
  !           If true, the equivalences are applied to (A,B). If not,
  !           then only to the active parts
  ! apC     type(tAp) [INOUT]
  !           Active parts linked list.
  ! apT     type(tAp) [IN]
  !           Total part of the pencil the method is acting on
  !           (used when compAB is true)
  !           Normally, the following order,
  !             tstrt <= cstrt < i < i+1 < cstp <= tstp,
  !           holds when calling d_swap. c = current, t = total
  ! Q       double array [INOUT]
  !           Unitary equivalence matrix Q
  ! compQ   boolean [IN]
  !           If true, the left Schur vectors are updated
  ! qcol    integer [IN]
  !           Start index of the columns of Q that are updated:
  !              qcol, qcol+1
  ! Z       double array [INOUT]
  !           Unitary equivalence matrix Z
  ! compZ   boolean [IN]
  !           If true, the right Schur vectors are updated
  ! zcol    integer [IN]
  !           Start index of the columns of Z that are updated:
  !              zcol, zcol+1
  !___________________________________________________________________________
  ! last edit: January 11, 2018
    real(kind=dp), intent(inout)      :: A(:,:), B(:,:), Q(:,:), Z(:,:)
    type(tAp), pointer, intent(inout) :: apC
    type(tAp), pointer, intent(in)    :: apT
    logical, intent(out)              :: defl
    logical, intent(in)               :: compAB, compQ, compZ
    integer, intent(in)               :: qcol, zcol

    integer                           :: i, j, cpy, cpystrt
    integer, pointer                  :: cstrt, cstp, tstrt, tstp
    real(kind=dp)                     :: l1, l2
    logical                           :: isreal, defli
    call tApGet(apC,cstrt,cstp)
    call tApGet(apT,tstrt,tstp)

    defl = .false.
    i = cstrt+1
    cpystrt = cstrt
    do while (i .le. cstp-2)
      if (abs(A(i+2,i)) .gt. dzero) then
        ! double pole
        call d_eigenvalues2x2(A,B,i+1,i,l1,l2,isreal)
        if (isreal) then
          ! Not C.C.
          call d_make_hess(l1,i+1,i,A,B,compAB,apC,apT,Q,compQ,qcol+i-cpystrt,&
                 Z,compZ,zcol+i-cpystrt-1)
          call d_interior_deflation_sng(i,defli,A,B)
          if (defli) then
            defl = .true.
            ! update active parts
            cpy = cstp
            call tApPut(apC,strt=cstrt, stp=i)
            call tApInsertAfter(apC,strt=i,stp=cpy)
            apC => tApNext(apC)
            call tApGet(apC,cstrt,cstp) ! this does update cstrt,cstp
                                        !(but does not affect the loop counter)
          end if
          i = i + 1
        else
          j = i
          call d_interior_deflation_dbl(j,defli,A,B)
          if (defli) then
            defl = .true.
            ! update active parts
            cpy = cstp
            call tApPut(apC,strt=cstrt, stp=i+j)
            call tApInsertAfter(apC,strt=i+j,stp=cpy)
            apC => tApNext(apC)
            call tApGet(apC,cstrt,cstp) ! this does update cstrt,cstp
                                        !(but does not affect the loop counter)
          end if
          i = i + 2
        end if
      else
        call d_interior_deflation_sng(i,defli,A,B)
        if (defli) then
          defl = .true.
          ! update active parts
          cpy = cstp
          call tApPut(apC,strt=cstrt, stp=i)
          call tApInsertAfter(apC,strt=i,stp=cpy)
          apC => tApNext(apC)
          call tApGet(apC,cstrt,cstp) ! this does update cstrt,cstp
                                      !(but does not affect the loop counter)
        end if
        i = i + 1
      end if
    end do
  end subroutine d_check_interior_deflations

  subroutine d_interior_deflation_sng(i,defl,A,B)
    ! DESCRIPTION
    !___________________________________________________________________________
    ! Test if the single interior pole at position (i+1,i) in (A,B)
    ! is deflated
    !
    ! ARGUMENTS
    !___________________________________________________________________________
    ! i       integer [IN]
    !           column index of single pole
    ! defl    boolean [INOUT]
    !           returns true of the ith pole can be deflated.
    !           If so, the respective entries in A,B are set to zero.
    ! A       double array [INOUT]
    !           block-Hessenberg matrix
    ! B       double array [INOUT]
    !           Hessenberg matrix
    !
    ! NOTA
    !___________________________________________________________________________
    ! This is a private subroutine called from  d_check_interior_deflations
    !___________________________________________________________________________
    ! last edit: January 11, 2019
    real(kind=dp), intent(inout)      :: A(:,:), B(:,:)
    integer, intent(in)               :: i
    logical, intent(inout)            :: defl

    defl = .false.
    if ((abs(A(i+1,i)) .lt. mp * (abs(A(i,i)) + abs(A(i+1,i+1)))) .and. &
      (abs(B(i+1,i)) .lt. mp * (abs(B(i,i)) + abs(B(i+1,i+1))))) then
      ! Set to zero
      defl = .true.
      A(i+1,i) = dzero
      B(i+1,i) = dzero
    end if
  end subroutine

  subroutine d_interior_deflation_dbl(i,defl,A,B)
  ! DESCRIPTION
  !___________________________________________________________________________
  ! Test if the double interior pole at position (i+1:i+2,i:i+1)
  ! in (A,B) is deflated
  ! ARGUMENTS
  !___________________________________________________________________________
  ! i       integer [IN]
  !           column index of double pole
  ! defl    boolean [INOUT]
  !           returns true of the ith pole can be deflated.
  !           If so, the respective entries in A,B are set to zero.
  ! A       double array [INOUT]
  !           block-Hessenberg matrix
  ! B       double array [INOUT]
  !           Hessenberg matrix
  !
  ! NOTA
  !___________________________________________________________________________
  ! This is a private subroutine called from  d_check_interior_deflations
  !___________________________________________________________________________
  ! last edit: February 7, 2019
    real(kind=dp), intent(inout)      :: A(:,:), B(:,:)
    logical, intent(inout)            :: defl
    integer, intent(inout)            :: i

    defl = .false.
    if (((abs(A(i+2,i)) + abs(A(i+2,i+1))) .lt. mp * &
        (abs(A(i+1,i+1)) + abs(A(i+2,i+2)))) .and. &
        (abs(B(i+2,i+1)) .lt. mp * &
        (abs(B(i+1,i+1)) + abs(B(i+2,i+2))))) then
        defl = .true.
        B(i+2,i:i+1) = dzero
        A(i+2,i:i+1) = dzero
        i = 1 ! Ensures that active parts are handled in calling function
    elseif (((abs(A(i+1,i)) + abs(A(i+2,i))) .lt. mp * &
        (abs(A(i,i)) + abs(A(i+1,i+1)))) .and. &
        (abs(B(i+1,i)) .lt. mp * &
        (abs(B(i,i)) + abs(B(i+1,i+1))))) then
        defl = .true.
        B(i+1:i+2,i) = dzero
        A(i+1:i+2,i) = dzero
        i = 0 ! Ensures that active parts are handled in calling function
      end if
  end subroutine

  subroutine d_start_deflation_single(defl, A, B, compAB, apC, apT, &
                                     Q, compQ, qcol)
  ! DESCRIPTION
  !___________________________________________________________________________
  ! Check for deflation at the start of the active area
  ! The pencil (A,B) and the Q matrix is updated as requested if a deflation
  ! is found.
  ! The current active part apC is also updated, which also updates
  ! it in the caller function.
  !
  ! ARGUMENTS
  !___________________________________________________________________________
  ! defl    boolean [OUT]
  !           Deflation indicator (true if deflated, else false)
  ! A       complex double array [INOUT]
  !           Upper Hessenberg matrix A
  ! B       complex double array [INOUT]
  !           Upper Hessenberg matrix B
  ! compAB  boolean [INOUT]
  !           If true, the equivalences are applied to (A,B) as defined by
  !           apT. If not, then only to the active part apC
  ! apC     type(tAp) [INOUT]
  !           Current active part
  ! apT     type(tAp) [IN]
  !           Total part of the pencil the method is acting on
  !           (used when compAB is true)
  ! Q       complex double array [INOUT]
  !           Unitary equivalence matrix Q
  ! compQ   boolean [IN]
  !           If true, the left Schur vectors are updated
  ! qcol    integer [IN]
  !           Start index of the columns of Q that are updated:
  !              qcol, qcol+1
  !___________________________________________________________________________
  ! last edit: September 12, 2018
    real(kind=dp), intent(inout)      ::  A(:,:), B(:,:), Q(:,:)
    logical, intent(in)               ::  compAB, compQ
    integer, intent(in)               ::  qcol
    logical, intent(out)              ::  defl
    type(tAp), pointer, intent(inout) ::  apC
    type(tAp), pointer, intent(in)    ::  apT

    real(kind=dp)                     :: c,s,r,t, tt, u(2)
    integer,pointer                   :: cstrt, cstp, tstrt, tstp
    integer                           :: LDQ

    call d_getLeadingDim(LDQ,Q)

    ! Get current and total ranges
    call tApGet(apC,cstrt,cstp)
    call tApGet(apT,tstrt,tstp)

    defl = .false.
    ! first check for direct deflation
    if ((abs(A(cstrt+2,cstrt+1)) .lt. &
         mp*(abs(A(cstrt+1,cstrt+1)) + abs(A(cstrt+2,cstrt+2)))) .and. &
        (abs(B(cstrt+2,cstrt+1)) .lt. &
         mp*(abs(B(cstrt+1,cstrt+1)) + abs(B(cstrt+2,cstrt+2))))) then
        defl = .true.
        A(cstrt+2,cstrt+1) = dzero
        B(cstrt+2,cstrt+1) = dzero
        ! This also updates it in the caller function
        call tApPut(apC,strt=cstrt+1,stp=cstp)
    elseif (abs(A(cstrt+1,cstrt+1) * B(cstrt+2,cstrt+1) - &
                A(cstrt+2,cstrt+1) * B(cstrt+1,cstrt+1)) .lt. &
           mp*(abs(A(cstrt+2,cstrt+2)) + abs(B(cstrt+2,cstrt+2)))) then
      if (abs(A(cstrt+2,cstrt+1)) .ge. abs(B(cstrt+2,cstrt+1))) then
        ! Compute rotation based on A
        call d_compute_ct(A(cstrt+1,cstrt+1),A(cstrt+2,cstrt+1),c,s,r)
        ! Apply to B
        r = B(cstrt+1,cstrt+1)
        t = B(cstrt+2,cstrt+1)
        u = B(cstrt+1:cstrt+2,cstrt+2)
      else
        ! Compute rotation based on B
        call d_compute_ct(B(cstrt+1,cstrt+1),B(cstrt+2,cstrt+1),c,s,r)
        ! Apply to A
        r = A(cstrt+1,cstrt+1)
        t = A(cstrt+2,cstrt+1)
        u = A(cstrt+1:cstrt+2,cstrt+2)
      end if

      tt = -s * r + c * t
      r = c * r + s * t
      t = tt
      u(2) = -s * u(1) + c * u(2)

      if (abs(t) .lt. mp*(abs(r) + abs(u(2)))) then
        defl = .true.
        if (compAB) then
          call d_apply_ct_l(A(cstrt+1,cstrt+1:tstp),A(cstrt+2,cstrt+1:tstp),c,s)
          call d_apply_ct_l(B(cstrt+1,cstrt+1:tstp),B(cstrt+2,cstrt+1:tstp),c,s)
        else
          call d_apply_ct_l(A(cstrt+1,cstrt+1:cstp),A(cstrt+2,cstrt+1:cstp),c,s)
          call d_apply_ct_l(B(cstrt+1,cstrt+1:cstp),B(cstrt+2,cstrt+1:cstp),c,s)
        end if
        if (compQ) then
          call d_apply_ct_r(Q(1:LDQ,qcol),Q(1:LDQ,qcol+1),c,-s)
        end if
        A(cstrt+2,cstrt+1) = dzero
        B(cstrt+2,cstrt+1) = dzero
        ! This also updates it in the caller function
        call tApPut(apC,strt=cstrt+1,stp=cstp)
      end if
    end if

    ! Double check if a 2x2 block has separated
    if (cstp-cstrt .gt. 3) then
      if (.not. (defl .or. (abs(A(cstrt+4,cstrt+2)) .gt. dzero))) then
      call d_interior_deflation_sng(cstrt+2,defl,A,B)
      if (defl) then
        ! update active parts
        call tApInsertAfter(apC,strt=cstrt+2,stp=cstp)
        call tApPut(apC,strt=cstrt, stp=cstrt+2)
      end if
     end if
    end if
  end subroutine d_start_deflation_single

  subroutine d_start_deflation_double(defl, A, B, compAB, apC, apT, &
                                     Q, compQ, qcol, Z, compZ, zcol)
  ! DESCRIPTION
  !___________________________________________________________________________
  ! Check for deflation at the start of the active area. It is assumed
  ! that there is a double pole at the start. It is also checked if the double
  ! pole actually is a complex conjugate pair. If not, the Hessenberg form
  ! is restored and a single deflation is checked.
  ! The pencil (A,B) and the Q and Z matrices are updated as requested
  ! if a deflation is found.
  ! The current active part apC is also updated, which also updates
  ! it in the caller function.
  !
  ! ARGUMENTS
  !___________________________________________________________________________
  ! defl    boolean [OUT]
  !           Deflation indicator (true if deflated, else false)
  ! A       complex double array [INOUT]
  !           Upper Hessenberg matrix A
  ! B       complex double array [INOUT]
  !           Upper Hessenberg matrix B
  ! compAB  boolean [INOUT]
  !           If true, the equivalences are applied to (A,B) as defined by
  !           apT. If not, then only to the active part apC
  ! apC     type(tAp) [INOUT]
  !           Current active part
  ! apT     type(tAp) [IN]
  !           Total part of the pencil the method is acting on
  !           (used when compAB is true)
  ! Q       complex double array [INOUT]
  !           Unitary equivalence matrix Q
  ! compQ   boolean [IN]
  !           If true, the left Schur vectors are updated
  ! qcol    integer [IN]
  !           Start index of the columns of Q that are updated:
  !              qcol, qcol+1, qcol+2
  ! Z       double array [INOUT]
  !           Orthonormal equivalence matrix Z
  ! compZ   boolean [IN]
  !           If true, the right Schur vectors are updated
  ! zcol    integer [IN]
  !           Start index of the columns of Z that are updated:
  !              zcol, zcol+1
  !___________________________________________________________________________
  ! last edit: September 12, 2018
  real(kind=dp), intent(inout)      ::  A(:,:), B(:,:), Q(:,:), Z(:,:)
  logical, intent(in)               ::  compAB, compQ, compZ
  integer, intent(in)               ::  qcol, zcol
  logical, intent(out)              ::  defl
  type(tAp), pointer, intent(inout) ::  apC
  type(tAp), pointer, intent(in)    ::  apT

  real(kind=dp)                     :: c,c2,s,s2,r,t
  logical                           :: isreal
  integer,pointer                   :: cstrt, cstp, tstrt, tstp
  integer                           :: LDAB, LDR, LDC, LDQ
  external                          :: DGEMM

  call d_getLeadingDim(LDAB,A)
  call d_getLeadingDim(LDR,Ru)
  call d_getLeadingDim(LDC,Cu)
  call d_getLeadingDim(LDQ,Q)

  ! Get current and total ranges
  call tApGet(apC,cstrt,cstp)
  call tApGet(apT,tstrt,tstp)

  defl = .false.

  ! Check first if it actually a cc pole
  call d_eigenvalues2x2(A,B,cstrt+2,cstrt+1,c,c2,isreal)
  if (isreal) then
    call d_make_hess(c,cstrt+2,cstrt+1,A,B,compAB,apC,apT,Q,compQ,qcol+1,&
                       Z,compZ,zcol)
    call d_start_deflation_single(defl,A,B,compAB,apC,apT,Q,compQ,qcol)
  else
    ! Compute the QR factorization
    ! We create a copy of the leading block for the deflation test
    Q4(1:3,1:2) = A(cstrt+1:cstrt+3,cstrt+1:cstrt+2)
    Z4(1:3,1:2) = B(cstrt+1:cstrt+3,cstrt+1:cstrt+2)
    ! Create zero in B(cstrt+2,cstrt+1)
    call d_compute_ct(Z4(1,1),Z4(2,1),c,s,r)
    ! Apply transformation
    Z4(1,1) = r
    Z4(2,1) = dzero
    t = -s * Z4(1,2) + c * Z4(2,2)
    Z4(1,2) = c * Z4(1,2) + s * Z4(2,2)
    Z4(2,2) = t
    call d_apply_ct_l(Q4(1,1:2),Q4(2,1:2),c,s)
    ! Try to zero row cstrt+3 all at once
    if ((abs(Z4(3,2)) .gt. abs(Q4(3,1))) .and. &
       (abs(Z4(3,2)) .gt. abs(Q4(3,2)))) then
      call d_compute_ct(Z4(2,2),Z4(3,2),c2,s2,r)
      Z4(2,2) = r
      Z4(3,2) = dzero
    else
      if (abs(Q4(3,1)) .gt. abs(Q4(3,2))) then
        call d_compute_ct(Q4(2,1),Q4(3,1),c2,s2,r)
      else
        call d_compute_ct(Q4(2,2),Q4(3,2),c2,s2,r)
      end if
      t = -s2 * Z4(2,2) + c2 * Z4(3,2)
      Z4(2,2) = c2 * Z4(2,2) + s2 * Z4(3,2)
      Z4(3,2) = t
    end if
    call d_apply_ct_l(Q4(2,1:2),Q4(3,1:2),c2,s2)
    ! Test if deflated
    if (((abs(Q4(3,1)) + abs(Q4(3,2))) .lt. &
          mp * (abs(Q4(1,1)) + abs(Q4(2,2)) + abs(Q4(1,2)) &
          + abs(Q4(2,1)))) .and. (abs(Z4(3,2)) .lt. &
           mp * (abs(Z4(1,1)) + abs(Z4(2,2)) + abs(Z4(1,2))))) then
        defl = .true.
        ! Construct Q
        Q4 = dzero
        Q4(1,1) = done
        Q4(2,2) = done
        Q4(3,3) = done
        call d_apply_ct_l(Q4(1,1:3),Q4(2,1:3),c,s)
        call d_apply_ct_l(Q4(2,1:3),Q4(3,1:3),c2,s2)
    end if

    if (defl) then
      if (compAB) then
        call DGEMM('N','N',3,tstp-cstrt,3,done,Q4(1,1),4,A(cstrt+1,cstrt+1),&
                       LDAB,dzero,Ru(1,1),LDR)
        A(cstrt+1:cstrt+3,cstrt+1:tstp) = Ru(1:3,1:tstp-cstrt)
        call DGEMM('N','N',3,tstp-cstrt,3,done,Q4(1,1),4,B(cstrt+1,cstrt+1),&
                       LDAB,dzero,Ru(1,1),LDR)
        B(cstrt+1:cstrt+3,cstrt+1:tstp) = Ru(1:3,1:tstp-cstrt)
      else
        call DGEMM('N','N',3,cstp-cstrt,3,done,Q4(1,1),4,A(cstrt+1,cstrt+1),&
                       LDAB,dzero,Ru(1,1),LDR)
        A(cstrt+1:cstrt+3,cstrt+1:cstp) = Ru(1:3,1:cstp-cstrt)
        call DGEMM('N','N',3,cstp-cstrt,3,done,Q4(1,1),4,B(cstrt+1,cstrt+1),&
                       LDAB,dzero,Ru(1,1),LDR)
        B(cstrt+1:cstrt+3,cstrt+1:cstp) = Ru(1:3,1:cstp-cstrt)
      end if
      ! Put elements to zero
      A(cstrt+3,cstrt+1:cstrt+2) = dzero
      B(cstrt+3,cstrt+1:cstrt+2) = dzero
      B(cstrt+2,cstrt+1) = dzero
      if (compQ) then
        call DGEMM('N','T',LDQ,3,3,cone,Q(1,qcol),LDQ,Q4(1,1),4,&
                      czero,Cu(1,1),LDC)
        Q(1:LDQ,qcol:qcol+2) = Cu(1:LDQ,1:3)
      end if
      ! This also updates it in the caller function
      call tApPut(apC,strt=cstrt+2,stp=cstp)
    end if
  end if
  end subroutine d_start_deflation_double

  subroutine d_stop_deflation_single(defl, A, B, compAB, apC, apT,&
                                    Z, compZ, zcol )
  !___________________________________________________________________________
  ! DESCRIPTION
  !___________________________________________________________________________
  ! Check for deflation at the end of the active area
  ! The pencil (A,B) and the Z matrix is updated as requested if a deflation
  ! is found.
  ! The current active part apC is also updated, which also updates
  ! it in the caller function.
  !
  ! ARGUMENTS
  !___________________________________________________________________________
  ! defl    boolean [OUT]
  !           Deflation indicator (true if deflated, else false)
  ! A       complex double array [INOUT]
  !           Upper Hessenberg matrix A
  ! B       complex double array [INOUT]
  !           Upper Hessenberg matrix B
  ! compAB  boolean [INOUT]
  !           If true, the equivalences are applied to (A,B). If not,
  !           then only to the current active part
  ! apC     type(tAp) [INOUT]
  !           Current active part
  ! apT     type(tAp) [IN]
  !           Total part of the pencil the method is acting on
  !           (used when compAB is true)
  ! Z       complex double array [INOUT]
  !           Unitary equivalence matrix Z
  ! compZ   boolean [IN]
  !           If true, the right Schur vectors are updated
  ! zcol    integer [IN]
  !           Start index of the columns of Z that are updated:
  !              zcol, zcol+1
  !___________________________________________________________________________
  ! last edit: September 12, 2018
    real(kind=dp), intent(inout)      ::  A(:,:), B(:,:), Z(:,:)
    logical, intent(in)               ::  compAB, compZ
    integer, intent(in)               ::  zcol
    logical, intent(out)              ::  defl
    type(tAp), pointer, intent(inout) ::  apC
    type(tAp), pointer, intent(in)    ::  apT

    real(kind=dp)                     :: c, s, r,t, tt, u(2)
    integer,pointer                   :: cstrt, cstp, tstrt, tstp
    integer                           :: LDZ

    call d_getLeadingDim(LDZ,Z)

    call tApGet(apC,cstrt,cstp)
    call tApGet(apT,tstrt,tstp)

    defl = .false.
    ! first check for direct deflation
    if ((abs(A(cstp,cstp-1)) .lt. &
         mp*(abs(A(cstp,cstp)) + abs(A(cstp-1,cstp-1)))) .and. &
        (abs(B(cstp,cstp-1)) .lt. &
         mp*(abs(B(cstp,cstp)) + abs(B(cstp-1,cstp-1))))) then
      defl = .true.
      A(cstp,cstp-1) = dzero
      B(cstp,cstp-1) = dzero
      ! This also updates it in the caller function
      call tApPut(apC,strt=cstrt,stp=cstp-1)
    elseif (abs(A(cstp,cstp) * B(cstp,cstp-1) - &
                A(cstp,cstp-1) * B(cstp,cstp)) .lt. &
           mp*(abs(A(cstp-1,cstp-1)) + abs(B(cstp-1,cstp-1)))) then
      if (abs(A(cstp,cstp-1)) .ge. abs(B(cstp,cstp-1))) then
        ! Compute rotation based on A
        call d_compute_ct(A(cstp,cstp),A(cstp,cstp-1),c,s,r)
        ! Apply to B
        r = B(cstp,cstp)
        t = B(cstp,cstp-1)
        u = B(cstp-1,cstp-1:cstp)
      else
        ! Compute rotation based on B
        call d_compute_ct(B(cstp,cstp),B(cstp,cstp-1),c,s,r)
        ! Apply to A
        r = A(cstp,cstp)
        t = A(cstp,cstp-1)
        u = A(cstp-1,cstp-1:cstp)
      end if

      tt = -s * r + c * t
      r = c * r + s * t
      t = tt
      u(2) =  -s * u(1) + c * u(2)

      if (abs(t) .lt. mp*(abs(r) + abs(u(2)))) then
        defl = .true.
        if (compAB) then
          call d_apply_ct_r(A(tstrt+1:cstp,cstp-1),A(tstrt+1:cstp,cstp),c,s)
          call d_apply_ct_r(B(tstrt+1:cstp,cstp-1),B(tstrt+1:cstp,cstp),c,s)
        else
          call d_apply_ct_r(A(cstrt+1:cstp,cstp-1),A(cstrt+1:cstp,cstp),c,s)
          call d_apply_ct_r(B(cstrt+1:cstp,cstp-1),B(cstrt+1:cstp,cstp),c,s)
        endif
        if (compZ) then
          call d_apply_ct_r(Z(1:LDZ,zcol),Z(1:LDZ,zcol+1),c,s)
        end if
        A(cstp,cstp-1) = dzero
        B(cstp,cstp-1) = dzero
        ! This also updates it in the caller function
        call tApPut(apC,strt=cstrt,stp=cstp-1)
      end if
    end if

    ! Double check if a 2x2 block has separated
    if (cstp-cstrt .gt. 3) then
      if (.not. (defl .or. (abs(A(cstp-1,cstp-3)) .gt. dzero))) then
      call d_interior_deflation_sng(cstp-2,defl,A,B)
      if (defl) then
        ! update active parts
        call tApInsertAfter(apC,strt=cstp-2,stp=cstp)
        call tApPut(apC,strt=cstrt, stp=cstp-2)
      end if
     end if
    end if
  end subroutine d_stop_deflation_single

  subroutine d_stop_deflation_double(defl, A, B, compAB, apC, apT,&
                                    Q, compQ, qcol, Z, compZ, zcol )
  ! DESCRIPTION
  !___________________________________________________________________________
  ! Check for deflation at the end of the active area. It is assumed
  ! that there is a double pole at the end. It is also checked if the double
  ! pole actually is a complex conjugate pair. If not, the Hessenberg form
  ! is restored and a single deflation is checked.
  ! The pencil (A,B) and the Q and Z matrices are updated as requested
  ! if a deflation is found.
  ! The current active part apC is also updated, which also updates
  ! it in the caller function.
  !
  ! ARGUMENTS
  !___________________________________________________________________________
  ! defl    boolean [OUT]
  !           Deflation indicator (true if deflated, else false)
  ! A       complex double array [INOUT]
  !           Upper Hessenberg matrix A
  ! B       complex double array [INOUT]
  !           Upper Hessenberg matrix B
  ! compAB  boolean [INOUT]
  !           If true, the equivalences are applied to (A,B) as defined by
  !           apT. If not, then only to the active part apC
  ! apC     type(tAp) [INOUT]
  !           Current active part
  ! apT     type(tAp) [IN]
  !           Total part of the pencil the method is acting on
  !           (used when compAB is true)
  ! Q       complex double array [INOUT]
  !           Unitary equivalence matrix Q
  ! compQ   boolean [IN]
  !           If true, the left Schur vectors are updated
  ! qcol    integer [IN]
  !           Start index of the columns of Q that are updated:
  !              qcol, qcol+1
  ! Z       double array [INOUT]
  !           Orthonormal equivalence matrix Z
  ! compZ   boolean [IN]
  !           If true, the right Schur vectors are updated
  ! zcol    integer [IN]
  !           Start index of the columns of Z that are updated:
  !              zcol, zcol+1, zcol+2
  !___________________________________________________________________________
  ! last edit: January 22, 2019
  real(kind=dp), intent(inout)      ::  A(:,:), B(:,:), Q(:,:),Z(:,:)
  logical, intent(in)               ::  compAB, compQ, compZ
  integer, intent(in)               ::  qcol, zcol
  logical, intent(out)              ::  defl
  type(tAp), pointer, intent(inout) ::  apC
  type(tAp), pointer, intent(in)    ::  apT

  real(kind=dp)                     :: c, c2, s, s2, r,t
  logical                           :: isreal
  integer,pointer                   :: cstrt, cstp, tstrt, tstp
  integer                           :: LDAB, LDC, LDZ

  external                          :: DGEMM

  call d_getLeadingDim(LDAB,A)
  call d_getLeadingDim(LDC,Cu)
  call d_getLeadingDim(LDZ,Z)

  call tApGet(apC,cstrt,cstp)
  call tApGet(apT,tstrt,tstp)

  defl = .false.

  ! Check first if it is actually a cc pole
  call d_eigenvalues2x2(A,B,cstp-1,cstp-2,c,c2,isreal)
  if (isreal) then
    call d_make_hess(c,cstp-1,cstp-2,A,B,compAB,apC,apT,Q,compQ,qcol,&
                       Z,compZ,zcol)
    call d_stop_deflation_single(defl,A,B,compAB,apC,apT,Z,compZ,zcol)
  else
    ! Compute the RQ factorization
    ! We create a copy of the trailing block for the deflation test
    Q4(1:2,1:3) = A(cstp-1:cstp,cstp-2:cstp)
    Z4(1:2,1:3) = B(cstp-1:cstp,cstp-2:cstp)
    ! Create zero in B(cstp,cstp-1)
    call d_compute_ct(Z4(2,3),Z4(2,2),c,s,r)
    ! Apply transformation
    Z4(2,3) = r
    Z4(2,2) = dzero
    t = s * Z4(1,2) + c * Z4(1,3)
    Z4(1,2) = c * Z4(1,2) - s * Z4(1,3)
    Z4(1,3) = t
    call d_apply_ct_r(Q4(1:2,2),Q4(1:2,3),c,s)
    ! Try to zero column cstp-2 all at once
    if ((abs(Z4(1,1)) .gt. abs(Q4(1,1))) .and. &
       (abs(Z4(1,1)) .gt. abs(Q4(2,1)))) then
      call d_compute_ct(Z4(1,2),Z4(1,1),c2,s2,r)
      Z4(1,1) = dzero
      Z4(1,2) = r
    else
      if (abs(Q4(1,1)) .gt. abs(Q4(2,1))) then
        call d_compute_ct(Q4(1,2),Q4(1,1),c2,s2,r)
      else
        call d_compute_ct(Q4(2,2),Q4(2,1),c2,s2,r)
      end if
      t = s2 * Z4(1,1) + c2 * Z4(1,2)
      Z4(1,1) = c2 * Z4(1,1) - s2 * Z4(1,2)
      Z4(1,2) = t
    end if
    call d_apply_ct_r(Q4(1:2,1),Q4(1:2,2),c2,s2)
    ! Test if deflated
    if (((abs(Q4(1,1)) + abs(Q4(2,1))) .lt. &
          mp * (abs(Q4(1,2)) + abs(Q4(2,3)) + abs(Q4(1,3)) &
          + abs(Q4(2,2)))) .and. (abs(Z4(1,1)) .lt. &
           mp * (abs(Z4(1,2)) + abs(Z4(2,3))+ abs(Z4(1,3))))) then
        defl = .true.
        ! Construct Z
        Z4 = dzero
        Z4(1,1) = done
        Z4(2,2) = done
        Z4(3,3) = done
        call d_apply_ct_r(Z4(1:3,2),Z4(1:3,3),c,s)
        call d_apply_ct_r(Z4(1:3,1),Z4(1:3,2),c2,s2)
    end if

    if (defl) then
      if (compAB) then
        call DGEMM('N','N',cstp-tstrt,3,3,done,A(tstrt+1,cstp-2),LDAB,&
                  Z4(1,1),4,dzero,Cu(1,1),LDC)
        A(tstrt+1:cstp,cstp-2:cstp) = Cu(1:cstp-tstrt,1:3)
        call DGEMM('N','N',cstp-tstrt,3,3,done,B(tstrt+1,cstp-2),LDAB,&
                  Z4(1,1),4,dzero,Cu(1,1),LDC)
        B(tstrt+1:cstp,cstp-2:cstp) = Cu(1:cstp-tstrt,1:3)
      else
        call DGEMM('N','N',cstp-cstrt,3,3,done,A(cstrt+1,cstp-2),LDAB,&
                 Z4(1,1),4,dzero,Cu(1,1),LDC)
        A(cstrt+1:cstp,cstp-2:cstp) = Cu(1:cstp-cstrt,1:3)
        call DGEMM('N','N',cstp-cstrt,3,3,done,B(cstrt+1,cstp-2),LDAB,&
                 Z4(1,1),4,dzero,Cu(1,1),LDC)
        B(cstrt+1:cstp,cstp-2:cstp) = Cu(1:cstp-cstrt,1:3)
      end if
      ! Put elements to zero
      A(cstp-1:cstp,cstp-2) = dzero
      B(cstp-1:cstp,cstp-2) = dzero
      B(cstp,cstp-1) = dzero
      if (compZ) then
        call DGEMM('N','N',LDZ,3,3,done,Z(1,zcol),LDZ,Z4(1,1),4,&
                   dzero,Cu(1,1),LDC)
        Z(1:LDZ,zcol:zcol+2) = Cu(1:LDZ,1:3)
      end if
      ! This also updates it in the caller function
      call tApPut(apC,strt=cstrt,stp=cstp-2)
    end if
  end if
  end subroutine d_stop_deflation_double
end module


      SUBROUTINE MB04WR( JOB, TRANS, N, ILO, Q1, LDQ1, Q2, LDQ2, CS,
     $                   TAU, DWORK, LDWORK, INFO )
C
C     SLICOT RELEASE 5.7.
C
C     Copyright (c) 2002-2020 NICONET e.V.
C
C     PURPOSE
C
C     To generate orthogonal symplectic matrices U or V, defined as
C     products of symplectic reflectors and Givens rotations
C
C     U = diag( HU(1),HU(1) )  GU(1)  diag( FU(1),FU(1) )
C         diag( HU(2),HU(2) )  GU(2)  diag( FU(2),FU(2) )
C                              ....
C         diag( HU(n),HU(n) )  GU(n)  diag( FU(n),FU(n) ),
C
C     V = diag( HV(1),HV(1) )       GV(1)   diag( FV(1),FV(1) )
C         diag( HV(2),HV(2) )       GV(2)   diag( FV(2),FV(2) )
C                                   ....
C         diag( HV(n-1),HV(n-1) )  GV(n-1)  diag( FV(n-1),FV(n-1) ),
C
C     as returned by the SLICOT Library routines MB04TS or MB04TB. The
C     matrices U and V are returned in terms of their first N/2 rows:
C
C                 [  U1   U2 ]           [  V1   V2 ]
C             U = [          ],      V = [          ].
C                 [ -U2   U1 ]           [ -V2   V1 ]
C
C     ARGUMENTS
C
C     Input/Output Parameters
C
C     JOB     CHARACTER*1
C             Specifies whether the matrix U or the matrix V is
C             required:
C             = 'U':  generate U;
C             = 'V':  generate V.
C
C     TRANS   CHARACTER*1
C             If  JOB = 'U'  then TRANS must have the same value as
C             the argument TRANA in the previous call of MB04TS or
C             MB04TB.
C             If  JOB = 'V'  then TRANS must have the same value as
C             the argument TRANB in the previous call of MB04TS or
C             MB04TB.
C
C     N       (input) INTEGER
C             The order of the matrices Q1 and Q2. N >= 0.
C
C     ILO     (input) INTEGER
C             ILO must have the same value as in the previous call of
C             MB04TS or MB04TB. U and V are equal to the unit matrix
C             except in the submatrices
C             U([ilo:n n+ilo:2*n], [ilo:n n+ilo:2*n]) and
C             V([ilo+1:n n+ilo+1:2*n], [ilo+1:n n+ilo+1:2*n]),
C             respectively.
C             1 <= ILO <= N, if N > 0; ILO = 1, if N = 0.
C
C     Q1      (input/output) DOUBLE PRECISION array, dimension (LDQ1,N)
C             On entry, if  JOB = 'U'  and  TRANS = 'N'  then the
C             leading N-by-N part of this array must contain in its i-th
C             column the vector which defines the elementary reflector
C             FU(i).
C             If  JOB = 'U'  and  TRANS = 'T'  or  TRANS = 'C' then the
C             leading N-by-N part of this array must contain in its i-th
C             row the vector which defines the elementary reflector
C             FU(i).
C             If  JOB = 'V'  and  TRANS = 'N'  then the leading N-by-N
C             part of this array must contain in its i-th row the vector
C             which defines the elementary reflector FV(i).
C             If  JOB = 'V'  and  TRANS = 'T'  or  TRANS = 'C' then the
C             leading N-by-N part of this array must contain in its i-th
C             column the vector which defines the elementary reflector
C             FV(i).
C             On exit, if  JOB = 'U'  and  TRANS = 'N'  then the leading
C             N-by-N part of this array contains the matrix U1.
C             If  JOB = 'U'  and  TRANS = 'T'  or  TRANS = 'C' then the
C             leading N-by-N part of this array contains the matrix
C             U1**T.
C             If  JOB = 'V'  and  TRANS = 'N'  then the leading N-by-N
C             part of this array contains the matrix V1**T.
C             If  JOB = 'V'  and  TRANS = 'T'  or  TRANS = 'C' then the
C             leading N-by-N part of this array contains the matrix V1.
C
C     LDQ1    INTEGER
C             The leading dimension of the array Q1.  LDQ1 >= MAX(1,N).
C
C     Q2      (input/output) DOUBLE PRECISION array, dimension (LDQ2,N)
C             On entry, if  JOB = 'U'  then the leading N-by-N part of
C             this array must contain in its i-th column the vector
C             which defines the elementary reflector HU(i).
C             If  JOB = 'V'  then the leading N-by-N part of this array
C             must contain in its i-th row the vector which defines the
C             elementary reflector HV(i).
C             On exit, if  JOB = 'U'  then the leading N-by-N part of
C             this array contains the matrix U2.
C             If  JOB = 'V'  then the leading N-by-N part of this array
C             contains the matrix V2**T.
C
C     LDQ2    INTEGER
C             The leading dimension of the array Q2.  LDQ2 >= MAX(1,N).
C
C     CS      (input) DOUBLE PRECISION array, dimension (2N)
C             On entry, if  JOB = 'U'  then the first 2N elements of
C             this array must contain the cosines and sines of the
C             symplectic Givens rotations GU(i).
C             If  JOB = 'V'  then the first 2N-2 elements of this array
C             must contain the cosines and sines of the symplectic
C             Givens rotations GV(i).
C
C     TAU     (input) DOUBLE PRECISION array, dimension (N)
C             On entry, if  JOB = 'U'  then the first N elements of
C             this array must contain the scalar factors of the
C             elementary reflectors FU(i).
C             If  JOB = 'V'  then the first N-1 elements of this array
C             must contain the scalar factors of the elementary
C             reflectors FV(i).
C
C     Workspace
C
C     DWORK   DOUBLE PRECISION array, dimension (LDWORK)
C             On exit, if INFO = 0,  DWORK(1)  returns the optimal
C             value of LDWORK.
C             On exit, if  INFO = -12,  DWORK(1)  returns the minimum
C             value of LDWORK.
C
C     LDWORK  INTEGER
C             The length of the array DWORK.
C             LDWORK >= MAX(1,2*(N-ILO+1)).
C
C             If LDWORK = -1, then a workspace query is assumed;
C             the routine only calculates the optimal size of the
C             DWORK array, returns this value as the first entry of
C             the DWORK array, and no error message related to LDWORK
C             is issued by XERBLA.
C
C     Error Indicator
C
C     INFO    INTEGER
C             = 0:  successful exit;
C             < 0:  if INFO = -i, the i-th argument had an illegal
C                   value.
C
C     REFERENCES
C
C     [1] Benner, P., Mehrmann, V., and Xu, H.
C         A numerically stable, structure preserving method for
C         computing the eigenvalues of real Hamiltonian or symplectic
C         pencils. Numer. Math., Vol 78 (3), pp. 329-358, 1998.
C
C     [2] Kressner, D.
C         Block algorithms for orthogonal symplectic factorizations.
C         BIT, 43 (4), pp. 775-790, 2003.
C
C     CONTRIBUTORS
C
C     D. Kressner, Technical Univ. Berlin, Germany, and
C     P. Benner, Technical Univ. Chemnitz, Germany, December 2003.
C
C     REVISIONS
C
C     V. Sima, June 2008 (SLICOT version of the HAPACK routine DOSGSU).
C     V. Sima, Aug. 2011.
C
C     KEYWORDS
C
C     Elementary matrix operations, Hamiltonian matrix, orthogonal
C     symplectic matrix.
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION  ZERO, ONE
      PARAMETER         ( ZERO = 0.0D+0, ONE = 1.0D+0 )
C     .. Scalar Arguments ..
      CHARACTER         JOB, TRANS
      INTEGER           ILO, INFO, LDQ1, LDQ2, LDWORK, N
C     .. Array Arguments ..
      DOUBLE PRECISION  CS(*), DWORK(*), Q1(LDQ1,*), Q2(LDQ2,*), TAU(*)
C     .. Local Scalars ..
      LOGICAL           COMPU, LQUERY, LTRAN
      INTEGER           I, IERR, J, MINWRK, NH, WRKOPT
C     .. External Functions ..
      LOGICAL           LSAME
      EXTERNAL          LSAME
C     .. External Subroutines ..
      EXTERNAL          DLASET, MB04WD, XERBLA
C     .. Intrinsic Functions ..
      INTRINSIC         DBLE, INT, MAX
C
C     .. Executable Statements ..
C
C     Check the scalar input parameters.
C
      INFO  = 0
      LTRAN = LSAME( TRANS, 'T' ) .OR. LSAME( TRANS, 'C' )
      COMPU = LSAME( JOB, 'U' )
      IF ( .NOT.COMPU .AND. .NOT.LSAME( JOB, 'V' ) ) THEN
         INFO = -1
      ELSE IF ( .NOT.LTRAN .AND. .NOT.LSAME( TRANS, 'N' ) ) THEN
         INFO = -2
      ELSE IF ( N.LT.0 ) THEN
         INFO = -3
      ELSE IF ( ILO.LT.1 .OR. ILO.GT.MAX( 1, N ) ) THEN
         INFO = -4
      ELSE IF ( LDQ1.LT.MAX( 1, N ) ) THEN
         INFO = -6
      ELSE IF ( LDQ2.LT.MAX( 1, N ) ) THEN
         INFO = -8
      ELSE
         LQUERY = LDWORK.EQ.-1
         IF ( COMPU ) THEN
            NH = N - ILO + 1
         ELSE
            NH = N - ILO
         END IF
         MINWRK = MAX( 1, 2*NH )
         IF ( LQUERY ) THEN
            IF ( NH.LT.0 ) THEN
               WRKOPT = ONE
            ELSE
               CALL MB04WD( TRANS, TRANS, NH, NH, NH, Q1, LDQ1, Q2,
     $                      LDQ2, CS, TAU, DWORK, -1, IERR )
               WRKOPT = MAX( MINWRK, INT( DWORK(1) ) )
            END IF
            DWORK(1) = DBLE( WRKOPT )
            RETURN
         ELSE IF ( LDWORK.LT.MINWRK ) THEN
            DWORK(1) = DBLE( MINWRK )
            INFO = -12
         END IF
      END IF
C
C     Return if there were illegal values.
C
      IF ( INFO.NE.0 ) THEN
         CALL XERBLA( 'MB04WR', -INFO )
         RETURN
      END IF
C
C     Quick return if possible.
C
      IF( N.EQ.0 ) THEN
         DWORK(1) = ONE
         RETURN
      END IF
C
      IF ( COMPU ) THEN
         CALL DLASET( 'All', N, ILO-1, ZERO, ONE, Q1, LDQ1 )
         CALL DLASET( 'All', ILO-1, N-ILO+1, ZERO, ZERO, Q1(1,ILO),
     $                LDQ1 )
         CALL DLASET( 'All', N, ILO-1, ZERO, ZERO, Q2, LDQ2 )
         CALL DLASET( 'All', ILO-1, N-ILO+1, ZERO, ZERO, Q2(1,ILO),
     $                LDQ2 )
      END IF
      IF ( COMPU .AND. .NOT.LTRAN ) THEN
C
C        Generate U1 and U2.
C
         CALL MB04WD( 'No Transpose', 'No Transpose', NH, NH, NH,
     $                Q1(ILO,ILO), LDQ1, Q2(ILO,ILO), LDQ2, CS(ILO),
     $                TAU(ILO), DWORK, LDWORK, IERR )
      ELSE IF ( COMPU.AND.LTRAN ) THEN
C
C        Generate U1**T and U2.
C
         CALL MB04WD( 'Transpose', 'No Transpose', NH, NH, NH,
     $                Q1(ILO,ILO), LDQ1, Q2(ILO,ILO), LDQ2, CS(ILO),
     $                TAU(ILO), DWORK, LDWORK, IERR )
      ELSE IF ( .NOT.COMPU .AND. .NOT.LTRAN ) THEN
C
C        Generate V1**T and V2**T.
C
C        Shift the vectors which define the elementary reflectors one
C        column to the bottom, and set the first ilo rows and
C        columns to those of the unit matrix.
C
         DO 40  I = 1, N
            DO 10  J = N, MAX( I, ILO )+1, -1
               Q1(J,I) = ZERO
   10       CONTINUE
            DO 20  J = MAX( I, ILO ), ILO+1, -1
               Q1(J,I) = Q1(J-1,I)
   20       CONTINUE
            DO 30  J = ILO, 1, -1
               Q1(J,I) = ZERO
   30       CONTINUE
            IF ( I.LE.ILO )  Q1(I,I) = ONE
   40    CONTINUE
         DO 80  I = 1, N
            DO 50  J = N, MAX( I, ILO )+1, -1
               Q2(J,I) = ZERO
   50       CONTINUE
            DO 60  J = MAX( I, ILO ), ILO+1, -1
               Q2(J,I) = Q2(J-1,I)
   60       CONTINUE
            DO 70  J = ILO, 1, -1
               Q2(J,I) = ZERO
   70       CONTINUE
   80    CONTINUE
C
         IF ( NH.GT.0 ) THEN
            CALL MB04WD( 'Transpose', 'Transpose', NH, NH, NH,
     $                   Q1(ILO+1,ILO+1), LDQ1, Q2(ILO+1,ILO+1), LDQ2,
     $                   CS(ILO), TAU(ILO), DWORK, LDWORK, IERR )
         ELSE
            DWORK(1) = ONE
         END IF
      ELSE IF ( .NOT.COMPU .AND. LTRAN ) THEN
C
C        Generate V1 and V2**T.
C
C        Shift the vectors which define the elementary reflectors one
C        column to the right/bottom, and set the first ilo rows and
C        columns to those of the unit matrix.
C
         DO 110  J = N, ILO + 1, -1
            DO 90  I = 1, J-1
               Q1(I,J) = ZERO
   90       CONTINUE
            DO 100  I = J+1, N
               Q1(I,J) = Q1(I,J-1)
  100       CONTINUE
  110    CONTINUE
         CALL DLASET( 'All', N, ILO, ZERO, ONE, Q1, LDQ1 )
         DO 150 I = 1, N
            DO 120  J = N, MAX( I, ILO )+1, -1
               Q2(J,I) = ZERO
  120       CONTINUE
            DO 130  J = MAX( I, ILO ), ILO+1, -1
               Q2(J,I) = Q2(J-1,I)
  130       CONTINUE
            DO 140  J = ILO, 1, -1
               Q2(J,I) = ZERO
  140       CONTINUE
  150    CONTINUE
C
         IF ( NH.GT.0 ) THEN
            CALL MB04WD( 'No Transpose', 'Transpose', NH, NH, NH,
     $                   Q1(ILO+1,ILO+1), LDQ1, Q2(ILO+1,ILO+1), LDQ2,
     $                   CS(ILO), TAU(ILO), DWORK, LDWORK, IERR )
         ELSE
            DWORK(1) = ONE
         END IF
      END IF
      RETURN
C *** Last line of MB04WR ***
      END


SUBROUTINE set_stf(station)
!----------------------------------------------------------------------------
!
! Description:
!
!   Prepares the source-time-function (or more precisely, the moment-rate
!   function) to be used during convolution. The following functions are
!   available: box-car, triangular, Yoffe, Liu, Dreger and user-defined.
!   The code calculates amplitude and rise time of the source-time-function
!   as follows:
!   a) Computation of rupture area (Ar) from the relation of moment magnitude
!      (Mw) vs rupture area --> internal subroutine CalcAfrM
!   b) Computation of seismic moment (Mo) from the relation of Mo vs Mw -->
!      internal subroutine fMw2MoN
!   c) Once Mo and Ar are estimated, it calculates slip (D) from the relation
!      Mo=mu*D*Ar
!   d) Computation of Rise-Time (Tr) from the relation of Tr vs Mo -->
!      internal subroutine CalcTrfromM
!   e) Computation of source-time-function amplitude (Amp), once rise-time
!      and slip have been estimated
!
! Dependencies:
!
!   Subroutines CalcAfrM, fMw2MoN, CalcTrfromM, stf_box, stf_tri, stf_yof,
!   stf_dreg, stf_liu.
!
! References:
!
!   Numerical Recipes
!
! Notes:
!
!   This section is the same for both point-sources and extended-sources.
!
! Authors: W. Imperatori, B. Mena
!
! Modified: January 2009 (v1.3)
!
! Updated: December 2012 (v1.4.1)
!   change taper_len.
!
! Updated: March 2013 (v1.4.2)
!   Add srf_read subroutine to read srf to obtain subfault informations
!   used in acc_spec in composition.f90.
!
!   Add a new source time function in stf_new subroutine.
!
! Updated: October 2013 (v1.5.2)
!   Add tmp_lf_len and tmp_npts for STF, for output decimation.
!
! Updated: April 2014 (v1.5.5)
!    tmp_npts and tmp_lf_len are in the module tmp_para.
!
! Updated: September 2014 (v1.5.5.1)
!   Change SUBROUTINE set_stf to SUBROUTINE set_stf(station)
!
! Updated: December 2016 (v1.6.2)
!   Change call srf_read for only station = 1.
!
! Updated: February 2019 (v2.0)
!   Change call srf_read only if (station = 1) and (ext_flag = 1).
!   Add targ_fr, alt, tinit for point source (ext_flag = 0) without reading SRF.
!
use constants; use def_kind; use earthquake; use flags
use stf_data; use scattering, only: npts,fmax
use waveform; use fault_area;
use matching, only: targ_fr
use vel_model, only: alt,tinit

implicit none

integer(kind=i_single),intent(in)           :: station

! rigidity, average slip, stf's amplitude, time-step
real(kind=r_single)                         :: mu,D,Amp,dt
! indexes, taper length
integer(kind=i_single)                      :: i,j,taper_len
! dummy array
real(kind=r_single),allocatable,dimension(:):: h
! test dummy array
real(kind=r_single),allocatable,dimension(:):: stf_dreg_t,stf_liu_t
! rupture area, seismic moment and rise-time (for internal subroutines)
real(kind=r_single)                         :: Mo,Tr

! add
!real(kind=r_single),parameter               :: tmp_lf_len = 102.3750
!integer(kind=i_single),parameter            :: tmp_npts =  32768
!----------------------------------------------------------------------------

! set targ_fr, alt and tinit for point source scenario
if (ext_flag == 0) then
   targ_fr = 2
   alt = 1
   tinit = 0
endif

! read srf file
if (station == 1 .and. ext_flag == 1) call srf_read

! returns Ar (rupture Area [km^2]) from Mw and mechanism
call CalcAfrM

! returns Mo [Nm] (Seismic Moment) from Mw (moment magnitude)
call fMw2MoN

! Tr: rise time [sec] from Mo
call CalcTrfromM

! mu: rigidity. Split in two, otherwise can cause run-time error with some compilers
mu=3.3*(10**5); mu=mu*(10**5)

! average D: slip [m]
D=Mo/(mu*Ar*(10**6))

! calculating amplitude of velocity source-time-function (moment rate function) of
! box-car type.
! If triangular source-time-function is chosen, amplitude correction is made inside
! the triangular-function subroutine, so take the same amplitude as for box-car type.
! Amp [m/sec] (i.e. velocity)
Amp=D/Tr

! now create the moment-rate function; for simplicity we fix it here to be 15 sec. long

! total length of source time function (total) = 15 sec (may change for user-defined stf)
total = 15.0
! stf starts at 0 seconds (ton = 0.0)
ton = 0.0

! time-step for STF, assuming maximum frequency for coda waves as Nyquist frequency
!dt = 1 / (2 * fmax)   !it's the same as for coda waves time-series
dt = lf_len/(v_npts-1)

! number of points of the stf.
! NOTE: it can be changed if user-defined stf is selected
npts_stf = nint(total/dt) + 1     ! +1 is due to include 0

! read srf file
!call srf_read ! move to the top, v162

! allocate arrays for stf amplitudes and its time vector
if(.not.allocated(t_stf)) allocate(t_stf(npts_stf))
if(.not.allocated(stf)) allocate(stf(npts_stf))

! compute selected source-time-function
select case (trim(stf_name))
case('box')
   call stf_box           !BOXCAR
case('tri')
   call stf_tri           !TRIANGULAR
case('yof')
   call stf_yof           !YOFFE
case('dreg')
   call stf_dreg          !DREGER
case('liu')
   call stf_liu           !LIU
case('new')
   call stf_new           !new stf
!case default
!   call MomRateFunct(dt)  !USER-DEFINED
end select

! scale obtained source-time-function by rupture area (only for point-source case)
if(ext_flag == 0) stf=stf*Ar

! create stf's time-vector

t_stf(1)=0.
do i=1,(npts_stf-1)
   t_stf(i+1)=t_stf(i)+dt
enddo

! setting up the taper (Hanning window): only the end (last 20%) of convolved time series will
! be tapered
!taper_len=nint(npts*0.5)

! setting up the taper (Hanning window): only the end (10 sec) of convolved time series will
! be tapered
taper_len=nint(10.0/dt)

! allocate local array for building taper
if(.not.allocated(han_win)) allocate(han_win(taper_len))

! equation of Hanning window: h(i)=0.5*(1-cos(2*pi*i)/N) ---> see Numerical Recipes, page: 547
! taking only the second (decaying) half
do i=taper_len,1,-1
   han_win(taper_len-i+1) = 0.5 * (1 - cos(2 * pi * (i-1) / (2*taper_len)) )
enddo

! deallocate memory
if (allocated(h)) deallocate(h)

!<>--<>--<>--<>--<>--<>--<>--<>--<>--<>--<>--<>--<>--<>--<>--<>--<>--<>--<>--<>--<>--<>--<>--<>--<>-

CONTAINS

   SUBROUTINE CalcAfrM
   !-----------------------------------------------------------------
   !
   ! Description:
   !
   !   Calculates Rupture Area Ar given the moment magnitude Mw
   !   from empirical relations of Wells & Coppersmith, 1994.
   !   Resultant Rupture Area (Ar) is [km^2]
   !
   ! Dependencies:
   !
   !   None
   !
   ! Notes:
   !
   !   Four mechanism are accepted: strike-slip (ss), reverse-slip
   !   (rs), normal-slip (ns), other (al)
   !
   ! References:
   !
   !
   !
   ! Authors: W. Imperatori, B. Mena
   !
   ! Modified: January 2009 (v1.3)
   !

use fault_area

   implicit none

   ! local variables
   real(kind=r_single):: a,b

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

   ! define parameters after mechanism type
   select case(trim(mech))
   case('ss')
      a=-3.42
      b=0.90
   case('rs')
      a=-3.99
      b=0.98
   case('ns')
      a=-2.87
      b=0.82
   case('al')
      a=-3.49
      b=0.91
   end select

   Ar=10**(a+b*Mw)    !compute rupture area

   END SUBROUTINE CalcAfrM

!<>--<>--<>--<>--<>--<>--<>--<>--<>--<>--<>--<>--<>--<>--<>--<>--<>--<>--<>--<>--<>--<>--<>--<>--<>-

   SUBROUTINE fMw2MoN
   !----------------------------------------------------------------------------
   !
   ! Description:
   !
   !   Calculates the seismic moment Mo [in Nm] for a given moment magnitude Mw.
   !
   ! Dependencies:
   !
   !   None
   !
   ! Reference: Thorne & Lay, page 384
   !
   ! Authors: W. Imperatori, B. Mena
   !
   ! Modified: January 2009 (v1.3)
   !

   implicit none

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

   Mo=10**(1.5*Mw+9.05)

   END SUBROUTINE fMw2MoN

!<>--<>--<>--<>--<>--<>--<>--<>--<>--<>--<>--<>--<>--<>--<>--<>--<>--<>--<>--<>--<>--<>--<>--<>--<>-

   SUBROUTINE CalcTrfromM
   !-----------------------------------------------------------------------
   !
   ! Description:
   !
   !   Calculates Rise-Time [second] given the seismic moment (in [N*m], will
   !   be converted into [dyn*cm]).
   !
   ! Dependencies:
   !
   !   None
   !
   ! References:
   !
   ! Somerville et al., 1999
   !
   ! Authors: W. Imperatori, B. Mena
   !
   ! Modified: January 2009 (v1.3)
   !

   implicit none

   ! dummy (local)
   real(kind=r_single) :: Mo2

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

   ! converting Mo [Nm] to [dyne-cm]; 1Nm = 10^7 dyne-cm
   Mo2=Mo*(10**7)

   ! estimate rise-time
   Tr=2.03*(Mo2**(1.0/3.0))/(10**9)

   END SUBROUTINE CalcTrfromM

!<>--<>--<>--<>--<>--<>--<>--<>--<>--<>--<>--<>--<>--<>--<>--<>--<>--<>--<>--<>--<>--<>--<>--<>--<>-

   SUBROUTINE stf_box
   !----------------------------------------------------------------
   !
   ! Description:
   !
   !   Calculates box-car type source-time-function in time domain,
   !   given amplitude Amp and rise-time Tr.
   !
   ! Dependencies:
   !
   !   None
   !
   ! Authors: W. Imperatori, B. Mena
   !
   ! Modified: January 2009 (v1.3)
   !

   implicit none

   ! index, dummy (locals)
   real(kind=r_single)   :: tof
   integer(kind=i_single):: i

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

   tof=ton+Tr

   do i=1,nint(ton/dt)+1
      stf(i)=0
   enddo

   do i=nint(ton/dt)+2,nint(tof/dt)+1
      stf(i)=Amp
   enddo

   do i=nint(tof/dt)+2,npts_stf
      stf(i)=0
   enddo

   END SUBROUTINE stf_box

!<>--<>--<>--<>--<>--<>--<>--<>--<>--<>--<>--<>--<>--<>--<>--<>--<>--<>--<>--<>--<>--<>--<>--<>--<>-

   SUBROUTINE stf_tri
   !-------------------------------------------------------------------------
   !
   ! Description:
   !
   !   Calculates triangular type source-time function in time domain given
   !   amplitude Amp and rise-time Tr.
   !
   ! Dependencies:
   !
   !   None
   !
   ! Authors: W. Imperatori, B. Mena
   !
   ! Modified: January 2009 (v1.3)
   !

   implicit none

   ! indexes, dummies (locals)
   integer(kind=i_single):: i
   real(kind=r_single)   :: damp,tmid,tof

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

   tof=ton+Tr
   tmid=ton+(Tr/2)
   damp=(Amp*2)/(nint((Tr/2)/dt))

   do i=1,nint(ton/dt)+1
      stf(i)=0
   enddo

   stf(nint(ton/dt)+2)=damp

   do i=nint(ton/dt)+2,nint(tmid/dt)
      stf(i+1)=stf(i)+damp
   enddo

   do i=nint(tmid/dt)+1,nint(tof/dt)
      stf(i+1)=stf(i)-damp
   enddo

   do i=nint(tof/dt)+2,npts_stf
      stf(i)=0
   enddo

   END SUBROUTINE stf_tri

!<>--<>--<>--<>--<>--<>--<>--<>--<>--<>--<>--<>--<>--<>--<>--<>--<>--<>--<>--<>--<>--<>--<>--<>--<>-

   SUBROUTINE stf_yof
   !--------------------------------------------------------------
   !
   ! Description:
   !
   !   This subroutine computes Regularized Yoffe function.
   !
   ! Dependencies:
   !
   !   None
   !
   ! References:
   !
   !   Adapted from Tinti et al., 2005
   !
   ! Authors: W. Imperatori, B. Mena
   !
   ! Modified: January 2009 (v1.3)
   !

   implicit none

   ! indexes, dummies, coefficients (locals)
   integer(kind=i_single)                 :: i,j
   real(kind=r_single)                    :: c2,k,ts
   real(kind=r_single),dimension(npts_stf):: t,c1,c3,c4,c5,c6

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

   ! Rupture time (ton) assumed to be zero
   t(1)=0.
   do i=1,npts_stf-1
      t(i+1)=t(i)+dt
   enddo

   ! compute coefficients
   ts=0.3
   c2=(3.0/8.0)*pi*(Tr**2.0)
   k=2.0/(pi*Tr*ts**2.0)

   c1=((0.5*t+0.25*Tr)*sqrt(t*(Tr-t))+(t*Tr-(Tr**2.0))*asin(sqrt(t/Tr))     &
      -0.75*(Tr**2.0)*atan(sqrt((Tr-t)/t)))

   c3=((ts-t-0.5*Tr)*sqrt((t-ts)*(Tr-t+ts))+Tr*(2.0*Tr-2.0*t+2.0*ts)        &
      *(asin(sqrt((t-ts)/Tr)))+(3.0/2.0)*Tr**2.0*(atan(sqrt((Tr-t+ts)       &
      /(t-ts)))))

   c4=((-1.0*ts+0.5*t+0.25*Tr)*sqrt((t-2.0*ts)*(Tr-t+2.0*ts))+Tr*((-1.0*Tr) &
      +t-2.0*ts)*asin(sqrt((t-2.0*ts)/Tr))-0.75*Tr**2.0*atan(sqrt((Tr-t     &
      +2.0*ts)/(t-2.0*ts))))

   c5=((pi/2.0)*Tr*(t-Tr))

   c6=((pi/2.0)*Tr*(2.0*ts-t+Tr))

   ! here below create Yoffe's stf
   if (Tr .GT. ts*2.0) then
      do j=1,npts_stf
         if (t(j) .LE. 0.0) then
            stf(j)=0.0
         else if (0.0 .LT. t(j) .AND. t(j) .LT. ts) then
            stf(j)=D*k*(c1(j)+c2)
            else if (ts .LE. t(j) .AND. t(j) .LT. 2.0*ts) then
                stf(j)=D*k*(c1(j)-c2+c3(j))
            else if (2.0*ts .LE. t(j) .AND. t(j) .LT. Tr) then
                stf(j)=D*k*(c1(j)+c3(j)+c4(j))
            else if (Tr .LE. t(j) .AND. t(j) .LT. Tr+ts) then
                stf(j)=D*k*(c5(j)+c3(j)+c4(j))
            else if (Tr+ts .LE. t(j) .AND. t(j) .LT. Tr+2.0*ts) then
                stf(j)=D*k*(c4(j)+c6(j))
            else if (Tr+2.0*ts .LE. t(j)) then
                stf(j)=0.0
         end if
      enddo
   endif

   if ((ts .LT. Tr) .AND. (Tr .LT. 2.0*ts)) then
      do j=1,npts_stf
         if (t(j) .LE. 0.0) then
                stf(j)=0.0
             else if (0.0 .LT. t(j) .AND. t(j) .LT. ts) then
                stf(j)=D*k*(c1(j)+c2)
             else if (ts .LE. t(j) .AND. t(j) .LT. Tr) then
                stf(j)=D*k*(c1(j)-c2+c3(j))
             else if (Tr .LE. t(j) .AND. t(j) .LT. 2.0*ts) then
                stf(j)=D*k*(c5(j)+c3(j)-c2)
             else if (2.0*ts .LE. t(j) .AND. t(j) .LT. Tr*ts) then
                stf(j)=D*k*(c5(j)+c3(j)+c4(j))
             else if (Tr*ts .LE. t(j) .AND. t(j) .LT. Tr+2.0*ts) then
                stf(j)=D*k*(c4(j)+c6(j))
             else if (Tr+2.0*ts .LE. t(j)) then
                stf(j)=0.0
         endif
      enddo
   endif

   END SUBROUTINE stf_yof

!<>--<>--<>--<>--<>--<>--<>--<>--<>--<>--<>--<>--<>--<>--<>--<>--<>--<>--<>--<>--<>--<>--<>--<>--<>-

   SUBROUTINE stf_dreg
   !-------------------------------------------------------------------------
   !
   ! Description:
   !
   !   Computes Dreger et al., 2007 (SSA poster) type source-time-function.
   !   Banu Mena, APRIL 2008, SDSU. Healing front + white noise -> Sept.08.
   !
   ! Dependencies:
   !
   !   None
   !
   ! Authors: W. Imperatori, B. Mena
   !
   ! Modified: January 2009 (v1.3)
   !

   implicit none

   ! dummies (locals)
   real(kind=r_single),dimension(npts_stf)        :: t,s,ds,randm
   real(kind=r_single),allocatable,dimension(:)   :: heal
   real(kind=r_single),parameter                  :: ksi=0.1
   real(kind=r_single)                            :: max_ss,dss,t1_heal,t2_heal,max_ran
   integer(kind=i_single)                         :: i,n_t1,n_t2
   integer(kind=i_single)                         :: seed,seed_size
   integer(kind=i_single),allocatable,dimension(:):: tmp_seed

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

   Tr=Tr*0.3        ! reviewed

   t(1)=0.0
   do i=1,npts_stf-1
      t(i+1)=t(i)+dt
   enddo

   s=(t**ksi)*exp(-t/Tr)

   !linear healing front between t1_heal and t2_heal
   t1_heal=3.0; t2_heal=3.2;

   n_t1=nint(t1_heal/dt)+1; n_t2=nint(t2_heal/dt)+1

   dss=(s(n_t1))/(n_t2-n_t1)

   if(.not.allocated(heal)) allocate(heal(n_t2-n_t1))

   !linear healing function
   do i=1,(n_t2-n_t1)
      heal(i)=s(n_t1)-(dss*i)
   enddo

   !function until healing
   do i=1,n_t1
      stf(i)=s(i)
   enddo

   !function during healing
   do i=1,(n_t2-n_t1)
      stf(n_t1+i)=heal(i)
   enddo

   !function after healing
   do i=1,(npts_stf-n_t2)
      stf(i+n_t2)=0.0
   enddo

   !adding white noise
   seed=321

   ! initialize the generator with a specified seed number
   call random_seed(size=seed_size)
   if (.not.allocated(tmp_seed)) allocate(tmp_seed(seed_size))
   tmp_seed=seed
   call random_seed(put=tmp_seed)

   ! generate random numbers
   call random_number(randm)

   max_ran=maxval(randm,dim=1)

   stf=stf+(randm/max_ran)*0.05

   ds(1)=stf(1)*dt
   do i=2,npts_stf
      ds(i)=ds(i-1)+(stf(i-1)+stf(i))/2.*dt
   enddo

   max_ss=maxval(ds,dim=1)

   stf=(D/max_ss)*stf

   ! deallocate memory
   if(allocated(heal)) deallocate(heal)

   END SUBROUTINE stf_dreg

!<>--<>--<>--<>--<>--<>--<>--<>--<>--<>--<>--<>--<>--<>--<>--<>--<>--<>--<>--<>--<>--<>--<>--<>--<>-

   SUBROUTINE stf_liu
   !-------------------------------------------------------------------
   !
   ! Description:
   !
   !   This subroutine computes Liu source-time function.
   !
   ! Dependencies:
   !
   !   None
   !
   ! Notes:
   !
   !   this STF hasn't been widely tested!
   !
   ! Authors: W. Imperatori, B. Mena
   !
   ! Modified: January 2009 (v1.3)
   !

   implicit none

   ! locals
   real(kind=r_single),dimension(npts_stf)        :: t,s,ds,randm
   real(kind=r_single)                            :: t1,t2,cn,max_ss,max_ran
   integer(kind=i_single)                         :: seed,seed_size
   integer(kind=i_single),allocatable,dimension(:):: tmp_seed

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

   t1=0.13*Tr; t2=Tr-t1
   cn=pi/(1.4*pi*t1+1.2*t1+0.3*pi*t2)

   t(1)=0.0
   do i=1,npts_stf-1
      t(i+1)=t(i)+dt
   enddo

   do i=1,npts_stf
      if (0.0 .LE. t(i) .AND. t(i) .LT. t1) then
         s(i)=cn*(0.7-0.7*cos(pi*t(i)/t1)+0.6*sin(0.5*pi*t(i)/t1))
      else if (t1 .LE. t(i) .AND. t(i) .LT. (2.0*t1)) then
         s(i)=cn*(1.0-0.7*cos(pi*t(i)/t1)+0.3*cos(pi*(t(i)-t1)/t2))
      else if ((2.0*t1) .LE. t(i) .AND. t(i) .LT. Tr) then
         s(i)=cn*(0.3+0.3*cos(pi*(t(i)-t1)/t2))
      else if (t(i) .GE. Tr) then
         s(i)=0.0
      end if
   enddo

   seed=123

   ! initialize the generator with a specified seed number
   call random_seed(size=seed_size)
   if (.not.allocated(tmp_seed)) allocate(tmp_seed(seed_size))
   tmp_seed=seed
   call random_seed(put=tmp_seed)

   ! generate random numbers
   call random_number(randm)

   max_ran=maxval(randm,dim=1)

   stf=s+(randm/max_ran)*0.05

   ds(1)=s(1)*dt

   do i=2,npts_stf
      ds(i)=ds(i-1)+(stf(i-1)+stf(i))/2.*dt
   enddo

   max_ss=maxval(ds,dim=1)

   stf=(D/max_ss)*stf

   END SUBROUTINE stf_liu

!<>--<>--<>--<>--<>--<>--<>--<>--<>--<>--<>--<>--<>--<>--<>--<>--<>--<>--<>--<>--<>--<>--<>--<>--<>-

   SUBROUTINE stf_new
   !-------------------------------------------------------------------
   !
   ! Description:
   !
   !   This subroutine is for a new stf
   !
   ! Dependencies:
   !
   !   None
   !
   ! Notes:
   !
   !
   !
   ! Authors: K. Olsen
   !
   ! Modified: March 2013 (v1.4.2)
   !
   ! Updated: May 2013 (v1.5.1)
   !   Add Tr_sca calculation
   !
   ! Updated: May 2013 (v1.5.2)
   !   Change Tr_sca calculation.
   !   Do not use Tr_sca from scattering.dat, just change the name to Tr_factor.
   !
   ! Updated: November 2013 (v1.5.3)
   !   Change Tr_factor calculation, depending on magnitude and dip.
   !
   ! Updated: September 2014 (v1.5.5.1)
   !   Add Tr_fac calculation for CENA events.
   !
   ! Updated: October 2014 (v1.5.5.1)
   !   Change Tr_fac calculation.
   !
   ! Updated: February 2015 (v1.5.5.3)
   !   Change Tr_fac calculation.
   !   Correct bc calculation for CENA events.
   !   Add tapering on stf.
   !
   ! Updated: May 2015 (v1.5.5.4)
   !   The update is applied for NGA-west2, only WNA and Japanese events,
   !   not for NGA-west1.
   !   Change alt and Tr_fac calculations for Tr.
   !   Add n and n1 parameters for stf computation.
   !
   ! Updated: June 2015 (v1.6)
   !   Merge NGA-west1 and NGA-west2 (v1.5.5.3 and v1.5.5.4).
   !   Move alt computation into srf_read subroutine.
   !
   ! Updated: February 2019 (v2.0)
   !   Add tapering length check if shorter than npts_stf.
   !
   use vel_model, only: dip, alt
   use source_receiver, only: sr_rrup
   use flags, only: gs_flag, ngaw_flag

   implicit none

   ! locals
   real(kind=r_single),dimension(npts_stf)        :: t
   real(kind=r_single),dimension(6)               :: P
   real(kind=r_single)                            :: t1
   real(kind=r_single)                            :: Tr_fac
   real(kind=r_single)                            :: bc,rc
   real(kind=r_single)                            :: n, n1
   real(kind=r_single)                            :: distfac
   real(kind=r_single)                            :: mindist

   integer(kind=i_single)                         :: taper_sec
   integer(kind=i_single)                         :: taper_len
   real(kind=r_single),allocatable,dimension(:)   :: taper
   !-------------------------------------------------------------------

   ! NGA-west1 western NA and Japan
   if (ngaw_flag == 1) then
      if (gs_flag == 1 .or. gs_flag == 3) then
         rc=0.141-0.090*atan(Mw*1.60-9.55) ! change (02/11/2014)
         Tr_fac=rc*alt
         n=2.0
         n1=0.5
         !print*,'NGAW1 WNA-JPN: rc,dip,alt=',rc,dip,alt
      endif
   endif

   ! NGA-west2 western NA
   if (ngaw_flag == 2 .and. gs_flag == 1) then
      ! Distance dependence for Mw<6.2
      if (Mw < 6.2) then
         distfac=0.1
         mindist=40 ! [km]
         rc=( 0.1449-0.08715*atan(Mw*1.685- 9.45) )*alt
         bc=( 0.1226-0.05900*atan(Mw*1.750- 9.85) )*alt
         if (sr_rrup(station) < mindist) then
            Tr_fac=rc
         elseif (mindist<=sr_rrup(station).and.sr_rrup(station)<50.) then
            Tr_fac=rc + (sr_rrup(station)-mindist)*(bc-rc)*distfac
         elseif (sr_rrup(station) >= 50.) then
            Tr_fac=bc
         endif
      ! No distance dependence for M>=6.2
      elseif (Mw >= 6.2 .and. Mw < 7.5) then ! change (06/03/2015)
         Tr_fac=( 0.1449-0.08715*atan(Mw*1.685- 9.45) )*alt
      elseif (Mw >= 7.5) then
         Tr_fac=( 0.141-0.090*atan(Mw*1.60-9.55) )*alt
      endif

      ! NGA-west2 Rule for n and n1 (04/27/2015)
      if (Mw < 6.2) then
         n=2.75
         n1=0.6
      elseif (Mw >= 6.2 .and. Mw < 6.6) then
         n=-1.875*Mw+14.375
         n1=-0.25*Mw+2.15
      elseif (Mw >= 6.6) then
         n=2.0
         n1=0.5
      endif
      !print*,'NGAW2 WNA: dip, alt, dist= ',dip,alt,sr_rrup(station)
   endif

   ! NGA-west2 Japan (04/27/2015)
   if (ngaw_flag == 2 .and. gs_flag == 3) then
      rc=0.141-0.090*atan(Mw*1.60-9.55)
      Tr_fac=rc*alt
      n=2.75
      n1=0.5
      !print*,'Japanese-NGA-west2: Tr_fac*alt,n,n1= ',Tr_fac,n,n1
   endif

   ! Common NGA-west1 and NGA-west2 CENA
   if (gs_flag == 2) then ! add(09/26/2014)
      ! change rc computation (02/06/2015)
      if (Mw <= 5.95) then
         rc=( 0.1484-0.085*atan(Mw*1.40-7.250) )*alt
      elseif (Mw > 5.95 .and. Mw <= 7.5) then
         rc=( 0.2061-0.155*atan(Mw*1.40-7.250) )*alt
      elseif (Mw > 7.5) then
         rc=( 0.0870-0.060*atan(Mw*1.45-7.250) )*alt
      endif
      bc=( 0.141-0.090*atan(Mw*1.60-9.55) )*alt ! corrected bc (02/13/2015)

      ! change (10/14/2014)
      if (sr_rrup(station) <= 100.0) then
         Tr_fac=rc
      elseif (sr_rrup(station)>100. .and. sr_rrup(station)<=120.) then
         Tr_fac=rc+(bc-rc)*(sr_rrup(station)-100.)*0.05
      elseif (sr_rrup(station) > 120.) then
         Tr_fac=bc
      endif
      n=2.0
      n1=0.5
      !print*,'CENA: dip, alt, dist= ',dip,alt,sr_rrup(station)
   endif

   t(1)=0.0
   do i=1,npts_stf-1
      t(i+1)=t(i)+dt
   enddo

   t1=Tr_fac*Tr

   ! stf=(t**0.5) / (1 + (t/(t1))**2.)
   stf=(t**n1) / (1 + (t/(t1))**n) ! change to use n and n1 (04/27/2015)

   ! Add tapering on stf (02/15/2015)
   ! compute tapering length as a function of magnitude (Tr)
   taper_sec = nint(Tr/dt)
   taper_len = nint(1/dt)

   if (taper_sec+taper_len+1 < npts_stf) then ! tapering length check
      ! compute taper
      if (.not.allocated(taper)) allocate(taper(taper_len))
      do i=1,taper_len
         taper(i) = 0.5 * (1 + (cos(pi*i/taper_len)) )
      enddo

      ! apply tapering from Tr to Tr+1sec
      stf(taper_sec+1 : taper_sec+taper_len)=                                &
          stf(taper_sec+1 : taper_sec+taper_len) * taper

      ! zeroing later part
      stf(taper_sec+taper_len+1:npts_stf) = 0

      if (allocated(taper)) deallocate(taper)
   endif

   END SUBROUTINE stf_new

END SUBROUTINE set_stf

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

SUBROUTINE MomRateFunct(dtr)
!--------------------------------------------------------------------------------
!
! Description:
!
!   Reads a user-defines moment-rate function in the format of Rob Graves.
!   The resulting stf is resampled in stf_npts (i.e. len=15 sec, npts=stf_npts
!   defined in the calling subroutine)
!
! Dependencies:
!
!   Subroutines inac, spline_interp
!
! WARNING:
!
!   This subroutine has to be still verified!
!
! Authors: R. Graves, W. Imperatori
!
! Modified: January 2009 (v1.3)
!

use interfaces, only: spline_interp; use stf_data

implicit none

! indexes, dummies (locals)
real(kind=r_single),intent(in)                 :: dtr
real(kind=r_single)                            :: r_dum,dtt,max_ton,t1,t2,sum_sdd
integer(kind=i_single)                         :: i_dum,Npts,nt_loc,NT,Tmax,Ntm,ind,i
integer(kind=i_single)                         :: pp,nn,npo,j,indic
character(len=80)                              :: s_dum
real(kind=r_single),allocatable,dimension(:)   :: dt,sv,sd,max_sd,tony,svp,ar
real(kind=r_single),allocatable,dimension(:)   :: mtime,sdd,mom,svf,svf_new,z
integer(kind=i_single),allocatable,dimension(:):: b,Np
!-------------------------------------------------------------------------------

!open file with stf and read values
open(1,file=trim(stf_name),status='old')
read(1,*); read(1,*); read(1,*); read(1,*)
read(1,*) s_dum,Npts

if(.not.allocated(dt)) allocate(dt(Npts),tony(Npts),max_sd(Npts),ar(Npts))

!loop over stf' # of points
do i = 1, Npts
   read(1,*) r_dum,r_dum,r_dum,i_dum,i_dum,ar(i),tony(i),dt(i)
   read(1,*) i_dum,r_dum,nt_loc,r_dum,i_dum,r_dum,i_dum

   if(.not.allocated(sv)) allocate(sv(nt_loc),sd(nt_loc))

   if (nt_loc /= 0) then
      read(1,*) (sv(j), j=1,nt_loc)
      call inac   !computes displacement
      max_sd(i)=maxval(sd)
   endif

   if(allocated(sv)) deallocate(sv,sd)

enddo

close(1)

! Number of samples in local slip function
Nt=100
dtt=0.1

max_ton=maxval(tony)

Tmax=nint(max_ton+(Nt+1)*dt(1))
Ntm=nint(Tmax/dtt)

if(.not.allocated(mtime)) allocate(mtime(Ntm),Np(Ntm),svp(Ntm),mom(Ntm),svf(Ntm))
if(.not.allocated(b)) allocate(b(Npts),sdd(Npts))

mtime(1)=0.0

!new time vector
do i=1, Ntm-1
   mtime(i+1)=mtime(i)+dtt
enddo

Np(1)=0

do pp=2,Ntm
   t1=mtime(pp-1)
   t2=mtime(pp)
   ind=0

   do i=1,Npts
      if (tony(i) .ge. t1 .and. tony(i) .lt. t2) then
         ind=ind+1
         b(ind)=i
      endif
   enddo

   Np(pp)=ind

   if (Np(pp) .eq. 0) then

      svf(pp)=0.0
      mom(pp)=0.0

   else
      do j=1,ind
         indic=b(j)
         sdd(j)=max_sd(indic)
      enddo

      sum_sdd=sum(sdd)
      svf(1)=0.0
      mom(1)=0.0
      svf(pp)=sum_sdd/Np(pp)

!!	mom(pp)=3.3*1e10*sum_sdd*(1/dtt)*1e-2*ar(1)*1e-4
!! ----------------------------------------------------------
!!  the scaling below, w/o rigidity and with 1e-12 simply
!!  creates mom with about the same amplitudes as svf;
!!  since the spectral amplitudes will be scaled later anyway
!!  this does not make any difference for the final results
!!  to get the correctly scaled moment-rate function, simply
!!  scale by a factor 3.3*1e16
! ----------------------------------------------------------

      mom(pp)=sum_sdd*(1/dtt)*ar(1)*1e-12
   endif

enddo

! Add 1 sec zeros to the beginning of the source time function
!nn=NINT(1/dtt)

!npo=pp+nn-1    !npts with initial zero padding

if(.not.allocated(svf_new)) allocate(svf_new(Ntm))

!do i=1,nn
!   z(i)=0.0
!enddo

!do i=1,nn
!   svf_new(i)=z(i)
!enddo

!do i=nn+1,npo
do i=1,Ntm
!! ------------------------------------------------------------------------
!! two options to construct the "moment-rate function":
!!
!! (1) using svf means the summed slip-velocity at each instant in time
!!     hence resulting in a rather jagged function
!! (2) using mom means in fact moment (i.e. scaled by area and rise time)
!!     hence a somewhat smoother convolution operator
!! ------------------------------------------------------------------------
!!	svf_new(I) = svf(I-nn)
   svf_new(i) = mom(i)
enddo

!mmtime(1)=0.0

!do i=1,npo-1
!   mmtime(i+1)=mmtime(i)+dtt      !old time vector
!enddo

! resampling the moment rate function svf_new
npts_stf=nint((Ntm-1)*dtt/dtr)+1

total=dtr*(npts_stf-1)

if(allocated(t_stf)) deallocate(t_stf,stf)
if(.not.allocated(stf)) allocate(stf(npts_stf),t_stf(npts_stf))

call spline_interp(svf_new,total,npts_stf,Ntm,stf)

!<>--<>--<>--<>--<>--<>--<>--<>--<>--<>--<>--<>--<>--<>--<>--<>--<>--<>--<>--<>--<>--<>--<>--<>--<>-

CONTAINS

   SUBROUTINE inac
   !------------------------------------------------------------
   !
   ! Description:
   !
   !   Inac means 'integration of acceleration', but here is
   !   used with velocity to obtain displacement
   !
   ! Dependencies:
   !
   !   None
   !
   ! Authors: R. Graves, W. Imperatori
   !
   ! Modified: January 2009 (v1.3)
   !

   implicit none

   ! counter (local)
   integer(kind=i_single):: j

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

   sd(1)=sv(1)*dt(i)

   do j=2,nt_loc
      sd(j)=sd(j-1)+(sv(j-1)+sv(j))/2.*dt(i)
   enddo

   END SUBROUTINE inac

END SUBROUTINE MomRateFunct

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

SUBROUTINE srf_read
!--------------------------------------------------------------------------------
!
! Description:
!
!   Reads a srf file
!
! Dependencies:
!
!   none
!
!
! Author: R. Takedatsu
!
! Modified: March 2013 (v1.4.2)
!
! Updated: February 2015 (v1.5.5.3)
!    Add str_fac computation for eastern CA events.
!
! Updated: June 2015 (v1.6)
!    Move alt computation from source.f90 and composition.f90
!    into this subroutine.
!
! Updated: December 2016 (v1.6.2)
!    Add to obtain minimum initiation time in srf file.
!    Set Mw from srf file.
!
! Updated: February 2019 (v2.0)
!    dtop becomes a global-parameter in module_bbtoolbox.f90
!    Avoid negative depth in fz.
!
! Updated: March 2019 (v2.1)
!    Change alt computation for NGA-W2 then WNA events/scenarios,
!    accepting Graves and Pitarka (2015) in equations 3-5.
!
use stf_data
use geometry, only: n_lay; use vel_model
use scattering, only: str_fac
use flags, only: gs_flag, ngaw_flag
use earthquake
use matching, only: targ_fr

implicit none

real(kind=r_single)                            :: r_dum
integer(kind=i_single)                         :: i_dum,nt_loc,i,j
integer(kind=i_single)                         :: nstk,ndip
character(len=80)                              :: s_dum
real(kind=r_single),allocatable,dimension(:)   :: dt,sv,tony
real(kind=r_single)                            :: ave_slip,mw_test
real(kind=r_single)                            :: arcu
!real(kind=r_single)                            :: dtop
real(kind=r_single),allocatable,dimension(:)   :: slip1
real(kind=r_single),allocatable,dimension(:)   :: slip1cu,mu_tmp,mo_tmp
real(kind=r_single)                            :: Ca,Fd,Fr ! from Graves and Pitarka 2015 (eqn. 3-5)
!-------------------------------------------------------------------------------

!open file with srf and read values

open(1,file=trim(srf_name),status='old')
read(1,*) ! read version e.g. 1.0
read(1,*) ! read header block line1 e.g. PLANE 1
read(1,*) ! read header block line2, elon in x,elat in y,nstk,ndp,len,wid
!read(1,*) r_dum,dip,r_dum,r_dum,r_dum ! read header block line3, stk,dip,dtop,shyp,dhyp
read(1,*) r_dum,dip,dtop,r_dum,r_dum ! read header block line3, stk,dip,dtop,shyp,dhyp
read(1,*) s_dum,nsub ! read data block e.g. POINTS, np

!compute str_fac for eastern CA events
if (str_fac == 0.0) then
   str_fac = (225.0 + dtop*16.0)
   str_fac = str_fac * 10**6
endif
if (str_fac < 10**6) then
   print*,'check str_fac should be in bars'
!else
!   print*,'str_fac = ',str_fac
endif

!compute alt
if (ngaw_flag == 1 .or. gs_flag == 2) then
   if (dip <= 55.) then
      alt=0.82
   elseif (dip > 55. .and. dip < 70.) then
      alt=0.16+0.012*dip
   elseif (dip >= 70.) then
      alt=1.
   endif
elseif (ngaw_flag == 2) then
   !! original alt computation for both WNA and Japan
   !if (gs_flag == 1 .or. gs_flag == 3) then
   !   if (dip <= 45.) then
   !      alt=0.785
   !   elseif (dip > 45. .and. dip < 70.) then
   !      alt=0.0086*dip+0.3980
   !   elseif (dip >= 70.) then
   !      alt=1.
   !   endif
   !endif

   ! new alt (alt2015) for only WNA events
   if (gs_flag == 1) then
      Ca=0.1

      ! with the dip (Fd) factor
      if (dip <= 45.0) then
         Fd=1
      elseif (dip > 45.0 .and. dip <= 90.0) then
         Fd=1-(dip-45.0)/45.0
      endif

      ! with the rake (Fr) factor
      if (rake >= 0.0 .and. rake <= 180.0) then
         Fr=1-abs(rake-90.0)/90.0
      else
         Fr=0
      endif

      ! alt
      alt=(1+Fd*Fr*Ca)**(-1)

   ! Japan uses original alt computation
   elseif (gs_flag == 3) then
   !if (gs_flag == 1 .or. gs_flag == 3) then
      if (dip <= 45.) then
         alt=0.785
      elseif (dip > 45. .and. dip < 70.) then
         alt=0.0086*dip+0.3980
      elseif (dip >= 70.) then
         alt=1.
      endif
   endif
endif
print*,'Ca,Fd,Fr,alt for WNA=',Ca,Fd,Fr,alt

! initiation time would be 0 for 1 segment for multi-segments
tinit=0

if(.not.allocated(dt)) then
   allocate(dt(nsub),tony(nsub),slip1(nsub))
endif
if(.not.allocated(fx)) allocate(fx(nsub),fy(nsub),fz(nsub),areas(nsub))

!loop over srf' # of points
do i = 1, nsub
   read(1,*) fx(i),fy(i),fz(i),i_dum,i_dum,areas(i),tony(i),dt(i)
   read(1,*) i_dum,slip1(i),nt_loc,r_dum,i_dum,r_dum,i_dum

   ! avoid negative number of depth
   if(fz(i) < 0.0) fz(i)=0.0

   if(.not.allocated(sv)) allocate(sv(nt_loc))

   if (nt_loc /= 0) then
      read(1,*) (sv(j), j=1,nt_loc)
   endif

   if(allocated(sv)) deallocate(sv)

enddo

sum_area=sum(areas)
ave_slip=sum(slip1)/nsub
tinit=minval(tony) ! add v162
print*,'minimum initiation time = ',tinit

close(1)

! compute mu (shear modulus) and moment
! allocate arrays
if(.not.allocated(mo_tmp)) allocate(mu_tmp(nsub),slip1cu(nsub),mo_tmp(nsub))
if(.not.allocated(mo_ratio)) allocate(mo_ratio(nsub),vscu(nsub),rhcu(nsub))

do i = 1, nsub
   mu_tmp(i)=0.0
   slip1cu(i)=0.0
   mo_tmp(i)=0.0

   do j = 2, n_lay
      if ( (fz(i) >= depth(j-1)) .and. (fz(i) < depth(j)) ) then
         vscu(i)=vs(j-1)*1000      ! km/s -> m/s
         rhcu(i)=rh(j-1)*1000      ! g/cm3 -> kg/m3
      endif

      if (slip1(i) > 0.0) then
         mu_tmp(i)=rhcu(i)*vscu(i)**2        ! [(kg*m2)/(m3*s2) = kg/(m*s2)]
         slip1cu(i)=slip1(i)/100             ! cm -> m
         arcu=areas(i)/10000                 ! cm2 -> m2
         mo_tmp(i)=mu_tmp(i)*slip1cu(i)*arcu ! [kg*m2/s2 = Nm]
      endif
   enddo

enddo

! calculation of Mw from equation of Mo[Nm]=10**(1.5*Mw+9.05)
total_Mo=sum(mo_tmp)
mw_test=(log10(total_Mo) - 9.05)/1.5

print*,'Mw from SOcomp.par= ',Mw
! Mw is from srf file, v162
Mw=mw_test

if (Mw > 5.25) then
   targ_fr = 1.
elseif (4.75 < Mw .and. Mw <= 5.25) then
   targ_fr = 11.5-2*Mw
else
   targ_fr = 2.
endif
print*,'Mw and targ_fr from srf= ',Mw,targ_fr

! for acc_spec
sum_area=sum_area/10000  ! cm2 -> m2
do i = 1, nsub
   if (slip1(i) == 0.0) then
      mo_ratio(i)=0.0
   else
      mo_ratio(i)=slip1cu(i)*mu_tmp(i)*sum_area/total_Mo
   endif
enddo

! change units for acc_spec
sum_area=sum_area*10000. ! m2 -> cm2
vscu=vscu*100.           ! m/s -> c/m
rhcu=rhcu/1000.          ! kg/m3 -> g/cm3

! deallocate memory
if(allocated(mo_tmp)) deallocate(mu_tmp,slip1cu,mo_tmp)

END SUBROUTINE srf_read