! calmat.f for wcalprem.f
!----------------------------------------------------------
subroutine calmatc( nlayer,vnp,vra,con,rpow,w1dn,w2dn,ra,m )
!----------------------------------------------------------
! Computing \int r^rpow con W_p^(w1dn) W_q^(w2dn) dr.
!----------------------------------------------------------
    implicit none
    integer,parameter:: maxrpow= 2
    integer,intent(in):: nlayer,vnp,rpow,w1dn,w2dn
    double precision,intent(in):: vra(vnp),con(vnp),ra(nlayer+1)
    double precision,intent(out)::m(4*nlayer)
    integer:: i,j,k,l,nn,snp
    double precision:: a(2,2),b(2,2),c(5),rh
    ! parameter check
    if (maxrpow<rpow ) stop 'Invalid arguments.(calmatc)'
    ! computing of the matrix elements
    snp = 1
    do i=1,nlayer
        rh = ra(i+1) - ra(i)
        if ( w1dn == 0 ) then
            a(2,1) = -1 / rh
            a(1,1) = ra(i+1) / rh
            a(2,2) = 1 / rh
            a(1,2) = -ra(i) / rh
        else
            if ( w1dn == 1 ) then
                a(2,1) = 0
                a(1,1) = -1 / rh
                a(2,2) = 0
                a(1,2) = 1 / rh
            else
                stop 'Invalid arguments.(calmatc)'
            endif
        endif
        if ( w2dn == 0 ) then
            b(2,1) = -1 / rh
            b(1,1) = ra(i+1) / rh
            b(2,2) = 1 / rh
            b(1,2) = -ra(i) / rh
        else
            if ( w2dn == 1 ) then
                b(2,1) = 0
                b(1,1) = -1 / rh
                b(2,2) = 0
                b(1,2) = 1 / rh
            else
                stop 'Invalid arguments.(calmatc)'
            endif
        endif
        do j=1,2
            do k=1,2
                c(1:5) = 0
                call pmulti( 2,a(1,j),2,b(1,k),3,c )
                do l=3,1,-1
                    c(l+rpow) = c(l)
                    if ( rpow>0 ) c(l)=0
                enddo
                nn = 4 * (i-1) + 2 * (j-1) + k
                call pinteg( snp,5,c,ra(i),ra(i+1),&
                    vnp,vra,con,m(nn) )
            enddo
        enddo
    enddo
    return
end

!----------------------------------------------------------
subroutine pmulti(n,a,m,b,l,c)
!----------------------------------------------------------
! Computing the (l-1) degrees polynomial c(n) which is the product of
! (n-1) degrees polynomial a(n) and (m-1) degrees polynomial b(n).
!----------------------------------------------------------
    implicit none
    integer,intent(in):: n,m,l
    integer:: i,j
    double precision:: a(n),b(m),c(l)

    if (n+m-1/=l) stop 'Invalid arguments.(pmulti)'
    c=0
    do i=1,n
        do j=1,m
            c(i+j-1) = c(i+j-1) + a(i)*b(j)
        enddo
    enddo
    return
end

!----------------------------------------------------------
subroutine pinteg(snp,n,p,from,to,vnp,vra,con,pint)
!----------------------------------------------------------
! Evaluating the integrated value pint from 'from' to 'to' of p(n)*con
! which is the product of (n-1) degrees polynomial 'p(n)' and 'con'.
!----------------------------------------------------------
    implicit none
    integer,parameter::maxn = 5
    integer:: snp,n,vnp
    double precision:: from,to,p(n),vra(vnp),con(vnp),pint
    double precision:: x1,x2,q(2),pq(maxn+1),psint

    if ( maxn<n ) stop 'Degrees of a polynomial is too large.(pinteg)'
    if ( vnp <=snp ) snp = 1

    pint = 0
    x1 = from

    do
        if ( vra(snp)<=x1 .and. vra(snp+1)>x1 ) then
            x2 = dmin1( to, vra(snp+1) )
        else
            snp = snp + 1
            if ( snp==vnp ) snp = 1
            cycle
        endif
        ! evaluating the integrated value
        q(2) = ( con(snp+1)-con(snp) ) / ( vra(snp+1)-vra(snp) )
        q(1) = - q(2) * vra(snp) + con(snp)
        call pmulti( n,p,2,q,n+1,pq )
        call polint( n+1,pq,x1,x2,psint )
        pint = pint + psint

        if ( x2==to ) then
            exit
        else
            x1 = x2
        endif
    enddo
    return
end

!----------------------------------------------------------
subroutine polint( n,p,x1,x2,pint )
!----------------------------------------------------------
! Evaluating the integrated value 'pint' from 'x1' to 'x2'
! of (n-1) degrees polynomial 'p(n)'.
!----------------------------------------------------------
    implicit none
    integer,parameter :: maxn = 6
    integer:: i,j,n
    double precision:: p(*),x1,x2,pint
    double precision:: a(maxn),b(maxn),dx,xx

    if (maxn<n ) stop 'Degree of a polynomial is too large.(polint)'

    a(1) = 1
    b(1) = 1
    if ( 2<=n ) then
        do i=2,n
            a(i) = a(i-1) * x1
            b(i) = b(i-1) * x2
        enddo
    endif
    dx = x2 - x1

    pint = 0
    do i=1,n
        xx = 0
        do j=1,i
            xx = xx + a(j) * b(i-j+1) / dble(i)
        enddo
        pint = pint + p(i) * dx * xx
    enddo
    return
end

!----------------------------------------------------------
subroutine caltl( nlayer,vnp,vra,rho,ra,tl)
!----------------------------------------------------------
! Computing of lumped mass matrix.
!----------------------------------------------------------
    implicit none
    integer:: nlayer,vnp
    double precision:: vra(vnp),rho(vnp),ra(nlayer+1),tl(4*nlayer)
    integer:: i,nn,snp
    double precision:: c(3),from,to

    snp = 1
    do i=1,nlayer
        c(1) = 0
        c(2) = 0
        c(3) = 1

        from = ra(i)
        to = ( ra(i) + ra(i+1) ) / 2
        nn = 4 * (i-1)
        call pinteg( snp,3,c,from,to,vnp,vra,rho,tl(nn+1) )

        tl(nn+2) = 0
        tl(nn+3) = 0

        from = to
        to = ra(i+1)
        call pinteg( snp,3,c,from,to,vnp,vra,rho,tl(nn+4) )
    enddo
    return
end

!----------------------------------------------------------
subroutine calhl( nlayer,vnp,vra,mu,ra,hl)
!----------------------------------------------------------
! Computing of lumped rigidity matrix.
!----------------------------------------------------------
    implicit none
    integer:: nlayer,vnp
    double precision:: vra(vnp),mu(vnp),ra(nlayer+1),hl(4*nlayer)
    integer:: i,nn,snp
    double precision:: c(1),from,to

    snp = 1
    do i=1,nlayer
        c(1) = 1
        from = ra(i)
        to = ( ra(i) + ra(i+1) ) / 2
        nn = 4 * (i-1)
        call pinteg( snp,1,c,from,to,vnp,vra,mu,hl(nn+1) )

        hl(nn+2) = 0
        hl(nn+3) = 0

        from = to
        to = ra(i+1)
        call pinteg( snp,1,c,from,to,vnp,vra,mu,hl(nn+4) )
    enddo
    return
end

!----------------------------------------------------------
subroutine calh5( nlayer,vra,con,ra,h5 )
!----------------------------------------------------------
! Computation of the submatrix `h5'.
!----------------------------------------------------------
    implicit none
    integer:: nlayer
    double precision:: vra(*),con(*),ra(nlayer+1),h5(4*nlayer)
    integer:: itmp,i

    ! Data initialization
    h5(1:4*nlayer)=0

    itmp = 0
    do
        itmp = itmp + 1
        if ( vra(itmp)==ra(1) ) then
            if ( vra(itmp+1)==vra(itmp) ) itmp = itmp + 1
            exit
        endif
    enddo
    itmp = itmp - 1

    do i=1,nlayer
        itmp = itmp + 1
        h5(4*i-3) = - 3.d0 / 8.d0 * con(itmp) * ra(i) - 1.d0 / 8.d0 * con(itmp+1) * ra(i+1)
        h5(4*i-2) = - h5(4*i-3)
        h5(4*i-1) = - 1.d0 / 8.d0 * con(itmp) * ra(i) - 3.d0 / 8.d0 * con(itmp+1) * ra(i+1)
        h5(4*i)   = - h5(4*i-1)
    enddo
    return
end

!----------------------------------------------------------
subroutine calhm1( nlayer,vra,con,ra,hm1 )
!----------------------------------------------------------
! Computing the modified submatrix `hm1'.
!----------------------------------------------------------
    implicit none
    integer:: nlayer
    double precision:: vra(nlayer),con(nlayer+1),ra(nlayer+1),hm1(-1:2,nlayer+1)
    integer:: itmp,i

    hm1=0
    itmp = 0
    do
        itmp = itmp + 1
        if ( vra(itmp)==ra(1) ) then
            if ( vra(itmp+1)==vra(itmp) ) itmp = itmp + 1
            exit
        endif
    enddo
    hm1(0,1) = hm1(0,1) - 7.d0 / 12.d0 * con(itmp) * ra(1)
    hm1(1,1) = hm1(1,1) + 8.d0 / 12.d0 * con(itmp) * ra(1)
    hm1(2,1) = hm1(2,1) - 1.d0 / 12.d0 * con(itmp) * ra(1)
    do i=2,nlayer-1
        itmp = itmp + 1
        hm1(-1,i) = hm1(-1,i) - 5.d0 / 12.d0 * con(itmp) * ra(i)
        hm1( 0,i) = hm1( 0,i) - 3.d0 / 12.d0 * con(itmp) * ra(i)
        hm1( 1,i) = hm1( 1,i) + 9.d0 / 12.d0 * con(itmp) * ra(i)
        hm1( 2,i) = hm1( 2,i) - 1.d0 / 12.d0 * con(itmp) * ra(i)
    enddo
    itmp = itmp + 1
    hm1(-1,nlayer) = hm1(-1,nlayer) - 5.d0 / 12.d0 * con(itmp) * ra(nlayer)
    hm1( 0,nlayer) = hm1( 0,nlayer) - 3.d0 / 12.d0 * con(itmp) * ra(nlayer)
    hm1( 1,nlayer) = hm1( 1,nlayer) + 8.d0 / 12.d0 * con(itmp) * ra(nlayer)
    itmp = itmp + 1
    hm1(-1,nlayer+1) = hm1(-1,nlayer+1) - 5.d0 / 12.d0 * con(itmp) * ra(nlayer+1)
    hm1( 0,nlayer+1) = hm1( 0,nlayer+1) + 5.d0 / 12.d0 * con(itmp) * ra(nlayer+1)
    return
end

!----------------------------------------------------------
subroutine calhm2( nlayer,vra,con,ra,hm2 )
!----------------------------------------------------------
! Computing the modified submatrix `hm2'.
!----------------------------------------------------------
    implicit none
    integer ::nlayer
    double precision:: vra(nlayer),con(nlayer+1),ra(nlayer+1),hm2(-2:1,nlayer+1)
    integer ::itmp,i
    hm2=0
    itmp = 0
    do
        itmp = itmp + 1
        if ( vra(itmp)==ra(1) ) then
            if ( vra(itmp+1)==vra(itmp) ) itmp = itmp + 1
            exit
        endif
    enddo
    hm2(0,1) = hm2(0,1) - 5.d0 / 12.d0 * con(itmp) * ra(1)
    hm2(1,1) = hm2(1,1) + 5.d0 / 12.d0 * con(itmp) * ra(1)
    itmp = itmp + 1
    hm2(-1,2) = hm2(-1,2) - 8.d0 / 12.d0 * con(itmp) * ra(2)
    hm2( 0,2) = hm2( 0,2) + 3.d0 / 12.d0 * con(itmp) * ra(2)
    hm2( 1,2) = hm2( 1,2) + 5.d0 / 12.d0 * con(itmp) * ra(2)
    do i=3,nlayer
        itmp = itmp + 1
        hm2(-2,i) = hm2(-2,i) + 1.d0 / 12.d0 * con(itmp) * ra(i)
        hm2(-1,i) = hm2(-1,i) - 9.d0 / 12.d0 * con(itmp) * ra(i)
        hm2( 0,i) = hm2( 0,i) + 3.d0 / 12.d0 * con(itmp) * ra(i)
        hm2( 1,i) = hm2( 1,i) + 5.d0 / 12.d0 * con(itmp) * ra(i)
    enddo
    itmp = itmp + 1
    hm2(-2,nlayer+1) = hm2(-2,nlayer+1) + 1.d0 / 12.d0 * con(itmp) * ra(nlayer+1)
    hm2(-1,nlayer+1) = hm2(-1,nlayer+1) - 8.d0 / 12.d0 * con(itmp) * ra(nlayer+1)
    hm2( 0,nlayer+1) = hm2( 0,nlayer+1) + 7.d0 / 12.d0 * con(itmp) * ra(nlayer+1)
    return
end

!----------------------------------------------------------
subroutine mtrnp(nlayer,a1,a2)
!----------------------------------------------------------
! Computing 'a2' which is the transpose of 'a1'.
!----------------------------------------------------------
    implicit none
    integer:: nlayer
    double precision,intent(in):: a1(4*nlayer)
    double precision,intent(out):: a2(4*nlayer)
    integer:: i,nn

    nn = 4 * nlayer

    a2(1:nn-3:4) = a1(1:nn-3:4)
    a2(2:nn-2:4) = a1(3:nn-1:4)
    a2(3:nn-1:4) = a1(2:nn-2:4)
    a2(4:nn:4) = a1(4:nn:4)

    return
end

!----------------------------------------------------------
subroutine mtrnp2( nlayer,p,q,hm1,hm2 )
!----------------------------------------------------------
    implicit none
    integer::nlayer,p,q
    double precision,intent(in):: hm1(-p:q,nlayer+1)
    double precision,intent(out)::hm2(-q:p,nlayer+1)
    integer::i,j,m,n

    do i=-q,p
        do j=1,nlayer+1
            m = -i
            n = i + j
            if ( n>=1 .and. n<=nlayer+1 ) hm2(i,j) = hm1(m,n)
        enddo
    enddo

    return
end

!----------------------------------------------------------
subroutine calcoef( nzone,omega,qmu,qkappa,coef1,coef2,coef )
!----------------------------------------------------------
    use parameters
    implicit none
    integer:: nzone
    double precision,intent(in):: omega,qmu(nzone),qkappa(nzone)
    complex(dp),intent(out):: coef1(nzone),coef2(nzone),coef(nzone)
    integer:: i
    double precision:: aa,bb

    ! evaluating the effect of anelasticity
    do i=1,nzone
        if ( qmu(i)<=0 ) then
            coef1(i) = 1
        else
            if ( omega==0 ) then
                aa = 1
            else
                aa = 1  + dlog( omega / ( 2.d0 * pi ) ) / ( pi * qmu(i) )
            endif
            bb = 1 / ( 2 * qmu(i) )
            coef1(i) = dcmplx( aa, bb ) * dcmplx( aa, bb )
        endif
        if ( qkappa(i)<=0.d0 ) then
            coef2(i) =  1
            coef(i) =  1  / coef2(i)
        else
            if ( omega==0.d0 ) then
                aa = 1.d0
            else
                aa = 1.d0  + dlog( omega / ( 2.d0 * pi ) ) / ( pi * qkappa(i) )
            endif
            bb = 1 / ( 2 * qkappa(i) )
            coef2(i) = dcmplx( aa, bb ) * dcmplx( aa, bb )
            coef(i) =  1  / coef2(i)
        endif
    enddo
    return
end

!----------------------------------------------------------
subroutine cala0( nlayer,omega,omegai,t,h1x,h2L,h2N,&
    h3ay,h4aL,h4aN,h5ay,h6aL,h6aN,&
    h7y,h7z,h8L,h8N,coef1,coef2,a0 )
    use parameters
    implicit none
!----------------------------------------------------------
! Computing the coefficient matrix 'a' in the solid part.
!----------------------------------------------------------
    integer:: nlayer
    double precision,intent(in):: omega,omegai
    double precision,intent(in):: t(4*nlayer)
    double precision,intent(in):: h1x(4*nlayer),h2L(4*nlayer),h2N(4*nlayer)
    double precision,intent(in):: h3ay(4*nlayer),h4aL(4*nlayer),h4aN(4*nlayer)
    double precision,intent(in):: h5ay(4*nlayer),h6aL(4*nlayer),h6aN(4*nlayer)
    double precision,intent(in):: h7y(4*nlayer),h7z(4*nlayer),h8L(4*nlayer),h8N(4*nlayer)
    complex(dp),intent(in):: coef1,coef2
    complex(dp),intent(out):: a0(16*nlayer)
    integer:: i,nnn
    double precision:: tt
    complex(dp)::hh0,comega2
    !
    a0( 1:16*nlayer)=0
    comega2 = dcmplx( omega, -omegai ) * dcmplx( omega, -omegai )
    do i=1,16*nlayer-3,4
        nnn = ( i + 3 ) / 4
        if ( mod(nnn,4)==3 ) cycle
        tt = t(nnn)
        hh0 = coef2 *  4.d0 * h1x(nnn) & !4A
            + coef1 *  16.d0/3.d0 * h2N(nnn) & !4A
            - coef1 *  4.d0 * h2N(nnn) & !-4N
            + coef2 *  2.d0 * ( h3ay(nnn) + h5ay(nnn) ) & !2F
            - coef1 *  4.d0/3.d0 * ( h4aN(nnn) + h6aN(nnn) ) &
            + coef2 * ( 3.d0 *h7z(nnn) -2.d0*h7y(nnn) )& !C
            + coef1 *  4.d0/3.d0 * h8N(nnn)  !C
        a0(i) = comega2 * tt  - hh0
    enddo
    do i=4,16*nlayer,4
        nnn = i / 4
        if ( mod(nnn,4)==3 ) cycle
        tt = t(nnn)
        hh0 = coef1 *    h2L(nnn)  &!L
            + coef1 * ( -2.d0 * h2N(nnn) )& !-2N
            - coef1 *  (h4aL(nnn) + h6aL(nnn) )& !-L
            + coef1 *  h8L(nnn)  !L
        a0(i) = comega2 *  tt  - hh0
    enddo
    return
end

!----------------------------------------------------------
subroutine cala1( nlayer,h1x,h2L,h2N,h3y,&
    h4L,h4N,h5y,h6L,h6N,coef1,coef2,a1 )
!----------------------------------------------------------
! Computing the coefficient matrix 'a' in the solid part.
!----------------------------------------------------------
    use parameters
    implicit none
    integer:: nlayer
    double precision,intent(in):: h1x(4*nlayer),h2L(4*nlayer),h2N(4*nlayer)
    double precision,intent(in):: h3y(4*nlayer),h4L(4*nlayer),h4N(4*nlayer)
    double precision,intent(in):: h5y(4*nlayer),h6L(4*nlayer),h6N(4*nlayer)
    complex(dp):: coef1,coef2
    complex(dp),intent(out):: a1(16*nlayer)
    integer:: i,nnn
    complex(dp):: hh1

    a1( 1:16*nlayer )=0
    do i=2,16*nlayer-2,4
        nnn = ( i + 2 ) / 4
        if ( mod(nnn,4)==3 ) cycle
        hh1 = - coef2 * ( 2.d0 * h1x(nnn) )&  !2A
            - coef1 * ( 8.d0/3.d0 * h2N(nnn) ) &!2A
            - coef1 * ( h2L(nnn) )& !L
            - coef1 * ( -2.d0 * h2N(nnn) ) &!-2N
            - coef2 * ( h3y(nnn) )& !F
            - coef1 * ( -2.d0/3.d0 * h4N(nnn) ) &!F
            + coef1 * ( h6L(nnn) ) !-L
        a1(i) = - hh1
    enddo
    do i=3,16*nlayer-1,4
        nnn = ( i + 1 ) / 4
        if ( mod(nnn,4)/=2 ) cycle
        hh1 = - coef2 * ( 2.d0 * h1x(nnn) )& !2A
            - coef1 * ( 8.d0/3.d0 * h2N(nnn) ) & !2A
            - coef1 * ( -2.d0 * h2N(nnn) )& !-2N
            - coef1 *   h2L(nnn)  & !L
            + coef1 *  h4L(nnn)  & !-L
            - coef2 *  h5y(nnn) & !F
            + coef1 * ( 2.d0/3.d0 * h6N(nnn) ) !F
        a1(i) = - hh1
    enddo
    return
end

!----------------------------------------------------------
subroutine cala2( nlayer,h1x,h2L,h2N,coef1,coef2,a2 )
!----------------------------------------------------------
! Computing the coefficient matrix 'a' in the solid part.
!----------------------------------------------------------
    use parameters
    implicit none
    integer:: nlayer
    double precision,intent(in):: h1x(4*nlayer),h2L(4*nlayer),h2N(4*nlayer)
    complex(dp),intent(in):: coef1,coef2
    complex(dp),intent(out):: a2(16*nlayer)
    integer:: i,nnn
    complex(dp):: hh2

    a2( 1:16*nlayer)=0
    do i=1,16*nlayer-3,4
        nnn = ( i + 3 ) / 4
        if ( mod(nnn,4)==3 ) cycle
        hh2 = coef1 * h2L(nnn)
        a2(i) = - hh2
    enddo

    do i=4,16*nlayer,4
        nnn = i / 4
        if ( mod(nnn,4)==3 ) cycle
        hh2 = coef2 *  h1x(nnn) + coef1 * ( 4.d0/3.d0 * h2N(nnn) )
        a2(i) = - hh2
    enddo
    return
end

!----------------------------------------------------------
subroutine calb0( nlayer,omega,omegai,p1,p3,coef,b0 )
!----------------------------------------------------------
! Computing the coefficient matrix 'b' in the solid part.
!----------------------------------------------------------
    use parameters
    implicit none
    integer:: nlayer
    double precision,intent(in):: omega,omegai,p1(4*nlayer),p3(4*nlayer)
    complex(dp),intent(in):: coef
    complex(dp),intent(out)::b0(4*nlayer)
    integer:: i
    complex(dp):: comega2

    b0( 1:4*nlayer )=0
    comega2 = dcmplx( omega, -omegai ) * dcmplx( omega, -omegai )

    do i=1,nlayer
        b0(i*4-3) = -  p1(i*4-3)  / comega2  + coef * p3(i*4-3)
        b0(i*4-2) = -  p1(i*4-2)  / comega2  + coef * p3(i*4-2)
        b0(i*4) = - p1(i*4)  / comega2  + coef * p3(i*4)
    enddo
    return
end

!----------------------------------------------------------
subroutine calb2( nlayer,omega,omegai,p2,b2 )
!----------------------------------------------------------
! Computing the coefficient matrix 'b' in the solid part.
!----------------------------------------------------------
    use parameters
    implicit none
    integer:: nlayer
    double precision,intent(in):: omega,omegai,p2(4*nlayer)
    complex(dp),intent(out):: b2(4*nlayer)
    integer:: i
    complex(dp):: comega2

    b2( 1:4*nlayer )=0
    comega2 = dcmplx( omega, -omegai ) * dcmplx( omega, -omegai )

    do i=1,nlayer
        b2(i*4-3) = - p2(i*4-3) / comega2
        b2(i*4-2) = - p2(i*4-2) / comega2
        b2(i*4) = - p2(i*4) / comega2
    enddo
    return
end

!----------------------------------------------------------
subroutine calhml( nlayer,coef1,coef2,h3my,h5my,h4m1L,h4m2N,h6m1N,h6m2L,a1 )
!----------------------------------------------------------
! Summing up the modified first derivatives matrix operators.
!----------------------------------------------------------
    use parameters
    implicit none
    integer:: nlayer
    double precision,intent(in):: h3my(-2:1,nlayer+1),h5my(-1:2,nlayer+1)
    double precision,intent(in):: h4m1L(-1:2,nlayer+1),h4m2N(-2:1,nlayer+1)
    double precision,intent(in):: h6m1N(-1:2,nlayer+1),h6m2L(-2:1,nlayer+1)
    complex(dp),intent(in):: coef1,coef2
    complex(dp),intent(out)::a1(4,2*nlayer+2)
    integer:: i,j,m,n

    do j=2,2*(nlayer+1),2
        do i=1,3,2
            if ( i==1 .and. j==2 ) cycle
            m = (-i+3)/2
            n = (i+j-3)/2
            a1(i,j) = a1(i,j)&
                - ( - coef2 *  h3my(m,n) & !-F
                + coef1 * ( 2.d0/3.d0 * h4m2N(m,n) )&
                + coef1 * ( h6m2L(m,n) ) )!L
        enddo
    enddo
    do j=3,2*nlayer+1,2
        do i=1,3,2
            if ( i==1 .and. j==3 ) cycle
            m = (-i+5)/2
            n = (i+j-4)/2
            a1(i,j) = a1(i,j)&
                - (   coef1 * ( h4m1L(m,n) ) &!L
                - coef2 * ( h5my(m,n) ) &!-F
                + coef1 * ( 2.d0/3.d0 * h6m1N(m,n) ) )
        enddo
    enddo
    return
end

!----------------------------------------------------------
subroutine overlapa(nlayer,a,a2)
!----------------------------------------------------------
! Overlapping the coefficient matrix elements in the solid part.
!----------------------------------------------------------
    use parameters
    implicit none
    integer:: nlayer
    complex(dp),intent(in):: a(16*nlayer)
    complex(dp),intent(out)::a2(4,2*nlayer+2)
    integer:: i,nsize,msize,n1,n2

    nsize = 2 * ( nlayer + 1 )
    msize = 16 * nlayer

    a2(1:4,1:nsize)=0

    a2(4,1) = a(1)
    a2(3,2)  = a(2)
    a2(4,2)  = a(4)
    a2(4,nsize-1) = a(msize-3)
    a2(3,nsize)   = a(msize-2)
    a2(4,nsize)   = a(msize)
    do i=3,nsize-1,2
        n1 = 16 * (i-3)/2 + 5
        a2(2,i) = a(n1)
        n1 = n1 + 2
        a2(3,i) = a(n1)
        if ( i/=nsize-1 ) then
            n1 = n1 + 6
            n2 = n1 + 4
            a2(4,i) = a(n1) + a(n2)
        endif
    enddo
    do i=4,nsize,2
        n1 = 16 * (i-4)/2 + 6
        a2(1,i) = a(n1)
        n1 = n1 + 2
        a2(2,i) = a(n1)
        if ( i/=nsize ) then
            n1 = n1 + 6
            n2 = n1 + 4
            a2(3,i) = a(n1) + a(n2)
            n1 = n1 + 2
            n2 = n1 + 4
            a2(4,i) = a(n1) + a(n2)
        endif
    enddo
    return
end

!----------------------------------------------------------
subroutine overlapb(nlayer,b,b2)
!----------------------------------------------------------
! Overlapping the coefficient matrix elements in the liquid part.
!----------------------------------------------------------
    use parameters
    implicit none
    integer:: nlayer
    complex(dp)::b(4*nlayer),b2(4,nlayer+1)
    integer:: i,n1,n2

    b2(1:4,1:nlayer+1)=0

    b2(4,1) = b(1)
    do i=2,nlayer
        b2(4,i) = b( 4 * ( i - 1 )) + b( 4 * ( i - 1 )+1)
    enddo
    b2(4,nlayer+1) = b(4*nlayer)

    do i=2,nlayer+1
        b2(3,i) = b(4 * ( i - 2 ) + 2)
    enddo
    return
end

!----------------------------------------------------------
subroutine cala( ndc,iphase,nlayer,kkdr,kdr,ksp,&
        l2,lsq,nn,a0,a1,a2,a )
!----------------------------------------------------------
    use parameters
    implicit none
    integer,intent(in):: ndc,iphase(ndc+1)
    integer,intent(in):: nlayer(maxnzone)
    integer,intent(in):: kkdr(ndc+1),kdr,ksp(maxnzone),nn
    double precision,intent(in):: l2,lsq
    complex(dp),intent(in):: a0(4,*),a1(4,*),a2(4,*)
    complex(dp),intent(out)::a(4,nn)
    integer:: j,isl,ill,ii,jj,mtmp,i1,i2
    ! --- Initializing the matrix elements
    a(1:4,1:nn)=0

    isl = 0
    ill = 0
    do j=1,ndc+1
        if ( iphase(j)==1 ) then
            isl = isl + 1
            i1 = kkdr(j)
            i2 = kkdr(j)+2*nlayer(j)+1
            do jj=i1,i2
                mtmp = kdr+ksp(j)+jj-kkdr(j)
                a(2:4:2,jj) = a(2:4:2,jj) + a0(2:4:2,mtmp)+ l2*a2(2:4:2,mtmp)
                a(1:3:2,jj) = a(1:3:2,jj) + lsq*a1(1:3:2,mtmp)
            enddo
        else
            ill = ill + 1
            i1 = kkdr(j)
            i2 = kkdr(j)+nlayer(j)
            do jj=i1,i2
                mtmp = kdr+ksp(j)+jj-kkdr(j)
                a(3:4,jj)=a(3:4,jj)+a0(3:4,mtmp)+l2*a2(3:4,mtmp)
            enddo
        endif
    enddo
    return
end

!----------------------------------------------------------
subroutine calbc( ndc,rdc,iphase,kkdr,a )
!----------------------------------------------------------
! Computing the boundary condition elements.
!----------------------------------------------------------
    use parameters
    implicit none
    integer:: ndc,iphase(ndc+1),kkdr(ndc+1)
    double precision,intent(in):: rdc(ndc+1)
    complex(dp),intent(out):: a(4,*)
    integer:: i

    do i=1,ndc
        if ( iphase(i)==1 .and. iphase(i+1)==2 )  a( 2,kkdr(i+1) ) =   rdc(i) * rdc(i)
        if ( iphase(i)==2 .and. iphase(i+1)==1 )  a( 3,kkdr(i+1) ) = -  rdc(i) * rdc(i)
    enddo
    return
end

!----------------------------------------------------------
subroutine calabnum( omega,omegai,rmax,rrho,vpv,vph,vsv,vsh,eta,&
    ra,r0,coef1,coef2,anum,bnum )
!----------------------------------------------------------
    use parameters
    implicit none
    double precision:: omega,omegai,rmax
    double precision:: rrho(4),vpv(4),vph(4),vsv(4),vsh(4),eta(4)
    double precision:: ra(2),r0
    complex(dp):: coef1,coef2,anum(4,4,10),bnum(4,4,10)
    integer:: i,j,k
    double precision:: trho,tmu,tecA,tecC,tecL,tecN,tAkappa,tCkappa
    double precision:: tvpv,tvph,tvsv,tvsh,teta,coef,r,r2
    complex(dp):: xrho,xecA,xecC,xecF,xecL,xecN
    complex(dp):: xmu,xFdC,xAmF2dC
    complex(dp):: xAkappa,xCkappa,comega2

    anum(1:4,1:4,1:10) =  0
    bnum(1:4,1:4,1:10) =  0
    ! computation of mu,lam and rho at r
    do i=1,10
        if ( i<=5 ) then
            r = ra(1) + (i-1) / 4.d0 * ( r0 - ra(1) )
        else
            r = ra(2) - (10-i) / 4.d0 * ( ra(2) - r0 )
        endif
        trho = 0
        tvpv = 0
        tvph = 0
        tvsv = 0
        tvsh = 0
        teta = 0
        do j=1,4
            if ( j==1 ) then
                coef = 1
            else
                coef = coef * ( r / rmax )
            endif
            trho = trho + rrho(j) * coef
            tvpv = tvpv + vpv(j) * coef
            tvph = tvph + vph(j) * coef
            tvsv = tvsv + vsv(j) * coef
            tvsh = tvsh + vsh(j) * coef
            teta = teta + eta(j) * coef
        enddo
        tecA = trho * tvph * tvph
        tecC = trho * tvpv * tvpv
        tecL = trho * tvsv * tvsv
        tecN = trho * tvsh * tvsh
        tmu  = trho * tvsv * tvsv

        tAkappa = tecA - tmu * 4.d0 / 3.d0
        tCkappa = tecC - tmu * 4.d0 / 3.d0
        xAkappa = tAkappa * coef2
        xCkappa = tCkappa * coef2
        xrho = trho
        xmu  = tmu *coef1
        xecL = tecL * coef1
        xecN = tecN * coef1
        xecA = xAkappa + 4.d0 / 3.d0*xmu
        xecC = xCkappa + 4.d0 / 3.d0*xmu
        xecF = teta * ( xecA - 2 * xecL )
        xFdC = xecF / xecC
        xAmF2dC = xecA - xecF * xFdC

        r2 = r * r
        comega2 = dcmplx( omega, -omegai ) * dcmplx( omega, -omegai )

        anum(1,1,i) = -  2 / r  * xFdC
        anum(1,2,i) =    1 / xecC
        anum(2,1,i) = - xrho * comega2   +  4 / r2  * ( xAmF2dC - xecN )
        anum(2,2,i) =   2 / r  * ( xFdC - 1 )
        anum(3,1,i) = - 1 / r
        anum(3,3,i) =   1 / r
        anum(3,4,i) =   1 / xecL
        anum(4,1,i) = - 2 / r2  * ( xAmF2dC - xecN )
        anum(4,2,i) = - xFdC / r
        anum(4,3,i) = - xrho * comega2 -  2 / r2  * xecN
        anum(4,4,i) = - 3 / r
        bnum(1,3,i) =   xFdC / r
        bnum(2,3,i) = - 2 / r2  * ( xAmF2dC - xecN )
        bnum(2,4,i) =   1 / r
        bnum(4,3,i) =   xAmF2dC / r2
    enddo
    return
end

!----------------------------------------------------------
subroutine calya( aa,bb,l2,ra,r0,ya,yb,yc,yd )
!----------------------------------------------------------
! Computing the excitation vector using Geller and Hatori(1995).
!                                1995.7     N.Takeuchi
! 2020.5 K.Konishi
!----------------------------------------------------------
    use parameters
    implicit none
    common a,b,cl2,itmp
    external eqmotion1
! ---------------------------<< variables >>---------------------------
! variables for the source
    double precision:: r0
! variables for the numerical integration
    integer:: i,k,itmp
    double precision:: l2,cl2
    complex(dp):: ya(4),yb(4),yc(4),yd(4),yn(4)
    double precision:: xs,xe,dr,ra(2)
    complex(dp):: work(4,2),aa(160),bb(160),a(64),b(64)
    integer ktmp1,ktmp2,ktmp3,ktmp4

    ! -----------------------<< common variables >>-----------------------
    cl2 = l2
    ! ---------------------<< numerical integration >>---------------------
    ! integration from the lower boundary
    ya=0
    ya(2) = 1
    yb=0
    yb(4) = 1
    dr = ( r0 - ra(1) ) / 2.d0
    if ( dr>0.d0 ) then
        xs = ra(1)
        do  k=1,2
            ktmp1 = 32 * ( k-1 )
            ktmp2 = ktmp1 - 16
            do i=1,64
                if ( i<=32 ) then
                    a(i) = aa(i+ktmp1)
                    b(i) = bb(i+ktmp1)
                else
                    a(i) = aa(i+ktmp2)
                    b(i) = bb(i+ktmp2)
                endif
            enddo
            itmp = 0
            xe = xs + dr
            call rk3(4,xs,xe,1,ya,yn,4,work)
            itmp = 0
            xs = xe - dr
            call rk3(4,xs,xe,1,yb,yn,4,work)
        enddo
    endif
! integration from the upper boundary
    yc = 0
    yc(2) = 1
    yd = 0
    yd(4) = 1
    dr = ( ra(2) - r0 ) / 2.d0
    if ( dr>0 ) then
        xs = ra(2)
        do k=1,2
            ktmp1 = 144 - 32 * ( k-1 )
            ktmp2 = ktmp1 - 32
            ktmp3 = ktmp1 - 48
            ktmp4 = ktmp1 - 80
            do i=1,64
                if ( i<=32 ) then
                    if ( i<=16 ) then
                        a(i) = aa(i+ktmp1)
                        b(i) = bb(i+ktmp1)
                    else
                        a(i) = aa(i+ktmp2)
                        b(i) = bb(i+ktmp2)
                    endif
                else
                    if ( i<=48 ) then
                        a(i) = aa(i+ktmp3)
                        b(i) = bb(i+ktmp3)
                    else
                        a(i) = aa(i+ktmp4)
                        b(i) = bb(i+ktmp4)
                    endif
                endif
            enddo
            itmp = 0
            xe = xs - dr
            call rk3(4,xs,xe,1,yc,yn,4,work)
            itmp = 0
            xs = xe + dr
            call rk3(4,xs,xe,1,yd,yn,4,work)
        enddo
    endif
end

!----------------------------------------------------------
subroutine calg( l,m,coef1,coef2,lsq,ecC0,ecF0,ecL0,ya,yb,yc,yd,ra,r0,mt,g )
!----------------------------------------------------------
! Computing the excitation vector using Geller and Hatori(1995).
!                                1995.7     N.Takeuchi
! changed 2020,5 K.Konishi
!----------------------------------------------------------
    use parameters
    implicit none
! ---------------------------<< variables >>---------------------------
! variables for the structure
    complex(dp),intent(in):: coef1,coef2
! variables for the source
    double precision:: r0,mt(3,3),ecC0,ecF0,ecL0
    complex(dp):: dd,ee,s1,s2,s(4)
! variables for the numerical integration
    integer l,m
    complex(dp):: ya(4),yb(4),yc(4),yd(4)
    complex(dp),intent(out):: g(4)
    double precision:: ra(2)
    ! other variables
    integer ip(4),ier,i
    complex(dp):: a(4,4),b(4),wk(4),xtmp
    double precision:: eps,sgn,b1,b2,lsq,r03,dtmp(4)
    data eps / -1.d0 /

! ---------------------<< parameter computation >>---------------------
! computation of the discontinuity
    if ( m>=0 ) then
        sgn = 1
    else
        sgn = -1
    endif
    b1 = dsqrt( (2*l+1)/pi/16 )
    if ( l/=0 ) b2 = dsqrt( (2*l+1d0)*(l-1)*(l+2)/pi/64 )

    if ( iabs(m)==2 ) then
        dd = 0
        ee = 0
    endif
    if ( iabs(m)==1 ) then
        dd = 0
        ee = dcmplx( - b1 * sgn * mt(1,2), b1 * mt(1,3) ) / ( r0 * r0 * ecL0 * coef1 )
    endif
    if ( m==0 ) then
        dd = dcmplx( 2.d0 * b1 * mt(1,1) / ( r0 * r0 ) ) &
            / ( ( ecC0 - 4.d0 / 3.d0 * ecL0 ) * coef2 + 4.d0/3.d0*ecL0 * coef1 )
        ee = 0
    endif

    if ( m==0 ) then
        r03 = r0 * r0 * r0
        xtmp = ( ( ecF0 + 2.d0 / 3.d0 * ecL0) * coef2 &
            - 2.d0 / 3.d0 * ecL0 * coef1 )&
            / ( (ecC0 - 4.d0 / 3.d0 * ecL0)* coef2 &
            + 4.d0 / 3.d0 * ecL0 * coef1 )
        s1 = - 2.d0 * b1 * ( mt(2,2) + mt(3,3) ) / r03  +  4.d0 * b1 * mt(1,1) / r03 * xtmp
        s2 =  b1 * lsq * ( mt(2,2) + mt(3,3) ) / r03  -  2.d0 * b1 * lsq * mt(1,1) / r03 * xtmp
    endif
    if ( iabs(m)==1 ) then
        s1 =  0
        s2 =  0
    endif
    if ( iabs(m)==2 ) then
        r03 = r0 * r0 * r0
        s1 = 0
        s2 = b2*dcmplx( mt(3,3)- mt(2,2), sgn * 2.d0 * mt(2,3) ) /r03
    endif
    s(1) = dd
    s(2) = s1
    if ( l/=0 ) then
        s(3) = ee/lsq
        s(4) = s2/lsq
    else
        s(3:4) =  0
    endif
! consideration of the boundary conditions
! determination of the analytical solution
    if ( l/=0 ) then
        call sab1( ya,yb,yc,yd,s,a,b )
        call glu(a,4,4,b,eps,wk,ip,ier)
    else
        call sab2( ya,yc,s,a,b )
        call glu(a,2,4,b,eps,wk,ip,ier)
        b(3) = b(2)
        b(2) = 0
        b(4) = 0
    endif
! computation of the excitation vector
    dtmp(1) = - ra(1) * ra(1)
    dtmp(2) = dtmp(1) * lsq
    dtmp(3) = ra(2) * ra(2)
    dtmp(4) = dtmp(3) * lsq

    g(1:4) = b(1:4)*dtmp(1:4)

end

!----------------------------------------------------------
subroutine eqmotion1(r,y,f)
!----------------------------------------------------------
! Equation of the motion of the solid medium.
!----------------------------------------------------------
    use parameters
    implicit none
    common a,b,l2,itmp
    double precision:: r,l2
    complex(dp):: y(4),f(4)
    integer i,j,itmp,mtmp
    complex(dp):: a(64),b(64),c(4,4)

! computation of itmp
    itmp = itmp + 1
! computation of the differential coefficients
    mtmp = 16 * ( itmp - 1 )
    do j=1,4
        do i=1,4
            mtmp = mtmp + 1
            c(i,j) = a(mtmp) + l2*b(mtmp)
        enddo
    enddo
    do i=1,4
        f(i) = 0
        do j=1,4
            f(i) = f(i) + c(i,j) * y(j)
        enddo
    enddo
    return
end

!----------------------------------------------------------
subroutine sab1( ya,yb,yc,yd,s,a,b )
!----------------------------------------------------------
! determination of the matrix imposing the boundary conditions.
!----------------------------------------------------------
    use parameters
    implicit none
    complex(dp),intent(in):: ya(4),yb(4),yc(4),yd(4),s(4)
    complex(dp),intent(out):: a(4,4),b(4)
    integer i

    a(1:4,1) = - ya(1:4)
    a(1:4,2) = - yb(1:4)
    a(1:4,3) =   yc(1:4)
    a(1:4,4) =   yd(1:4)
    b(1:4) = s(1:4)
    return
end

!----------------------------------------------------------
subroutine sab2( ya,yc,s,a,b )
!----------------------------------------------------------
! determination of the matrix imposing the boundary conditions.
!----------------------------------------------------------
    use parameters
    implicit none
    complex(dp),intent(in):: ya(4),yc(4),s(4)
    complex(dp),intent(out):: a(4,4),b(4)
    integer i

    a(1:2,1) = - ya(1:2)
    a(1:2,2) =   yc(1:2)
    b(1:2) = s(1:2)
    return
end

!----------------------------------------------------------
subroutine rea2( nn,a,g,c,d,nzone,iphase,kkdr,spn,kkdr0,nn0 )
!----------------------------------------------------------
! rearranging the matrix elements for l=0.
!----------------------------------------------------------
    use parameters
    implicit none
    integer,intent(in):: nn,nzone
    integer,intent(in):: iphase(nzone),kkdr(nzone),spn
    integer,intent(out)::kkdr0,nn0
    complex(dp):: a(4,*),c(2,*),g(nn),d(nn)
    integer:: izone,i1,i2,itmp,mtmp,i
!
    itmp = 0
    do izone=1,nzone
        if ( iphase(izone)==1 ) then
            if ( izone==spn ) kkdr0 = itmp + 1
            i1 = itmp + 1
            if ( izone/=nzone ) then
                i2 = i1 + ( kkdr(izone+1) - kkdr(izone) ) / 2 - 1
            else
                i2 = i1 + ( nn + 1 - kkdr(izone) ) / 2 - 1
            endif
            d(i1) = g(kkdr(izone))
            if ( izone/=1 ) then
                if ( iphase(izone-1)==2 ) then
                    c(1,i1) = a(3,kkdr(izone))
                else
                    c(1,i1) = a(2,kkdr(izone))
                endif
            endif
            c(2,i1) = a(4,kkdr(izone))
            do i=i1+1,i2
                mtmp = kkdr(izone) + 2 * ( i - i1 )
                d(i) = g(mtmp)
                c(1,i) = a(2,mtmp)
                c(2,i) = a(4,mtmp)
            enddo
            itmp = i2
        else
            i1 = itmp + 1
            i2 = i1 + ( kkdr(izone+1) - kkdr(izone) ) - 1
            d(i1) = g(kkdr(izone))
            if ( izone/=1 ) then
                if ( iphase(izone-1)==1 ) then
                    c(1,i1) = a(2,kkdr(izone))
                else
                    c(1,i1) = a(3,kkdr(izone))
                endif
            endif
            c(2,i1) = a(4,kkdr(izone))
            do i=i1+1,i2
                mtmp = kkdr(izone) + ( i - i1 )
                d(i) = g(mtmp)
                c(1,i) = a(3,mtmp)
                c(2,i) = a(4,mtmp)
            enddo
            itmp = i2
        endif
    enddo
    nn0 = itmp
    return
end


module amos
  implicit none

  ! This module contains interfaces for the amos routines (in unmodified form
  ! found on http://netlib.org/amos).
  ! The slightly modified sources taken from SciPy's "legacy/amos/special"
  ! module are linked against.

  ! The original code was written by Donald E. Amos at Sandia National Labratories
  ! See also "Portable package for Bessel functions of a complex argument and
  ! non-negative order" by D. E. Amos in Trans. Math. Software (1986)

  ! Note that we made all routines pure routines. We do this to be able to
  ! use these routines in OpenMP loops and forall statements. The F77 routines
  ! are, of course, not declared as pure. However, they behave as such - the do
  ! not have side effects. Also, the intent of every argument is clear.
  ! Technically, there is one exception: the ?1mach.f90 routines (used in
  ! finding machine constants) each contain a write statement in case the query
  ! fails. We ignore this possibility (as we trust the queries made by amos).
  ! The author of the wrapper uses this without any problems in production code.

  interface

     ! Bessel J function:
     pure subroutine zbesj(re, im, order, scaling, length, zOut_r, zOut_i, &
          underflows, ierr)
       implicit none
       double precision, intent(in) :: re, im, order
       integer, intent(in) :: scaling, length
       double precision, intent(out) :: zOut_r(length), zOut_i(length)
       integer, intent(out) :: underflows, ierr
     end subroutine zbesj

     ! Bessel Y function of second kind:
     pure subroutine zbesy(re, im, order, scaling, length, zOut_r, zOut_i, &
          underflows, workr, worki, ierr)
       implicit none
       double precision, intent(in) :: re, im, order
       integer, intent(in) :: scaling, length
       double precision, intent(out) :: workr(length), worki(length), &
            zOut_r(length), zOut_i(length)
       integer, intent(out) :: underflows, ierr
     end subroutine zbesy

     ! modified Bessel I function of first kind:
     pure subroutine zbesi(re, im, order, scaling, length, zOut_r, zOut_i, &
          underflows, ierr)
       implicit none
       double precision, intent(in) :: re, im, order
       integer, intent(in) :: scaling, length
       double precision, intent(out) :: zOut_r(length), zOut_i(length)
       integer, intent(out) :: underflows, ierr
     end subroutine zbesi

     ! modified Bessel K function of second kind:
     pure subroutine zbesk(re, im, order, scaling, length, zOut_r, zOut_i, &
          underflows, ierr)
       implicit none
       double precision, intent(in) :: re, im, order
       integer, intent(in) :: scaling, length
       double precision, intent(out) :: zOut_r(length), zOut_i(length)
       integer, intent(out) :: underflows, ierr
     end subroutine zbesk

     ! Hankel H functions:
     pure subroutine zbesh(re, im, order, scaling, hankelkind, length, zOut_r, &
          zOut_i, underflows, ierr)
       implicit none
       double precision, intent(in) :: re, im, order
       integer, intent(in) :: scaling, hankelkind, length
       double precision, intent(out) :: zOut_r(length), zOut_i(length)
       integer, intent(out) :: underflows, ierr
     end subroutine zbesh

     ! Airy function Ai (or its derivative):
     pure subroutine zairy(re, im, deriv, scaling, zOut_r, zOut_i, underflow, ierr)
       implicit none
       double precision, intent(in) :: re, im
       integer, intent(in) :: deriv, scaling
       double precision, intent(out) :: zOut_r, zOut_i
       integer, intent(out) :: underflow, ierr
     end subroutine zairy

     ! Airy function Bi (or its derivative)
     pure subroutine zbiry(re, im, deriv, scaling, zOut_r, zOut_i, ierr)
       implicit none
       double precision, intent(in) :: re, im
       integer, intent(in) :: deriv, scaling
       double precision, intent(out) :: zOut_r, zOut_i
       integer, intent(out) :: ierr
     end subroutine zbiry

  end interface

end module amos


!
!     CalculiX - A 3-dimensional finite element program
!              Copyright (C) 1998-2021 Guido Dhondt
!
!     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(version 2);
!
!
!     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., 675 Mass Ave, Cambridge, MA 02139, USA.
!
!
!  regularization function for normal contact mortar
! see phd-thesis Sitzmann Chapter 3.2.1., semi-smooth Newton for normal contact
!
!  [in]lambdap  contact pressure in normal direction
!  [in]divmode indicates whether function or derivate
!                             should be called
!                    =0 function called
!                    =1 derivative called
!  [in]regmode        selects regularization funtion
!                    =1 perturbed Lagrange
!                    =2 piece wise linear with given data points
!                    =3 expontential contact law
!  [out]gnc        result regularization function
!  [in] aninvloc        stiffness constant for perturbed Lagrange
!  [in] p0 parameter for exponential regularization
!  [in] beta parameter for exponential regularization
!
      subroutine regularization_gn_c(lambdap,divmode,regmode,
     &     gnc,aninvloc,p0,beta,elcon,nelcon,itie,ntmat_,
     &     plicon,nplicon,npmat_,ncmat_,tietol,scal)
!
!     regularization function for normal contact
!     Author: Saskia Sitzmann
!
      implicit none
!
      integer divmode,regmode,i,ndata,kode,npmat_,ncmat_,
     &     itie,ntmat_,nplicon(0:ntmat_,*),nelcon(2,*),
     &     imat
!
      real*8 lambdap,gnc,pn_d(40),gn_d(40),aninv1(40),t(40),
     &     beta,p0,aninvloc,elconloc(21),plconloc(802),t1l,
     &     elcon(0:ncmat_,ntmat_,*),plicon(0:2*npmat_,ntmat_,*),
     &     tietol(4,*),scal
!
      kode=-51
      t1l=0.0
      imat=int(tietol(2,itie+1))
!
      gnc=0.0
!
!     perturbed Lagrange
!
      if(regmode.eq.1)then
         if(divmode.eq.0)then
            gnc=aninvloc*lambdap
         elseif(divmode.eq.1)then
            gnc=aninvloc
         else
            write(*,*)'error in regularzation_gn_c.f!'
            call exit(201)
         endif
!
!     multiple perturbed Lagrange
!
      else if(regmode.eq.2)then
         call materialdata_sp(elcon,nelcon,imat,ntmat_,i,t1l,
     &        elconloc,kode,plicon,nplicon,npmat_,plconloc,ncmat_)
         ndata=int(plconloc(801))
!        is this right?
c         ndata=int(plconloc(81))
         do i=1,ndata
            gn_d(i)=plconloc(2*i-1)*scal
            pn_d(i)=plconloc(2*i)*scal
         enddo
         do i=1,ndata-1
            aninv1(i)=(gn_d(i+1)-gn_d(i))/(pn_d(i+1)-pn_d(i))
            t(i)=gn_d(i)-aninv1(i)*pn_d(i)
         enddo
         if(divmode.eq.0)then
            if(lambdap.lt.pn_d(1))then
               gnc=aninv1(1)*lambdap+t(1)
            endif
            do i=1,ndata-2
               if(pn_d(i+1).gt.lambdap.and.pn_d(i).le.lambdap)then
                  gnc=aninv1(i)*lambdap+t(i)
               endif
            enddo
            if(pn_d(ndata-1).le.lambdap)then
               gnc=aninv1(ndata-1)*lambdap+t(ndata-1)
            endif
         elseif(divmode.eq.1)then
            if(lambdap.lt.pn_d(1))then
               gnc=aninv1(1)
            endif
            do i=1,ndata-2
               if(pn_d(i+1).gt.lambdap.and.pn_d(i).le.lambdap)then
                  gnc=aninv1(i)
               endif
            enddo
            if(pn_d(ndata-1).le.lambdap)then
               gnc=aninv1(ndata-1)
            endif
         else
            write(*,*)'error in regularzation_gn_c.f!'
            call exit(201)
         endif
!
!     exponetial perturbed Lagrange
!
      else if (regmode.eq.3)then
         if(divmode.eq.0)then
            if(lambdap.gt.0.0)then
               gnc=scal*beta*log(((lambdap/scal)+p0)/p0)
            else
               gnc=beta/(p0)*lambdap
            endif
         elseif(divmode.eq.1)then
            if(lambdap.gt.0.0)then
               gnc=beta/(lambdap+p0)
            else
               gnc=beta/(p0)
            endif
         else
            write(*,*)'error in regularzation_gn_c.f!'
            call exit(201)
         endif
      endif
c     call exit(201)
      return
      end