#include "macros.h"

module fftw_include
    use, intrinsic :: iso_c_binding
    include 'fftw3.f03'
end module fftw_include

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

module fftw
    use numbers
    use openmpi
    use io
    use parameters
    use fftw_include

    ! field arrays for fft
    complex(dpc), pointer, dimension(:, :, :) :: &
        fftw_sfieldk, fftw_sfieldkx, fftw_sfieldkx_tmp1, fftw_sfieldkx_tmp1_t, &
        fftw_sfieldkx_tmp2
    real(dp), pointer :: fftw_sfieldxx(:, :, :)

    type(C_PTR) :: p_fftw_sfieldk, p_fftw_sfieldxx, p_fftw_sfieldkx_tmp1, &
        p_fftw_sfieldkx_tmp2

    real(dp), allocatable, dimension(:) :: kx, ky, kz ! wave numbers
    integer(i4), allocatable, dimension(:) :: qx, qy, qz ! integer wave numbers

    integer(i4) :: &
        ix_zero = -1, iy_force = -1, & ! indices of ky=kF and kx=0
        ix_max = -1, iz_max = -1, & ! indices of max(kx) and max(kz)
        my_id_ix_max, my_id_ix_max1=-1 ! id of process with max(kx)

    ! fftw plans
    type(C_PTR) :: p_plan_x_forward,  p_plan_y_forward,  p_plan_z_forward, &
                   p_plan_x_backward, p_plan_y_backward, p_plan_z_backward

    ! benchmarking
    real(sp)    :: time_fftw = 0, time_local_transpose = 0, &
        time_global_transpose = 0

    contains

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

    subroutine fftw_allocate

        allocate(kx(nx_perproc), ky(ny_half), kz(nz), &
                 qx(nx_perproc), qy(ny_half), qz(nz))

        ! allocating fftw_sfieldk arrays with fftw_alloc_complex and pointing
        ! to them with c_f_pointer to make fftw happy with regards to memory
        ! alignment
        ! this also allows several arrays to share the same memory

        p_fftw_sfieldk = fftw_alloc_complex(int(nx_perproc * ny_half * nz, i8))
        ! fftw_sfieldk has its own memory
        call c_f_pointer(p_fftw_sfieldk, fftw_sfieldk, [nx_perproc, ny_half, nz])

        p_fftw_sfieldxx = fftw_alloc_complex(&
            int(nyy_half_pad1  * nzz_perproc * nxx, i8))
        ! fftw_sfieldxx and fftw_sfieldkx share memory
        call c_f_pointer(&
            p_fftw_sfieldxx, fftw_sfieldxx, [2 * nyy_half_pad1 , nzz_perproc, nxx])
        call c_f_pointer(&
            p_fftw_sfieldxx, fftw_sfieldkx, [nyy_half_pad1 , nzz_perproc, nxx])

        p_fftw_sfieldkx_tmp1 = fftw_alloc_complex(int(ny_half * nx_perproc * nzz, i8))
        ! fftw_sfieldkx_tmp1 and fftw_sfieldkx_tmp1_t share memory
        call c_f_pointer(p_fftw_sfieldkx_tmp1, fftw_sfieldkx_tmp1,   &
                         [ny_half, nx_perproc,  nzz])
        call c_f_pointer(p_fftw_sfieldkx_tmp1, fftw_sfieldkx_tmp1_t, &
                         [ny_half, nzz_perproc, nx])

        p_fftw_sfieldkx_tmp2 = fftw_alloc_complex(int(ny_half * nzz_perproc * nxx, i8))
        ! fftw_sfieldkx_tmp2 has its own memory
        call c_f_pointer(p_fftw_sfieldkx_tmp2, fftw_sfieldkx_tmp2, [ny_half, nzz_perproc, nxx])

        fftw_sfieldk = 0
        fftw_sfieldxx = 0
        fftw_sfieldkx_tmp1 = 0
        fftw_sfieldkx_tmp2 = 0

    end subroutine fftw_allocate

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

    subroutine fftw_init

        _indices

        call fftw_allocate()

        ! fftw plans

        ! forward, real to complex

        p_plan_y_forward = fftw_plan_many_dft_r2c(&
            1, [nyy], nzz_perproc * nxx, &
            fftw_sfieldxx, [2 * nyy_half_pad1], 1, 2 * nyy_half_pad1, &
            fftw_sfieldkx, [nyy_half_pad1], 1, nyy_half_pad1 , &
            FFTW_ESTIMATE)

        p_plan_x_forward = fftw_plan_many_dft(&
            1, [nxx], ny_half * nzz_perproc, &
            fftw_sfieldkx_tmp2(:, :, :), [nxx], ny_half * nzz_perproc, 1, &
            fftw_sfieldkx_tmp2(:, :, :), [nxx], ny_half * nzz_perproc, 1, &
            FFTW_FORWARD, FFTW_ESTIMATE)

        p_plan_z_forward = fftw_plan_many_dft(&
            1, [nzz], ny_half * nx_perproc, &
            fftw_sfieldkx_tmp1(:, :, :), [nzz], ny_half * nx_perproc, 1, &
            fftw_sfieldkx_tmp1(:, :, :), [nzz], ny_half * nx_perproc, 1, &
            FFTW_FORWARD, FFTW_ESTIMATE)

        ! backward, complex to real

        p_plan_z_backward = fftw_plan_many_dft(&
            1, [nzz], ny_half * nx_perproc, &
            fftw_sfieldkx_tmp1(:, :, :), [nzz], ny_half * nx_perproc, 1, &
            fftw_sfieldkx_tmp1(:, :, :), [nzz], ny_half * nx_perproc, 1, &
            FFTW_BACKWARD, FFTW_ESTIMATE)

        p_plan_x_backward = fftw_plan_many_dft(&
            1, [nxx], ny_half * nzz_perproc, &
            fftw_sfieldkx_tmp2(:, :, :), [nxx], ny_half * nzz_perproc, 1, &
            fftw_sfieldkx_tmp2(:, :, :), [nxx], ny_half * nzz_perproc, 1, &
            FFTW_BACKWARD, FFTW_ESTIMATE)

        p_plan_y_backward = fftw_plan_many_dft_c2r(&
            1, [nyy], nzz_perproc * nxx, &
            fftw_sfieldkx, [nyy_half_pad1 ], 1, nyy_half_pad1 , &
            fftw_sfieldxx, [2 * nyy_half_pad1 ], 1, 2 * nyy_half_pad1 , &
            FFTW_ESTIMATE)

        ! wavenumbers

        ! kx are shared among processes
        do ix = 1, nx_perproc
            qx(ix) = my_id * nx_perproc + ix - 1
            if (qx(ix) > nx_half) then
                qx(ix) = qx(ix) - nx
            end if
            kx(ix) = (2.0_dp * PI / Lx)  * qx(ix)
        end do

        ! ky keeps only the non-negative modes (rest comes from hermitian symmetry)
        do iy = 1, ny_half
            qy(iy) = iy - 1
            ky(iy) = (2.0_dp * PI / Ly)  * qy(iy)
        end do

        ! kz
        do iz = 1, nz
            qz(iz) = iz - 1
            if (qz(iz) > nz_half) then
                qz(iz) = qz(iz) - nz
            end if
            kz(iz) = (2.0_dp * PI / Lz)  * qz(iz)
        end do

        ! Find which index holds kF
        if (forcing /= 0) then
            do iy = 1, ny_half
                if (are_equal(ky(iy), kF)) then
                    iy_force = iy
                end if
            end do
        end if

        ! Find which index holds the zero mode in the distributed dimension
        do ix = 1, nx_perproc
            if (qx(ix) == 0) then
                ix_zero = ix
            end if
        end do

        ! Find which indices holds the maximal modes in x and z
        do ix = 1, nx_perproc
            if (qx(ix) == nx_half) then
                ix_max = ix
            end if
        end do

        ! broadcast which processor holds this index
        if (ix_max /= -1) my_id_ix_max1 = my_id
        call MPI_ALLREDUCE(my_id_ix_max1, my_id_ix_max, 1, MPI_INTEGER4, MPI_PROD, &
        MPI_COMM_WORLD, mpi_err)
        my_id_ix_max = abs(my_id_ix_max)

        do iz = 1, nz
            if (qz(iz) == nz_half) then
                iz_max = iz
            end if
        end do

    end subroutine fftw_init

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

    subroutine fftw_transpose(L,M,N,in,out)
        ! Adapted from nsCouette, mod_myMpi.f90, Florian Merz (IBM,RZG)
        ! https://gitlab.mpcdf.mpg.de/mjr/nscouette

        integer(i4),  intent(in)  :: L,M,N
        complex(dpc), intent(in)  :: in(L,M/num_procs,N)
        complex(dpc), intent(out) :: out(L,N/num_procs,M)
        complex(dpc) :: temp(L,M/num_procs,N/num_procs,num_procs)
        integer(i4)  :: blocksize, n_bl, pe, i, d1
        real(sp)     :: timer_start, timer_stop

        blocksize=L*(M/num_procs)*(N/num_procs)
        n_bl=M/num_procs

        ! WARNING: Might not work for when N=num_procs or M=num_procs
        ! parameters is set to abort at such values

        ! TODO: handle the above case.

        ! processor transpose (=alltoall), reordering and  local transpose
        call cpu_time(timer_start)
        call mpi_alltoall(in, blocksize, MPI_COMPLEX16,&
            temp, blocksize, MPI_COMPLEX16,&
            MPI_COMM_WORLD)
        call cpu_time(timer_stop)
        time_global_transpose = time_global_transpose + timer_stop - timer_start

        call cpu_time(timer_start)
        do pe=1,num_procs
            do i=1,N/num_procs
                do d1=1,L
                    out(d1,i,(pe-1)*n_bl+1:pe*n_bl)=temp(d1,:,i,pe)
                end do
            end do
        end do
        call cpu_time(timer_stop)
        time_local_transpose = time_local_transpose + timer_stop - timer_start

    end subroutine fftw_transpose

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

    subroutine fftw_transform(flag)

        integer(i4), intent(in) :: flag
        real(sp)                :: timer_start, timer_stop
        _indices

        if (flag == 1) then
            ! physical to spectral, end result is rescaled with norm_fft
            ! fftw_sfieldxx -> fftw_sfieldk

            ! do y: fftw_sfieldxx -> fftw_sfieldkx, in-place
            call cpu_time(timer_start)
            call fftw_execute_dft_r2c(p_plan_y_forward, &
                fftw_sfieldxx(:, :, :), fftw_sfieldkx(:, :, :))
            call cpu_time(timer_stop)
            time_fftw = time_fftw + timer_stop - timer_start

            ! shrink y: fftw_sfieldkx -> fftw_sfieldkx_tmp2
            call cpu_time(timer_start)
            do ix = 1, nxx
                do iz = 1, nzz_perproc
                    do iy = 1, ny_half
                        ! non-negative
                        fftw_sfieldkx_tmp2(iy, iz, ix) = fftw_sfieldkx(iy, iz, ix)
                    end do
                end do
            end do
            call cpu_time(timer_stop)
            time_local_transpose = time_local_transpose + timer_stop - timer_start

            ! do x: fftw_sfieldkx_tmp2 -> fftw_sfieldkx_tmp2, in-place
            call cpu_time(timer_start)
            call fftw_execute_dft(p_plan_x_forward, fftw_sfieldkx_tmp2, fftw_sfieldkx_tmp2)
            call cpu_time(timer_stop)
            time_fftw = time_fftw + timer_stop - timer_start

            ! shrink x: fftw_sfieldkx_tmp2 -> fftw_sfieldkx_tmp1_t
            call cpu_time(timer_start)
            ! maximum x mode is zeroed
            fftw_sfieldkx_tmp1_t(:, :, nx_half+1) = 0
            do ix = 1, nx_half
                do iz = 1, nzz_perproc
                    do iy = 1, ny_half
                        ! non-negative
                        fftw_sfieldkx_tmp1_t(iy, iz, ix) = fftw_sfieldkx_tmp2(iy, iz, ix)
                        ! negative
                        if (ix <= nx_half - 1) then
                            fftw_sfieldkx_tmp1_t(iy, iz, nx_half + 1 + ix) &
                                = fftw_sfieldkx_tmp2(iy, iz, 1 + nxx - nx_half + ix)
                        end if
                    end do
                end do
            end do
            call cpu_time(timer_stop)
            time_local_transpose = time_local_transpose + timer_stop - timer_start

            ! transpose: fftw_sfieldkx_tmp1_t -> fftw_sfieldkx_tmp1, in-place with temporary arrays
            call fftw_transpose(ny_half, nzz, nx, fftw_sfieldkx_tmp1_t, fftw_sfieldkx_tmp1)

            ! do z: fftw_sfieldkx_tmp1 -> fftw_sfieldkx_tmp1, in-place
            call cpu_time(timer_start)
            call fftw_execute_dft(p_plan_z_forward, fftw_sfieldkx_tmp1, fftw_sfieldkx_tmp1)
            call cpu_time(timer_stop)
            time_fftw = time_fftw + timer_stop - timer_start

            ! shrink z: fftw_sfieldkx_tmp1 -> fftw_sfieldk
            call cpu_time(timer_start)
            ! maximum z mode is zeroed
            fftw_sfieldk(:, :, nz_half+1) = 0
            do iz = 1, nz_half
                do iy = 1, ny_half
                    do ix = 1, nx_perproc
                        if (ix_max /= -1 .and. ix == ix_max) cycle
                        ! non-negative
                        fftw_sfieldk(ix, iy, iz) = fftw_sfieldkx_tmp1(iy, ix, iz)
                        ! negative
                        if (iz <= nz_half - 1) then
                            fftw_sfieldk(ix, iy, nz_half + 1 + iz) &
                                = fftw_sfieldkx_tmp1(iy, ix, 1 + nzz - nz_half + iz)
                        end if
                    end do
                end do
            end do
            call cpu_time(timer_stop)
            time_local_transpose = time_local_transpose + timer_stop - timer_start

            ! normalize
            fftw_sfieldk(:, :, :) = fftw_sfieldk(:, :, :) * norm_fft

        else if (flag == -1) then

            ! spectral to physical
            ! fftw_sfieldk -> fftw_sfieldxx

            ! expand z: fftw_sfieldk -> fftw_sfieldkx_tmp1
            call cpu_time(timer_start)
            fftw_sfieldkx_tmp1(:, :, :) = 0
            do iz = 1, nz_half
                do iy = 1, ny_half
                    do ix = 1, nx_perproc
                        if (ix_max /= -1 .and. ix == ix_max) cycle
                        ! non-negative
                        fftw_sfieldkx_tmp1(iy, ix, iz) = fftw_sfieldk(ix, iy, iz)
                        ! negative
                        if (iz <= nz_half - 1) then
                            fftw_sfieldkx_tmp1(iy, ix, 1 + nzz - nz_half + iz) &
                                                = fftw_sfieldk(ix, iy, nz_half + 1 + iz)
                        end if
                    end do
                end do
            end do
            call cpu_time(timer_stop)
            time_local_transpose = time_local_transpose + timer_stop - timer_start

            ! do z: fftw_sfieldkx_tmp1 -> fftw_sfieldkx_tmp1, in-place
            call cpu_time(timer_start)
            call fftw_execute_dft(p_plan_z_backward, fftw_sfieldkx_tmp1, fftw_sfieldkx_tmp1)
            call cpu_time(timer_stop)
            time_fftw = time_fftw + timer_stop - timer_start

            ! transpose: fftw_sfieldkx_tmp1 -> fftw_sfieldkx_tmp1_t, in-place with temporary arrays
            call fftw_transpose(ny_half, nx, nzz, fftw_sfieldkx_tmp1, fftw_sfieldkx_tmp1_t)

            ! expand x: fftw_sfieldkx_tmp1_t -> fftw_sfieldkx_tmp2
            call cpu_time(timer_start)
            fftw_sfieldkx_tmp2(:, :, :) = 0
            do ix = 1, nx_half
                do iz = 1, nzz_perproc
                    do iy = 1, ny_half
                        ! non-negative
                        fftw_sfieldkx_tmp2(iy, iz, ix) = fftw_sfieldkx_tmp1_t(iy, iz, ix)
                        ! negative
                        if (ix <= nx_half - 1) then
                            ! x has one zeroed mode (maximum positive)
                            fftw_sfieldkx_tmp2(iy, iz, 1 + nxx - nx_half + ix) &
                                            = fftw_sfieldkx_tmp1_t(iy, iz, nx_half + 1 + ix)
                        end if
                    end do
                end do
            end do
            call cpu_time(timer_stop)
            time_local_transpose = time_local_transpose + timer_stop - timer_start

            ! do x: fftw_sfieldkx_tmp2 -> fftw_sfieldkx_tmp2, in-place
            call cpu_time(timer_start)
            call fftw_execute_dft(p_plan_x_backward, fftw_sfieldkx_tmp2, fftw_sfieldkx_tmp2)
            call cpu_time(timer_stop)
            time_fftw = time_fftw + timer_stop - timer_start

            ! expand y: fftw_sfieldkx_tmp2 -> fftw_sfieldkx
            call cpu_time(timer_start)
            fftw_sfieldkx(:, :, :) = 0
            do ix = 1, nxx
                do iz = 1, nzz_perproc
                    do iy = 1, ny_half
                        ! non-negative
                        fftw_sfieldkx(iy, iz, ix) = fftw_sfieldkx_tmp2(iy, iz, ix)
                    end do
                end do
            end do
            call cpu_time(timer_stop)
            time_local_transpose = time_local_transpose + timer_stop - timer_start

            ! do y: fftw_sfieldkx -> fftw_sfieldxx, in-place
            call cpu_time(timer_start)
            call fftw_execute_dft_c2r(p_plan_y_backward, &
                    fftw_sfieldkx(:, :, :), fftw_sfieldxx(:, :, :))
            call cpu_time(timer_stop)
            time_fftw = time_fftw + timer_stop - timer_start

        end if

    end subroutine fftw_transform

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

    subroutine fftw_sx2k(sfieldxx, sfieldk)

        real(dp), intent(in) :: sfieldxx(:, :, :)
        complex(dpc), intent(out) :: sfieldk(:, :, :)
        _indices
        _indicess

        _loop_phys_begin
            fftw_sfieldxx(iyy, izz, ixx) = sfieldxx(iyy, izz, ixx)
        _loop_phys_end

        call fftw_transform(1)

        _loop_spec_begin
            sfieldk(ix, iy, iz) = fftw_sfieldk(ix, iy, iz)
        _loop_spec_end

    end subroutine fftw_sx2k

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

    subroutine fftw_sk2x(sfieldk, sfieldxx)

        complex(dpc), intent(in) :: sfieldk(:, :, :)
        real(dp), intent(out) :: sfieldxx(:, :, :)
        _indices
        _indicess

        _loop_spec_begin
            fftw_sfieldk(ix, iy, iz) = sfieldk(ix, iy, iz)
        _loop_spec_end

        call fftw_transform(-1)

        _loop_phys_begin
            sfieldxx(iyy, izz, ixx) = fftw_sfieldxx(iyy, izz, ixx)
        _loop_phys_end

    end subroutine fftw_sk2x

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

    subroutine fftw_vx2k(sfieldxx, sfieldk)

        real(dp), intent(in) :: sfieldxx(:, :, :, :)
        complex(dpc), intent(out) :: sfieldk(:, :, :, :)
        integer(i4) :: n

        do n=1,3
            call fftw_sx2k(sfieldxx(:,:,:,n), sfieldk(:,:,:,n))
        end do

    end subroutine fftw_vx2k

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

    subroutine fftw_vk2x(sfieldk, sfieldxx)

        complex(dpc), intent(in) :: sfieldk(:, :, :, :)
        real(dp), intent(out) :: sfieldxx(:, :, :, :)
        integer(i4) :: n

        do n=1,3
            call fftw_sk2x(sfieldk(:,:,:,n), sfieldxx(:,:,:,n))
        end do

    end subroutine fftw_vk2x

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

end module fftw


!###################################################################
!PURPOSE  : Build the impurity Green's function using spectral sum
!###################################################################
MODULE ED_GREENS_FUNCTIONS
  USE SF_CONSTANTS, only:one,xi,zero,pi
  USE SF_TIMER
  USE SF_IOTOOLS, only: str,free_unit,reg,free_units,txtfy,splot
  USE SF_ARRAYS,  only: arange,linspace
  USE SF_LINALG,  only: inv,inv_sym,inv_her,eye
  USE SF_SP_LINALG, only: sp_lanc_tridiag
  USE ED_INPUT_VARS
  USE ED_VARS_GLOBAL
  USE ED_IO                     !< this contains the routine to print GF,Sigma and G0
  USE ED_BATH_FUNCTIONS
  USE ED_SETUP
  USE ED_HAMILTONIAN
  USE ED_AUX_FUNX
  !
  implicit none
  private

  public :: buildGf_impurity

  public :: buildChi_impurity

  !Lanczos shared variables
  !=========================================================
  real(8),dimension(:),pointer                :: state_vec
  complex(8),dimension(:),pointer             :: state_cvec
  real(8)                                     :: state_e

  !Frequency and time arrays:
  !=========================================================
  real(8),dimension(:),allocatable            :: wm,tau,wr,vm

  !Auxiliary functions GF
  !=========================================================
  complex(8),allocatable,dimension(:,:,:,:,:) :: impDeltamats,impDeltareal
  complex(8),allocatable,dimension(:,:,:,:,:) :: invimpG0mats,invimpG0real
  complex(8),allocatable,dimension(:,:,:,:,:) :: invimpGmats,invimpGreal

contains

  subroutine buildgf_impurity()
    if(.not.allocated(wm))allocate(wm(Lmats))
    if(.not.allocated(wr))allocate(wr(Lreal))
    wm     = pi/beta*dble(2*arange(1,Lmats)-1)
    wr     = linspace(wini,wfin,Lreal)
    !
    impGmats=zero
    impGreal=zero
    !
    impSmats = zero
    impSreal = zero
    !
    impG0mats=zero
    impG0real=zero
    !
    if(.not.allocated(impDeltamats)) allocate(impDeltamats(Nspin,Nspin,Norb,Norb,Lmats))
    if(.not.allocated(invimpG0mats)) allocate(invimpG0mats(Nspin,Nspin,Norb,Norb,Lmats))
    if(.not.allocated(invimpGmats))  allocate( invimpGmats(Nspin,Nspin,Norb,Norb,Lmats))
    if(.not.allocated(impDeltareal)) allocate(impDeltareal(Nspin,Nspin,Norb,Norb,Lreal))
    if(.not.allocated(invimpG0real)) allocate(invimpG0real(Nspin,Nspin,Norb,Norb,Lreal))
    if(.not.allocated(invimpGreal))  allocate( invimpGreal(Nspin,Nspin,Norb,Norb,Lreal))
    impDeltamats=zero
    invimpGmats=zero
    invimpG0mats=zero
    impDeltareal=zero
    invimpGreal=zero
    invimpG0real=zero
    !
    write(LOGfile,"(A)")"Get impurity Greens functions:"
    call build_gf_normal()
    call get_sigma_normal()
    !
    if(ed_print_Sigma)call ed_print_impSigma()
    if(ed_print_G)call ed_print_impG()
    if(ed_print_G0)call ed_print_impG0()
    !
    if(allocated(wm))deallocate(wm)
    if(allocated(wr))deallocate(wr)
    if(allocated(invimpG0mats))deallocate(invimpG0mats)
    if(allocated(invimpGmats))deallocate(invimpGmats)
    if(allocated(impDeltamats))deallocate(impDeltamats)
    if(allocated(invimpG0real))deallocate(invimpG0real)
    if(allocated(invimpGreal))deallocate(invimpGreal)
    if(allocated(impDeltareal))deallocate(impDeltareal)
  end subroutine buildgf_impurity

  !+------------------------------------------------------------------+
  !PURPOSE  : Evaluate Green's functions
  !+------------------------------------------------------------------+
  subroutine build_gf_normal()
    integer :: iorb,jorb,ispin,i
    logical :: MaskBool
    !
    !
    !NORMAL: (default)
    do ispin=1,Nspin
       do iorb=1,Norb
          write(LOGfile,"(A)")"Get G_l"//str(iorb)//"_m"//str(iorb)//"_s"//str(ispin)
          call full_build_gf_normal(iorb,iorb,ispin)
       enddo
    enddo
    !
    ! !HYBRID:
    if(bath_type=="hybrid")then
       do ispin=1,Nspin
          do iorb=1,Norb
             do jorb=iorb+1,Norb
                write(LOGfile,"(A)")"Get G_l"//str(iorb)//"_m"//str(jorb)//"_s"//str(ispin)
                call full_build_gf_normal(iorb,jorb,ispin)
                !>>ACTHUNG: this relation might not be true, it depends on the value of the impHloc_ij
                ! if impHloc_ij is REAL then it is true. if CMPLX hermiticity must be ensured
                impGmats(ispin,ispin,jorb,iorb,:) = impGmats(ispin,ispin,iorb,jorb,:)
                impGreal(ispin,ispin,jorb,iorb,:) = impGreal(ispin,ispin,iorb,jorb,:)
             enddo
          enddo
       enddo
    endif
  end subroutine build_gf_normal

  subroutine full_build_gf_normal(iorb,jorb,ispin)
    integer          :: iorb,jorb,ispin
    integer          :: isite,jsite
    integer          :: idim,isector
    integer          :: jdim,jsector
    complex(8)       :: op_mat(2)
    complex(8)       :: spectral_weight
    real(8)          :: sgn_cdg,sgn_c
    integer          :: ib(Nlevels)
    integer          :: li,rj
    integer          :: m,i,j,r,k,p
    real(8)          :: Ei,Ej
    real(8)          :: expterm,peso,de,w0
    complex(8)       :: iw
    type(sector_map) :: HI,HJ
    !
    isite=impIndex(iorb,ispin)
    jsite=impIndex(jorb,ispin)
    !
    call start_timer
    !
    do isector=1,Nsectors
       jsector=getCDGsector(ispin,isector)
       if(jsector==0)cycle
       !
       call eta(isector,Nsectors)
       !
       idim=getdim(isector)     !i-th sector dimension
       jdim=getdim(jsector)     !j-th sector dimension
       call build_sector(isector,HI)
       call build_sector(jsector,HJ)
       !
       do i=1,idim          !loop over the states in the i-th sect.
          do j=1,jdim       !loop over the states in the j-th sect.
             op_mat=0.d0
             expterm=exp(-beta*espace(isector)%e(i))+exp(-beta*espace(jsector)%e(j))
             if(expterm < cutoff)cycle
             !
             do li=1,idim              !loop over the component of |I> (IN state!)
                m = HI%map(li)
                !
                ib = bdecomp(m,2*Ns)
                if(ib(isite) == 1)cycle
                call cdg(isite,m,k,sgn_cdg)
                rj = binary_search(HJ%map,k)
                !
                op_mat(1)=op_mat(1) + conjg(espace(jsector)%M(rj,j))*sgn_cdg*espace(isector)%M(li,i)
             enddo

             do rj=1,jdim
                m = HJ%map(rj)
                !
                ib = bdecomp(m,2*Ns)
                if(ib(jsite) == 0)cycle
                call c(jsite,m,k,sgn_c)
                li = binary_search(HI%map,k)
                !
                op_mat(2)=op_mat(2) + conjg(espace(isector)%M(li,i))*sgn_c*espace(jsector)%M(rj,j)
             enddo
             !
             Ei=espace(isector)%e(i)
             Ej=espace(jsector)%e(j)
             de=Ej-Ei
             peso=expterm/zeta_function
             spectral_weight=peso*product(op_mat)
             !
             do m=1,Lmats
                iw=xi*wm(m)
                impGmats(ispin,ispin,iorb,jorb,m)=impGmats(ispin,ispin,iorb,jorb,m)+spectral_weight/(iw-de)
             enddo
             !
             do m=1,Lreal
                w0=wr(m);iw=cmplx(w0,eps)
                impGreal(ispin,ispin,iorb,jorb,m)=impGreal(ispin,ispin,iorb,jorb,m)+spectral_weight/(iw-de)
             enddo
             !
          enddo
       enddo
       deallocate(HI%map,HJ%map)
    enddo
    call stop_progress
  end subroutine full_build_gf_normal

  !+------------------------------------------------------------------+
  !                    SELF-ENERGY FUNCTIONS
  !+------------------------------------------------------------------+
  subroutine get_sigma_normal
    integer                                           :: i,ispin,iorb
    complex(8),dimension(Nspin,Nspin,Norb,Norb,Lmats) :: invG0mats,invGmats
    complex(8),dimension(Nspin,Nspin,Norb,Norb,Lreal) :: invG0real,invGreal
    complex(8),dimension(Norb,Norb)                   :: invGimp
    !
    if(.not.allocated(wm))allocate(wm(Lmats))
    if(.not.allocated(wr))allocate(wr(Lreal))
    wm     = pi/beta*real(2*arange(1,Lmats)-1,8)
    wr     = linspace(wini,wfin,Lreal)
    !
    invG0mats = zero
    invGmats  = zero
    invG0real = zero
    invGreal  = zero
    !
    !Get G0^-1
    invG0mats(:,:,:,:,:) = invg0_bath_mats(dcmplx(0d0,wm(:)),dmft_bath)
    invG0real(:,:,:,:,:) = invg0_bath_real(dcmplx(wr(:),eps),dmft_bath)
    !
    select case(bath_type)
    case default                !Diagonal in both spin and orbital
       !
       !Get Gimp^-1
       do ispin=1,Nspin
          do iorb=1,Norb
             invGmats(ispin,ispin,iorb,iorb,:) = one/impGmats(ispin,ispin,iorb,iorb,:)
             invGreal(ispin,ispin,iorb,iorb,:) = one/impGreal(ispin,ispin,iorb,iorb,:)
          enddo
       enddo
       !Get Sigma functions: Sigma= G0^-1 - G^-1
       impSmats=zero
       impSreal=zero
       do ispin=1,Nspin
          do iorb=1,Norb
             impSmats(ispin,ispin,iorb,iorb,:) = invG0mats(ispin,ispin,iorb,iorb,:) - invGmats(ispin,ispin,iorb,iorb,:)
             impSreal(ispin,ispin,iorb,iorb,:) = invG0real(ispin,ispin,iorb,iorb,:) - invGreal(ispin,ispin,iorb,iorb,:)
          enddo
       enddo
       !
    case ("hybrid")   !Diagonal in spin only. Full Orbital structure
       !
       !Get Gimp^-1
       do ispin=1,Nspin
          do i=1,Lmats
             invGimp = impGmats(ispin,ispin,:,:,i)
             call inv(invGimp)
             invGmats(ispin,ispin,:,:,i)=invGimp
          enddo
          !
          do i=1,Lreal
             invGimp = impGreal(ispin,ispin,:,:,i)
             call inv(invGimp)
             invGreal(ispin,ispin,:,:,i)=invGimp
          enddo
       enddo
       !Get Sigma functions: Sigma= G0^-1 - G^-1
       impSmats=zero
       impSreal=zero
       do ispin=1,Nspin
          impSmats(ispin,ispin,:,:,:) = invG0mats(ispin,ispin,:,:,:) - invGmats(ispin,ispin,:,:,:)
          !
          impSreal(ispin,ispin,:,:,:) = invG0real(ispin,ispin,:,:,:) - invGreal(ispin,ispin,:,:,:)
       enddo
       !
    end select
    !
    !Get G0and:
    impG0mats(:,:,:,:,:) = g0and_bath_mats(dcmplx(0d0,wm(:)),dmft_bath)
    impG0real(:,:,:,:,:) = g0and_bath_real(dcmplx(wr(:),eps),dmft_bath)
    !!
    !
    if(allocated(wm))deallocate(wm)
    if(allocated(wr))deallocate(wr)
    !
  end subroutine get_sigma_normal

  !+------------------------------------------------------------------+
  ! SUSCEPTIBILITY CALCULATIONS
  !+------------------------------------------------------------------+
  subroutine buildChi_impurity()
    integer :: i
    !
    call allocate_grids
    !
    !
    !BUILD SPIN SUSCEPTIBILITY
    if(.not.allocated(spinChi_tau)) stop "buildChi_impurity: spinChi_tau not allocated"
    if(.not.allocated(spinChi_w))  stop "buildChi_impurity: spinChi_w not allocated"
    if(.not.allocated(spinChi_iv)) stop "buildChi_impurity: spinChi_iv not allocated"
    spinChi_tau=zero
    spinChi_w=zero
    spinChi_iv=zero
    call build_chi_spin()
    !PRINTING:
    call ed_print_impChi()
    !
    call deallocate_grids
  end subroutine buildChi_impurity

  !+------------------------------------------------------------------+
  !PURPOSE  : Evaluate Spin Susceptibility
  !+------------------------------------------------------------------+
  subroutine build_chi_spin()
    integer :: iorb
    write(LOGfile,"(A)")"Get impurity spin Chi:"
    do iorb=1,Norb
       write(LOGfile,"(A)")"Get Chi_spin_l"//reg(txtfy(iorb))
       call full_ed_build_spinChi_c(iorb)
    enddo
    ! if(Norb>1)then
    !    write(LOGfile,"(A)")"Get Chi_spin_tot"
    !    call lanc_ed_build_spinChi_tot_c()
    ! endif
    spinChi_tau = SpinChi_tau/zeta_function
    spinChi_w   = spinChi_w/zeta_function
    spinChi_iv  = spinChi_iv/zeta_function
  end subroutine build_chi_spin

  !+------------------------------------------------------------------+
  !PURPOSE  :
  !+------------------------------------------------------------------+
  subroutine full_ed_build_spinChi_c(iorb)
    integer                    :: iorb
    real(8)                    :: cdgmat(Norb),chij(Norb),chitot,spin,spintot
    integer,dimension(Nlevels) :: ib
    integer                    :: i,j,k,r,ll,m,in,is,ispin,jorb,isector
    integer                    :: idim,ia
    real(8)                    :: Ei,Ej,cc,peso(Norb),pesotot
    real(8)                    :: expterm,de,w0,it
    complex(8)                 :: iw
    type(sector_map)           :: HI    !map of the Sector S to Hilbert space H
    !
    !Spin susceptibility \X(tau). |<i|S_z|j>|^2
    call start_timer()
    do isector=1,Nsectors !loop over <i| total particle number
       call eta(isector,Nsectors,LOGfile)
       idim=getdim(isector)
       call build_sector(isector,HI)
       do i=1,idim
          do j=1,idim
             chij=0.d0
             chitot=0.d0
             expterm=exp(-beta*espace(isector)%e(j))
             if(expterm<cutoff)cycle
             do ll=1,idim
                ia=HI%map(ll)
                ib = bdecomp(ia,2*Ns)
                spintot=0.d0
                spin=dble(ib(iorb))-dble(ib(iorb+Ns)) !nup - ndw
                chij(iorb)=chij(iorb)+espace(isector)%M(ll,i)*spin*espace(isector)%M(ll,j)
                ! spintot=spintot+dble(ib(iorb))-dble(ib(iorb+Ns))
                ! chitot=chitot+espace(isector)%M(ll,i)*spintot*espace(isector)%M(ll,j)
             enddo
             Ei=espace(isector)%e(i)
             Ej=espace(isector)%e(j)
             de=Ei-Ej
             peso=chij/zeta_function
             pesotot=chitot/zeta_function
             !
             !Matsubara (bosonic) frequency
             if(de>cutoff)spinChi_iv(iorb,0)=spinChi_iv(iorb,0)-peso(iorb)*exp(-beta*Ej)*(exp(-beta*de)-1.d0)/de
             do m=1,Lmats
                iw=xi*vm(m)
                spinChi_iv(iorb,m)=spinChi_iv(iorb,m)+peso(iorb)*exp(-beta*Ej)*(exp(-beta*de)-1.d0)/(iw-de)
             enddo
             !
             !Real-frequency
             do m=1,Lreal
                w0=wr(m);iw=cmplx(w0,eps,8)
                !Retarded = Commutator = response function
                spinChi_w(iorb,m)=spinChi_w(iorb,m)+peso(iorb)*exp(-beta*Ej)*(exp(-beta*de)-1.d0)/(iw-de)
             enddo
             !
             !Imaginary time:
             do m=0,Ltau
                it=tau(m)
                spinChi_tau(iorb,m)=spinChi_tau(iorb,m) + exp(-it*Ei)*exp(-(beta-it)*Ej)*peso(iorb)
             enddo
             !
          enddo
       enddo
    enddo
    call stop_progress
  end subroutine full_ed_build_spinChi_c

  !+------------------------------------------------------------------+
  !PURPOSE  : Allocate arrays and setup frequencies and times
  !+------------------------------------------------------------------+
  subroutine allocate_grids
    integer :: i
    if(.not.allocated(wm))allocate(wm(Lmats))
    if(.not.allocated(vm))allocate(vm(0:Lmats))          !bosonic frequencies
    if(.not.allocated(wr))allocate(wr(Lreal))
    if(.not.allocated(tau))allocate(tau(0:Ltau))
    wm     = pi/beta*real(2*arange(1,Lmats)-1,8)
    do i=0,Lmats
       vm(i) = pi/beta*2.d0*dble(i)
    enddo
    wr     = linspace(wini,wfin,Lreal)
    tau(0:)= linspace(0.d0,beta,Ltau+1)
  end subroutine allocate_grids

  subroutine deallocate_grids
    if(allocated(wm))deallocate(wm)
    if(allocated(vm))deallocate(vm)
    if(allocated(tau))deallocate(tau)
    if(allocated(wr))deallocate(wr)
  end subroutine deallocate_grids

end MODULE ED_GREENS_FUNCTIONS


cc      MODULE UELUTIL
cc      CONTAINS
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C11111111122222222223333333333444444444455555555556666666666777777777777
C23456789012345678901234567890123456789012345678901234567890123456789012
C                                                                      C
C       --U S E R   E L E M E N T    S U B R O U T I N E S---          C
C                                                                      C
C23456789012345678901234567890123456789012345678901234567890123456789012
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C23456789012345678901234567890123456789012345678901234567890123456789012
C                                                                      C
C  UELEXP9.for                                                         C
C  9-NODED ISOPARAMETRIC ELEMENT WITH FULL GAUSS INTEGRATION           C
C  USER ELEMENT SUBROUTINE FOR EXPLICIT DYNAMIC ANALYSIS               C
C                                                                      C
C  GIVEN THE DISPLACEMENT AT TIME T AND THE DISPLACEMENT INCREMENT     C
C  IT RETURNS IN THE RHS() VECTOR THE INERTIAL FORCE CONTRIBUTION      C
C  AT TIME T+DT AND IN THE ANMASS() VECTOR THE DIAGONALIZED MASS       C
C  MATRIX                                                              C
C                                                                      C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C23456789012345678901234567890123456789012345678901234567890123456789012

      SUBROUTINE UELEXP9(RHS,ANMASS,NDOFEL,PROPS,NPROPS,IPROPS,NIPROPS,
     1                   AWAVE,IWAVE,COORDS,MCRD,NNODE,U,DU,V,A,JELEM,
     2                   DT,KINC,NINCR)

      IMPLICIT REAL*8(A-H,O-Z)

      PARAMETER (ZERO=0.D0,HALF=0.5D0,ONE=1.D0,TWO=2.D0,NGPTS=9,
     1           THREE=3.D0, NDI=3)

C     Parameter arrays from UEL.f

      DIMENSION RHS(NDOFEL),ANMASS(NDOFEL),PROPS(NPROPS),
     1          IPROPS(NIPROPS),AWAVE(5),COORDS(MCRD,NNODE),U(NDOFEL),
     2          DU(NDOFEL),V(NDOFEL),A(NDOFEL),AMATRX(NDOFEL,NDOFEL),
     3          AMASS(NDOFEL,NDOFEL),CDMAT(NDOFEL,NDOFEL),UP(NDOFEL),
     4          DDSDDE(NDI,NDI),B(NDI,NDOFEL),BT(NDOFEL,NDI),
     5          FRST2(NDOFEL,NDOFEL),FRST1(NDOFEL,NDOFEL),XP(2,NGPTS),
     6          XW(NGPTS),AUX1(NDI,NDOFEL)

C     Mass density.

      RO=PROPS(3)

C     Rayleigh damping parameters.

      AALFA=PROPS(1)
      ABETA=PROPS(2)

      RHS=0.0D0
      ANMASS=0.0D0
	  DDSDDE=0.0D0
	  B =0.0D0
	  BT=0.0D0
      FRST2=0.0D0
      FRST1=0.0D0
      XP=0.0D0
      XW=0.0D0
      AUX1=0.0D0
      AMATRX=0.0D0
      AMASS=0.0D0
      CDMAT=0.0D0

C       Elasticity tensor.

	  CALL UMAT(DDSDDE,NDI,PROPS,NPROPS)

C     Generates Gauss points and weights
C     and loops around all Gauss points.

      CALL GPOINTS3X3(XP,XW)
      NGPT=9
      SMS=0.0D0
      SMT=0.0D0

      DO NN=1,NGPT

        RII=XP(1,NN)
        SII=XP(2,NN)
        ALF=XW(NN)

C       Computes B matrix.

        CALL STDM9(NNODE,NDOFEL,NDI,COORDS,MCRD,B,DDET,RII,SII,
     1             XBAR)

        SMT=SMT+RO*DDET*XBAR*ALF

C       Assembles stiffness and mass matrix.

	  	AUX1=MATMUL(DDSDDE,B)
	  	BT=TRANSPOSE(B)
	  	FRST1=MATMUL(BT,AUX1)
C
        CALL AMASS9(FRST2,NDOFEL,RII,SII)

C       Considers Gauss weight and Jacobian determinant
C       into partial stiffness and mass matrix.

        FRST1=FRST1*(ALF*DDET*XBAR)
        FRST2=FRST2*(ALF*DDET*XBAR*RO)

C       Updates stiffness and mass matrix.

        AMATRX=AMATRX+FRST1
        AMASS=AMASS+FRST2

      END DO

C     Computes elastic,inertial and damping nodal forces.

      CALL EFFECTIVEFORCE(AMASS,AMATRX,ANMASS,NDOFEL,
     1                    AALFA,ABETA,U,V,A,DT,SMT,RHS,JELEM)

      RETURN

      END

CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C23456789012345678901234567890123456789012345678901234567890123456789012
C                                                                      C
C  UELEXP8.for                                                         C
C  8-NODED ISOPARAMETRIC ELEMENT WITH FULL GAUSS INTEGRATION           C
C  USER ELEMENT SUBROUTINE FOR EXPLICIT DYNAMIC ANALYSIS               C
C                                                                      C
C  GIVEN THE DISPLACEMENT AT TIME T AND THE DISPLACEMENT INCREMENT     C
C  IT RETURNS IN THE RHS() VECTOR THE INERTIAL FORCE CONTRIBUTION      C
C  AT TIME T+DT AND IN THE ANMASS() VECTOR THE DIAGONALIZED MASS       C
C  MATRIX                                                              C
C                                                                      C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C23456789012345678901234567890123456789012345678901234567890123456789012

      SUBROUTINE UELEXP8(RHS,ANMASS,NDOFEL,PROPS,NPROPS,IPROPS,NIPROPS,
     1                   AWAVE,IWAVE,COORDS,MCRD,NNODE,U,DU,V,A,JELEM,
     2                   DT,KINC,NINCR)

      IMPLICIT REAL*8(A-H,O-Z)

      PARAMETER (ZERO=0.D0,HALF=0.5D0,ONE=1.D0,TWO=2.D0,NGPTS=9,
     1           THREE=3.D0, NDI=3)

C     Parameter arrays from UEL.f

      DIMENSION RHS(NDOFEL),ANMASS(NDOFEL),PROPS(NPROPS),
     1          IPROPS(NIPROPS),AWAVE(5),COORDS(MCRD,NNODE),U(NDOFEL),
     2          DU(NDOFEL),V(NDOFEL),A(NDOFEL),AMATRX(NDOFEL,NDOFEL),
     3          AMASS(NDOFEL,NDOFEL),CDMAT(NDOFEL,NDOFEL),UP(NDOFEL),
     4          DDSDDE(NDI,NDI),B(NDI,NDOFEL),BT(NDOFEL,NDI),
     5          FRST2(NDOFEL,NDOFEL),FRST1(NDOFEL,NDOFEL),XP(2,NGPTS),
     6          XW(NGPTS),AUX1(NDI,NDOFEL)

C     Mass density.

      RO=PROPS(3)

C     Rayleigh damping parameters.

      AALFA=PROPS(1)
      ABETA=PROPS(2)

      RHS=0.0D0
      ANMASS=0.0D0
	  DDSDDE=0.0D0
	  B =0.0D0
	  BT=0.0D0
      FRST2=0.0D0
      FRST1=0.0D0
      XP=0.0D0
      XW=0.0D0
      AUX1=0.0D0
      AMATRX=0.0D0
      AMASS=0.0D0
      CDMAT=0.0D0

C       Elasticity tensor.

	  CALL UMAT(DDSDDE,NDI,PROPS,NPROPS)

C     Generates Gauss points and weights
C     and loops around all Gauss points.

      CALL GPOINTS3X3(XP,XW)
      NGPT=9
      SMS=0.0D0
      SMT=0.0D0

      DO NN=1,NGPT

        RII=XP(1,NN)
        SII=XP(2,NN)
        ALF=XW(NN)

C       Computes B matrix.

        CALL STDM8(NNODE,NDOFEL,NDI,COORDS,MCRD,B,DDET,RII,SII,
     1             XBAR)
        SMT=SMT+RO*DDET*XBAR*ALF

C       Assembles stiffness and mass matrix.

	  	AUX1=MATMUL(DDSDDE,B)
	  	BT=TRANSPOSE(B)
	  	FRST1=MATMUL(BT,AUX1)
C
        CALL AMASS8(FRST2,NDOFEL,RII,SII)

C       Considers Gauss weight and Jacobian determinant
C       into partial stiffness and mass matrix.

        FRST1=FRST1*(ALF*DDET*XBAR)
        FRST2=FRST2*(ALF*DDET*XBAR*RO)

C       Updates stiffness and mass matrix.

        AMATRX=AMATRX+FRST1
        AMASS=AMASS+FRST2

      END DO

C     Computes elastic,inertial and damping nodal forces.

      CALL EFFECTIVEFORCE(AMASS,AMATRX,ANMASS,NDOFEL,
     1                    AALFA,ABETA,U,V,A,DT,SMT,RHS,JELEM)

      RETURN

      END

CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C23456789012345678901234567890123456789012345678901234567890123456789012
C                                                                      C
C  UELEXP6.for                                                         C
C  6-NODED ISOPARAMETRIC ELEMENT WITH FULL GAUSS INTEGRATION           C
C  USER ELEMENT SUBROUTINE FOR EXPLICIT DYNAMIC ANALYSIS               C
C                                                                      C
C  GIVEN THE DISPLACEMENT AT TIME T AND THE DISPLACEMENT INCREMENT     C
C  IT RETURNS IN THE RHS() VECTOR THE INERTIAL FORCE CONTRIBUTION      C
C  AT TIME T+DT AND IN THE ANMASS() VECTOR THE DIAGONALIZED MASS       C
C  MATRIX                                                              C
C                                                                      C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C23456789012345678901234567890123456789012345678901234567890123456789012

      SUBROUTINE UELEXP6(RHS,ANMASS,NDOFEL,PROPS,NPROPS,IPROPS,NIPROPS,
     1                   AWAVE,IWAVE,COORDS,MCRD,NNODE,U,DU,V,A,JELEM,
     2                   DT,KINC,NINCR)

      IMPLICIT REAL*8(A-H,O-Z)

      PARAMETER (ZERO=0.D0,HALF=0.5D0,ONE=1.D0,TWO=2.D0,NGPTS=7,
     1           THREE=3.D0, NDI=3)

C     Parameter arrays from UEL.f

      DIMENSION RHS(NDOFEL),ANMASS(NDOFEL),PROPS(NPROPS),
     1          IPROPS(NIPROPS),AWAVE(5),COORDS(MCRD,NNODE),U(NDOFEL),
     2          DU(NDOFEL),V(NDOFEL),A(NDOFEL),AMATRX(NDOFEL,NDOFEL),
     3          AMASS(NDOFEL,NDOFEL),CDMAT(NDOFEL,NDOFEL),UP(NDOFEL),
     4          DDSDDE(NDI,NDI),B(NDI,NDOFEL),BT(NDOFEL,NDI),
     5          FRST2(NDOFEL,NDOFEL),FRST1(NDOFEL,NDOFEL),XP(2,NGPTS),
     6          XW(NGPTS),AUX1(NDI,NDOFEL)

C     Mass density.

      RO=PROPS(3)

C     Rayleigh damping parameters.

      AALFA=PROPS(1)
      ABETA=PROPS(2)

      RHS=0.0D0
      ANMASS=0.0D0
	  DDSDDE=0.0D0
	  B =0.0D0
	  BT=0.0D0
      FRST2=0.0D0
      FRST1=0.0D0
      XP=0.0D0
      XW=0.0D0
      AUX1=0.0D0
      AMATRX=0.0D0
      AMASS=0.0D0
      CDMAT=0.0D0

C       Elasticity tensor.

	  CALL UMAT(DDSDDE,NDI,PROPS,NPROPS)

C     Generates Gauss points and weights
C     and loops around all Gauss points.

      CALL GPOINTS7(XP,XW)
      NGPT=7
      SMS=0.0D0
      SMT=0.0D0

      DO NN=1,NGPT

        RII=XP(1,NN)
        SII=XP(2,NN)
        ALF=XW(NN)

C       Computes B matrix.

        CALL STDM6(NNODE,NDOFEL,NDI,COORDS,MCRD,B,DDET,RII,SII,
     1             XBAR)
        SMT=SMT+RO*DDET*XBAR*ALF

C       Assembles stiffness and mass matrix.

	  	AUX1=MATMUL(DDSDDE,B)
	  	BT=TRANSPOSE(B)
	  	FRST1=MATMUL(BT,AUX1)
C
        CALL AMASS6(FRST2,NDOFEL,RII,SII)

C       Considers Gauss weight and Jacobian determinant
C       into partial stiffness and mass matrix.

        FRST1=FRST1*(ALF*DDET*XBAR)
        FRST2=FRST2*(ALF*DDET*XBAR*RO)

C       Updates stiffness and mass matrix.

        AMATRX=AMATRX+FRST1
        AMASS=AMASS+FRST2

      END DO

C     Computes elastic,inertial and damping nodal forces.

      CALL EFFECTIVEFORCE(AMASS,AMATRX,ANMASS,NDOFEL,
     1                    AALFA,ABETA,U,V,A,DT,SMT,RHS,JELEM)

      RETURN

      END

C23456789012345678901234567890123456789012345678901234567890123456789012
C                                                                      C
C  UELEXP4.for                                                         C
C  4-NODED ISOPARAMETRIC ELEMENT WITH FULL GAUSS INTEGRATION           C
C  USER ELEMENT SUBROUTINE FOR EXPLICIT DYNAMIC ANALYSIS               C
C                                                                      C
C  GIVEN THE DISPLACEMENT AT TIME T AND THE DISPLACEMENT INCREMENT     C
C  IT RETURNS IN THE RHS() VECTOR THE INERTIAL FORCE CONTRIBUTION      C
C  AT TIME T+DT AND IN THE ANMASS() VECTOR THE DIAGONALIZED MASS       C
C  MATRIX                                                              C
C                                                                      C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C23456789012345678901234567890123456789012345678901234567890123456789012

      SUBROUTINE UELEXP4(RHS,ANMASS,NDOFEL,PROPS,NPROPS,IPROPS,NIPROPS,
     1                   AWAVE,IWAVE,COORDS,MCRD,NNODE,U,DU,V,A,JELEM,
     2                   DT,KINC,NINCR)

      IMPLICIT REAL*8(A-H,O-Z)

      PARAMETER (ZERO=0.D0,HALF=0.5D0,ONE=1.D0,TWO=2.D0,NGPTS=4,
     1           THREE=3.D0, NDI=3)

C     Parameter arrays from UEL.f

      DIMENSION RHS(NDOFEL),ANMASS(NDOFEL),PROPS(NPROPS),
     1          IPROPS(NIPROPS),AWAVE(5),COORDS(MCRD,NNODE),U(NDOFEL),
     2          DU(NDOFEL),V(NDOFEL),A(NDOFEL),AMATRX(NDOFEL,NDOFEL),
     3          AMASS(NDOFEL,NDOFEL),CDMAT(NDOFEL,NDOFEL),UP(NDOFEL),
     4          DDSDDE(NDI,NDI),B(NDI,NDOFEL),BT(NDOFEL,NDI),
     5          FRST2(NDOFEL,NDOFEL),FRST1(NDOFEL,NDOFEL),XP(2,NGPTS),
     6          XW(NGPTS),AUX1(NDI,NDOFEL)

C     Mass density.

      RO=PROPS(3)
C
C     Rayleigh damping parameters.

      AALFA=PROPS(1)
      ABETA=PROPS(2)

      RHS=0.0D0
      ANMASS=0.0D0
	  DDSDDE=0.0D0
	  B =0.0D0
	  BT=0.0D0
      FRST2=0.0D0
      FRST1=0.0D0
      XP=0.0D0
      XW=0.0D0
      AUX1=0.0D0
      AMATRX=0.0D0
      AMASS=0.0D0
      CDMAT=0.0D0

C       Elasticity tensor.

	  CALL UMAT(DDSDDE,NDI,PROPS,NPROPS)

C     Generates Gauss points and weights
C     and loops around all Gauss points.

      CALL GPOINTS2X2(XP,XW)
      NGPT=4
      SMS=0.0D0
      SMT=0.0D0

      DO NN=1,NGPT

        RII=XP(1,NN)
        SII=XP(2,NN)
        ALF=XW(NN)

C       Computes B matrix.

        CALL STDM4(NNODE,NDOFEL,NDI,COORDS,MCRD,B,DDET,RII,SII,
     1             XBAR)
        SMT=SMT+RO*DDET*XBAR*ALF

C       Assembles stiffness and mass matrix.

	  	AUX1=MATMUL(DDSDDE,B)
	  	BT=TRANSPOSE(B)
	  	FRST1=MATMUL(BT,AUX1)

        CALL AMASS4(FRST2,NDOFEL,RII,SII)

C       Considers Gauss weight and Jacobian determinant
C       into partial stiffness and mass matrix.

        FRST1=FRST1*(ALF*DDET*XBAR)
        FRST2=FRST2*(ALF*DDET*XBAR*RO)

C       Updates stiffness and mass matrix.

        AMATRX=AMATRX+FRST1
        AMASS=AMASS+FRST2

      END DO

C     Computes elastic,inertial and damping nodal forces.

      CALL EFFECTIVEFORCE(AMASS,AMATRX,ANMASS,NDOFEL,
     1                    AALFA,ABETA,U,V,A,DT,SMT,RHS,JELEM)

      RETURN

      END

C23456789012345678901234567890123456789012345678901234567890123456789012
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C                                                                      C
C   SUBROUTINE UEL9INCOT(RHS,ANMASS,NDOFEL,PROPS,NPROPS,IPROPS,NIPROPS,  C
C    1                   COORDS,MCRD,NNODE,U,DU,V,JELEM,DT)            C
C                                                                      C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C23456789012345678901234567890123456789012345678901234567890123456789012

      SUBROUTINE UEL9INCOT(RHS,ANMASS,NDOFEL,PROPS,NPROPS,IPROPS,
     1                  NIPROPS,AWAVE,IWAVE,COORDS,MCRD,NNODE,U,DU,V,A,
     2                  JELEM,DT,KINC,NINCR)

      IMPLICIT REAL*8(A-H,O-Z)

      PARAMETER (ZERO=0.D0,HALF=0.5D0,TWO=2.D0,NGPTS=9,
     1           THREE=3.D0,NDI=3,ONE=1.0D0)

      DIMENSION RHS(NDOFEL),ANMASS(NDOFEL),PROPS(NPROPS),AWAVE(5),
     1          COORDS(MCRD,NNODE),U(NDOFEL),DU(NDOFEL),V(NDOFEL),
     2          UP(NDOFEL),DDSDDE(NDI,NDI),B(NDI,NDOFEL),
     3          BT(NDOFEL,NDI),FRST2(NDOFEL,NDOFEL),A(NDOFEL),
     4          FRST1(NDOFEL,NDOFEL),XP(2,NGPTS),XW(NGPTS),
     5          AUX1(NDI,NDOFEL),R00(NDOFEL),RELA(NDOFEL),
     6          RINE(NDOFEL),RDAM(NDOFEL),AMATRX(NDOFEL,NDOFEL),
     7          AMASS(NDOFEL,NDOFEL),CDMAT(NDOFEL,NDOFEL)

      DIMENSION IPROPS(NIPROPS)

C     Mass density

      RO=PROPS(3)

C     Rayleigh damping constants.

      AALFA=PROPS(1)
      ABETA=PROPS(2)
      IDF=IPROPS(1)

C     Clears arrays.

      RHS=0.0D0
      ANMASS=0.0D0
      DDSDDE=0.0D0
      B=0.0D0
      BT=0.0D0
      FRST2=0.0D0
      FRST1=0.0D0
      XP=0.0D0
      XW=0.0D0
      AUX1=0.0D0
      R00=0.0D0
      RELA=0.0D0
      RINE=0.0D0
      RDAM=0.0D0
      AMATRX=0.0D0
      AMASS=0.0D0
      CDMAT=0.0D0

C       Elasticity tensor.

	  CALL UMAT(DDSDDE,NDI,PROPS,NPROPS)

C     Generates Gauss points and weights
C     and loops around all Gauss points.

      CALL GPOINTS3X3(XP,XW)
      NGPT=9
      SMS=0.0D0
      SMT=0.0D0

      DO NN=1,NGPT

        RII=XP(1,NN)
        SII=XP(2,NN)
        ALF=XW(NN  )

C       Computes B and mass matrix.

        CALL STDM9(NNODE,NDOFEL,NDI,COORDS,MCRD,B,DDET,RII,SII,
     1             XBAR)
        SMT=SMT+RO*DDET*XBAR*ALF

C       Assembles stiffness and mass matrix.

	  	AUX1=MATMUL(DDSDDE,B)
	  	BT=TRANSPOSE(B)
	  	FRST1=MATMUL(BT,AUX1)

        CALL AMASS9(FRST2,NDOFEL,RII,SII)

C       Considers Gauss weight and Jacobian determinant
C       into partial stiffness and mass matrices.

        FRST1=FRST1*(ALF*DDET*XBAR)
        FRST2=FRST2*(ALF*DDET*XBAR*RO)

C       Updates stiffness and mass matrix.

        AMATRX=AMATRX+FRST1
        AMASS=AMASS+FRST2

      END DO

C     Computes the contribution -Kij*Uj-MII*Ai-alpha*Kij*Vj.....

      CALL EFFECTIVEFORCE(AMASS,AMATRX,ANMASS,NDOFEL,
     1                    AALFA,ABETA,U,V,A,DT,SMT,RHS,JELEM)

C     Computes the incoming wave field and mekes it into effective
C     forces R00(n).

      CALL INCOMINGDIS9(IDF,AMATRX,COORDS,PROPS,NPROPS,MCRD,AWAVE,
     1                 IWAVE,NNODE,NDOFEL,R00,DT,KINC,NINCR,IOUT)

C     Updates the effective loads
C     loads vector RHS=R00(n)-Kij*Uj-MII*Ai-alpha*Kij*Vj....

      RHS=RHS+R00

      RETURN

      END

C23456789012345678901234567890123456789012345678901234567890123456789012
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C                                                                      C
C   SUBROUTINE UEL8INCOT(RHS,ANMASS,NDOFEL,PROPS,NPROPS,IPROPS,NIPROPS,C
C    1                   COORDS,MCRD,NNODE,U,DU,V,JELEM,DT)            C
C                                                                      C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C23456789012345678901234567890123456789012345678901234567890123456789012

      SUBROUTINE UEL8INCOT(RHS,ANMASS,NDOFEL,PROPS,NPROPS,IPROPS,
     1                  NIPROPS,AWAVE,IWAVE,COORDS,MCRD,NNODE,U,DU,V,A,
     2                  JELEM,DT,KINC,NINCR)

      IMPLICIT REAL*8(A-H,O-Z)

      PARAMETER (ZERO=0.D0,HALF=0.5D0,TWO=2.D0,NGPTS=9,
     1           THREE=3.D0,NDI=3,ONE=1.0D0)

      DIMENSION RHS(NDOFEL),ANMASS(NDOFEL),PROPS(NPROPS),AWAVE(5),
     1          COORDS(MCRD,NNODE),U(NDOFEL),DU(NDOFEL),V(NDOFEL),
     2          UP(NDOFEL),DDSDDE(NDI,NDI),B(NDI,NDOFEL),
     3          BT(NDOFEL,NDI),FRST2(NDOFEL,NDOFEL),A(NDOFEL),
     4          FRST1(NDOFEL,NDOFEL),XP(2,NGPTS),XW(NGPTS),
     5          AUX1(NDI,NDOFEL),R00(NDOFEL),RELA(NDOFEL),
     6          RINE(NDOFEL),RDAM(NDOFEL),AMATRX(NDOFEL,NDOFEL),
     7          AMASS(NDOFEL,NDOFEL),CDMAT(NDOFEL,NDOFEL)

      DIMENSION IPROPS(NIPROPS)

C     Mass density

      RO=PROPS(3)

C     Rayleigh damping constants.

      AALFA=PROPS(1)
      ABETA=PROPS(2)
      IDF=IPROPS(1)

C     Clears arrays.

      RHS=0.0D0
      ANMASS=0.0D0
      DDSDDE=0.0D0
      B=0.0D0
      BT=0.0D0
      FRST2=0.0D0
      FRST1=0.0D0
      XP=0.0D0
      XW=0.0D0
      AUX1=0.0D0
      R00=0.0D0
      RELA=0.0D0
      RINE=0.0D0
      RDAM=0.0D0
      AMATRX=0.0D0
      AMASS=0.0D0
      CDMAT=0.0D0

C       Elasticity tensor.

	  CALL UMAT(DDSDDE,NDI,PROPS,NPROPS)

C     Generates Gauss points and weights
C     and loops around all Gauss points.

      CALL GPOINTS3X3(XP,XW)
      NGPT=9
      SMS=0.0D0
      SMT=0.0D0

      DO NN=1,NGPT

        RII=XP(1,NN)
        SII=XP(2,NN)
        ALF=XW(NN  )

C       Computes B and mass matrix.

        CALL STDM8(NNODE,NDOFEL,NDI,COORDS,MCRD,B,DDET,RII,SII,
     1             XBAR)
        SMT=SMT+RO*DDET*XBAR*ALF

C       Assembles stiffness and mass matrix.

	  	AUX1=MATMUL(DDSDDE,B)
	  	BT=TRANSPOSE(B)
	  	FRST1=MATMUL(BT,AUX1)

        CALL AMASS8(FRST2,NDOFEL,RII,SII)

C       Considers Gauss weight and Jacobian determinant
C       into partial stiffness and mass matrices.

        FRST1=FRST1*(ALF*DDET*XBAR)
        FRST2=FRST2*(ALF*DDET*XBAR*RO)

C       Updates stiffness and mass matrix.

        AMATRX=AMATRX+FRST1
        AMASS=AMASS+FRST2

      END DO

C     Computes the contribution -Kij*Uj-MII*Ai-alpha*Kij*Vj.....

      CALL EFFECTIVEFORCE(AMASS,AMATRX,ANMASS,NDOFEL,
     1                    AALFA,ABETA,U,V,A,DT,SMT,RHS,JELEM)

C     Computes the incoming wave field and mekes it into effective
C     forces R00(n).

      CALL INCOMINGDIS8(IDF,AMATRX,COORDS,PROPS,NPROPS,MCRD,AWAVE,
     1                 IWAVE,NNODE,NDOFEL,R00,DT,KINC,NINCR,IOUT)

C     Updates the effective loads
C     loads vector RHS=R00(n)-Kij*Uj-MII*Ai-alpha*Kij*Vj....

      RHS=RHS+R00

      RETURN

      END

C23456789012345678901234567890123456789012345678901234567890123456789012
C                                                                      C
C   SUBROUTINE UEL4INCOT(RHS,ANMASS,NDOFEL,PROPS,NPROPS,IPROPS,NIPROPS,C
C    1                   COORDS,MCRD,NNODE,U,DU,V,JELEM,DT)            C
C                                                                      C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C23456789012345678901234567890123456789012345678901234567890123456789012

      SUBROUTINE UEL4INCOT(RHS,ANMASS,NDOFEL,PROPS,NPROPS,IPROPS,
     1                  NIPROPS,AWAVE,IWAVE,COORDS,MCRD,NNODE,U,DU,V,A,
     2                  JELEM,DT,KINC,NINCR)

      IMPLICIT REAL*8(A-H,O-Z)

      PARAMETER (ZERO=0.D0,HALF=0.5D0,ONE=1.D0,TWO=2.D0,NGPTS=4,
     1           THREE=3.D0, NDI=3)

C     Parameter arrays from UEL.f

      DIMENSION RHS(NDOFEL),ANMASS(NDOFEL),PROPS(NPROPS),AWAVE(5),
     1          COORDS(MCRD,NNODE),U(NDOFEL),DU(NDOFEL),V(NDOFEL),
     2          UP(NDOFEL),DDSDDE(NDI,NDI),B(NDI,NDOFEL),
     3          BT(NDOFEL,NDI),FRST2(NDOFEL,NDOFEL),A(NDOFEL),
     4          FRST1(NDOFEL,NDOFEL),XP(2,NGPTS),XW(NGPTS),
     5          AUX1(NDI,NDOFEL),R00(NDOFEL),RELA(NDOFEL),
     6          RINE(NDOFEL),RDAM(NDOFEL),AMATRX(NDOFEL,NDOFEL),
     7          AMASS(NDOFEL,NDOFEL),CDMAT(NDOFEL,NDOFEL)

      DIMENSION IPROPS(NIPROPS)

C     Mass density.

      RO=PROPS(3)
C
C     Rayleigh damping parameters.

      AALFA=PROPS(1)
      ABETA=PROPS(2)
      IDF=IPROPS(1)

C     Clears arrays.

      RHS=0.0D0
      ANMASS=0.0D0
      DDSDDE=0.0D0
      B=0.0D0
      BT=0.0D0
      FRST2=0.0D0
      FRST1=0.0D0
      XP=0.0D0
      XW=0.0D0
      AUX1=0.0D0
      R00=0.0D0
      RELA=0.0D0
      RINE=0.0D0
      RDAM=0.0D0
      AMATRX=0.0D0
      AMASS=0.0D0
      CDMAT=0.0D0

C       Elasticity tensor.

	  CALL UMAT(DDSDDE,NDI,PROPS,NPROPS)

C     Generates Gauss points and weights
C     and loops around all Gauss points.

      CALL GPOINTS2X2(XP,XW)
      NGPT=4
      SMS=0.0D0
      SMT=0.0D0

      DO NN=1,NGPT

        RII=XP(1,NN)
        SII=XP(2,NN)
        ALF=XW(NN)

C       Computes B matrix.

        CALL STDM4(JELEM,NNODE,NDOFEL,NDI,COORDS,MCRD,B,DDET,RII,SII,
     1             XBAR)
        SMT=SMT+RO*DDET*XBAR*ALF

C       Assembles stiffness and mass matrix.

	  	AUX1=MATMUL(DDSDDE,B)
	  	BT=TRANSPOSE(B)
	  	FRST1=MATMUL(BT,AUX1)

        CALL AMASS4(FRST2,NDOFEL,RII,SII)

C       Considers Gauss weight and Jacobian determinant
C       into partial stiffness and mass matrix.

        FRST1=FRST1*(ALF*DDET*XBAR)
        FRST2=FRST2*(ALF*DDET*XBAR*RO)

C       Updates stiffness and mass matrix.

        AMATRX=AMATRX+FRST1
        AMASS=AMASS+FRST2

      END DO

C     Computes elastic,inertial and damping nodal forces.

      CALL EFFECTIVEFORCE(AMASS,AMATRX,ANMASS,NDOFEL,
     1                    AALFA,ABETA,U,V,A,DT,SMT,RHS,JELEM)

C     Computes the incoming wave field and mekes it into effective
C     forces R00(n).

      CALL INCOMINGDIS4(IDF,AMATRX,COORDS,PROPS,NPROPS,MCRD,AWAVE,
     1                  IWAVE,NNODE,NDOFEL,R00,DT,KINC,NINCR,IOUT)

C     Updates the effective loads
C     loads vector RHS=R00(n)-Kij*Uj-MII*Ai-alpha*Kij*Vj....

      RHS=RHS+R00

      RETURN

      END

CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C23456789012345678901234567890123456789012345678901234567890123456789012
C                                                                      C
C    SUBROUTINE UELEDASH3(RHS,ANMASS,NDOFEL,PROPS,NPROPS,IPROPS,NIPROPS,C
C    1                    COORDS,MCRD,NNODE,U,DU,V,JELEM,DT)           C
C                                                                      C
C    ABSORBING DASHPOT ELEMENT                                         C
C                                                                      C
C                                                                      C
C23456789012345678901234567890123456789012345678901234567890123456789012
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC

      SUBROUTINE UELEDASH3(RHS,ANMASS,NDOFEL,PROPS,NPROPS,IPROPS,
     1                    NIPROPS,AWAVE,IWAVE,COORDS,MCRD,NNODE,
     2                    U,DU,V,A,JELEM,DT,KINC,NINCR)

      IMPLICIT REAL*8(A-H,O-Z)

      PARAMETER (ZERO=0.D0,HALF=0.5D0,ONE=1.D0,TWO=2.D0,THREE=3.D0)

C     Parameter arrays from UEL.f

      DIMENSION RHS(NDOFEL),ANMASS(NDOFEL),PROPS(NPROPS),
     1          IPROPS(NIPROPS),AWAVE(5),COORDS(MCRD,NNODE),U(NDOFEL),
     2          DU(NDOFEL),V(NDOFEL),AMATRX(NDOFEL,NDOFEL),DDSDDE(2,2),
     3          XGP(6),WGP(6),DDSDDET(2,2), DAUX(2,2),AUX(2,6),
     4          AUXT(6,2),RL(6,6),RLL(6,2),RM(2,2),RMT(2,2),A(NDOFEL)

C     CALL CLEARV(RHS,NDOFEL)
C     CALL CLEARV(ANMASS,NDOFEL)
C     CALL CLEAR(AMATRX,NDOFEL,NDOFEL)
      AMATRX=0.0D0

C     Wave propagation velocities

      AALFA=PROPS(1)
      ABETA=PROPS(2)
      RO=PROPS(3)

C     Constitutive tensor

      DDSDDE(1,2)=0.0D0
      DDSDDE(2,1)=0.0D0
      DDSDDE(1,1)=RO*AALFA
      DDSDDE(2,2)=RO*ABETA

      XI=COORDS(1,1)
      XM=COORDS(1,2)
      XJ=COORDS(1,3)
      YI=COORDS(2,1)
      YM=COORDS(2,2)
      YJ=COORDS(2,3)
      DXS=(XI-XJ)**2
      DYS=(YI-YJ)**2
      DL=DSQRT(DXS+DYS)
      DETJAC=DL/2.0

      CALL NORMVCT(XI,XJ,YI,YJ,CT,ST)
      RM(1,1)=  CT
      RM(1,2)=  ST
      RM(2,1)= -ST
      RM(2,2)=  CT

      RMT=TRANSPOSE(RM)
      DAUX=MATMUL(RMT,DDSDDE)
      DDSDDET=MATMUL(DAUX,RM)

      CALL GAUSS1D(XGP,WGP)

      DO N=1,6
        ETA =XGP(N)
        ALF =WGP(N)
        CALL SHAPE1D(AUXT,ETA)

        RLL=MATMUL(AUXT, DDSDDET)
	  	AUX=TRANSPOSE(AUXT)
	  	RL=MATMUL(RLL,AUX)
        AMATRX=AMATRX-RL*ALF*DETJAC
      END DO

      RHS=MATMUL(AMATRX,V)

      RETURN

      END

cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C23456789012345678901234567890123456789012345678901234567890123456789012
C                                                                      C
C    SUBROUTINE UELDASH3D(RHS,ANMASS,NDOFEL,PROPS,NPROPS,IPROPS,NIPROPSC
C    1                    ,COORDS,MCRD,NNODE,U,DU,V,JELEM,DT)          C
C                                                                      C
C    ABSORBING 3D DASHPOT ELEMENT                                      C
C                                                                      C
C                                                                      C
C23456789012345678901234567890123456789012345678901234567890123456789012
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC

      SUBROUTINE UELDASH3D(RHS,ANMASS,NDOFEL,PROPS,NPROPS,IPROPS,
     1                    NIPROPS,AWAVE,IWAVE,COORDS,MCRD,NNODE,
     2                    U,DU,V,A,JELEM,DT,KINC,NINCR)

      IMPLICIT REAL*8(A-H,O-Z)

      PARAMETER (ZERO=0.D0,HALF=0.5D0,ONE=1.D0,TWO=2.D0,THREE=3.D0,
     1           NGPTS=4)

C     Parameter arrays from UEL.f

      DIMENSION RHS(NDOFEL),ANMASS(NDOFEL),PROPS(NPROPS),
     1          IPROPS(NIPROPS),AWAVE(5),COORDS(MCRD,NNODE),U(NDOFEL),
     2          DU(NDOFEL),V(NDOFEL),AMATRX(NDOFEL,NDOFEL),DDSDDE(3,3),
     3          XGP(2,NGPTS),WGP(NGPTS),DDSDDET(3,3),DAUX(2,2),
     4          AUX(3,12),AUXT(12,3),RL(12,12),RLL(12,3),RM(3,3),
     5			RMT(3,3),A(NDOFEL),P1(3), P2(3), P3(3), P4(3),
     6			V1(3),V2(3),V3(3),V4(3),P1T(3),P2T(3),P3T(3),P4T(3),
     7			XY(2,4), P(2,4), XJ(2,2)

      AMATRX=0.0D0

C     Wave propagation velocities

      AALFA=PROPS(1)
      ABETA=PROPS(2)
      RO=PROPS(3)

C     Constitutive tensor

      DDSDDE=0.0D0

      DDSDDE(3,3)=RO*ABETA
      DDSDDE(2,2)=RO*ABETA
	  DDSDDE(1,1)=RO*AALFA

	  CALL TRANSFORMA(COORDS, RM, XY)

      RMT=TRANSPOSE(RM)

      DDSDDET= MATMUL(RM, DDSDDE)

	  CALL GPOINTS2X2(XGP,WGP)
	  DDSDDE = MATMUL(DDSDDET, RMT)

	  SMT= 0.0D0

      DO N=1,NGPTS

      	RII= XGP(1,N)
      	SII= XGP(2,N)
        ALF= WGP(N)

        CALL SFDER4(1, NDOFEL, 4, RII, SII, P)
        CALL JACOPER(4,XJ,XX,P)
	    DETJAC= (XJ(1,1)*XJ(2,2)-XJ(1,2)*XJ(2,1))
	    CALL SHAPEF4DASH(AUXT, RII, SII, KINC)

	  	RLL= MATMUL(AUXT, DDSDDE)
	  	AUX= TRANSPOSE(AUXT)
	  	RL= MATMUL(RLL, AUX)
        AMATRX=AMATRX-RL*ALF*DETJAC
      END DO

      CALL MAVEC(AMATRX,NDOFEL,NDOFEL,V,RHS)

      RETURN

      END

CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C23456789012345678901234567890123456789012345678901234567890123456789012
C                                                                      C
C    SUBROUTINE UELEDASHINC(RHS,ANMASS,NDOFEL,PROPS,NPROPS,IPROPS,NIPROPS,C
C    1                    COORDS,MCRD,NNODE,U,DU,V,JELEM,DT)           C
C                                                                      C
C    TRANSMITING DASHPOT ELEMENT USED TO EXCITATE THE BASE OF          C
C    A MODEL WITH A SV WAVE WITH VERTICAL INCIDENCE                    C
C                                                                      C
C23456789012345678901234567890123456789012345678901234567890123456789012
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC

      SUBROUTINE UELDASHINC(RHS,ANMASS,NDOFEL,PROPS,NPROPS,IPROPS,
     1                      NIPROPS,AWAVE,IWAVE,COORDS,MCRD,NNODE,
     2                      U,DU,V,A,JELEM,DT,KINC,NINCR)

      IMPLICIT REAL*8(A-H,O-Z)

      PARAMETER (ZERO=0.D0,HALF=0.5D0,ONE=1.D0,TWO=2.D0,THREE=3.D0)

C     Parameter arrays from UEL.f

      DIMENSION RHS(NDOFEL),ANMASS(NDOFEL),PROPS(NPROPS),
     1          IPROPS(NIPROPS),AWAVE(5),COORDS(MCRD,NNODE),
     2          U(NDOFEL),DU(NDOFEL),V(NDOFEL),
     3          AMATRX(NDOFEL,NDOFEL),DDSDDE(2,2),XGP(6),VIN(6),
     4          WGP(6),AUX(2,6),AUXT(6,2),RL(6,6),RLL(6,2),A(NDOFEL)

      AMATRX=0.0D0
      VIN=0.0D0
      PPV=0.0D0

C     Wave propagation velocities

      AALFA=PROPS(1)
      ABETA=PROPS(2)
      RO=PROPS(3)

C     Constitutive tensor

      DDSDDE(1,2)=0.0D0
      DDSDDE(2,1)=0.0D0
      DDSDDE(1,1)=RO*ABETA
      DDSDDE(2,2)=0.0D0

      XI=COORDS(1,1)
      XM=COORDS(1,2)
      XJ=COORDS(1,3)
      YI=COORDS(2,1)
      YM=COORDS(2,2)
      YJ=COORDS(2,3)
      DXS=(XI-XJ)**2
      DYS=(YI-YJ)**2
      DL=DSQRT(DXS+DYS)
      DETJAC=DL/2.0D0

      CALL GAUSS1D(XGP,WGP)

      DO N=1,6
        ETA =XGP(N)
        ALF=WGP(N)
        CALL SHAPE1D(AUXT,ETA)

        RLL=MATMUL(AUXT,DDSDDE)
        AUX=TRANSPOSE(AUXT)
        RL=MATMUL(RLL,AUX)

        AMATRX=AMATRX-RL*ALF*DETJAC
      END DO

      CALL UPULSEV(PPV,NINCR,DT,AWAVE,KINC)

      VIN(1)=PPV
      VIN(3)=PPV
      VIN(5)=PPV

      RHS=MATMUL(AMATRX,VIN)

      RETURN

      END

CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C23456789012345678901234567890123456789012345678901234567890123456789012
C                                                                      C
C    SUBROUTINE UELEDASH2(RHS,ANMASS,NDOFEL,PROPS,NPROPS,IPROPS,NIPROPS,C
C    1                    COORDS,MCRD,NNODE,U,DU,V,JELEM,DT)           C
C                                                                      C
C    ABSORBING DASHPOT ELEMENT                                         C
C                                                                      C
C                                                                      C
C23456789012345678901234567890123456789012345678901234567890123456789012
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC

      SUBROUTINE UELEDASH2(RHS,ANMASS,NDOFEL,PROPS,NPROPS,IPROPS,
     1                    NIPROPS,AWAVE,IWAVE,COORDS,MCRD,NNODE,
     2                    U,DU,V,A,JELEM,DT,KINC,NINCR)

      IMPLICIT REAL*8(A-H,O-Z)

      PARAMETER (ZERO=0.D0,HALF=0.5D0,ONE=1.D0,TWO=2.D0,THREE=3.D0)

C     Parameter arrays from UEL.f

      DIMENSION RHS(NDOFEL),ANMASS(NDOFEL),PROPS(NPROPS),
     1          IPROPS(NIPROPS),AWAVE(5),COORDS(MCRD,NNODE),U(NDOFEL),
     2          DU(NDOFEL),V(NDOFEL),AMATRX(NDOFEL,NDOFEL),DDSDDE(2,2),
     3          XGP(4),WGP(4),DDSDDET(2,2), DAUX(2,2),AUX(2,4),
     4          AUXT(4,2),RL(4,4),RLL(4,2),RM(2,2),RMT(2,2),A(NDOFEL)

      AMATRX=0.0D0

C     Wave propagation velocities

      AALFA=PROPS(1)
      ABETA=PROPS(2)
      RO=PROPS(3)

C     Constitutive tensor

      DDSDDE(1,2)=0.0D0
      DDSDDE(2,1)=0.0D0
      DDSDDE(1,1)=RO*AALFA
      DDSDDE(2,2)=RO*ABETA

      XI=COORDS(1,1)
      XM=COORDS(1,2)
      XJ=COORDS(1,3)
      YI=COORDS(2,1)
      YM=COORDS(2,2)
      YJ=COORDS(2,3)
      DXS=(XI-XJ)**2
      DYS=(YI-YJ)**2
      DL=DSQRT(DXS+DYS)
      DETJAC=DL/2.0

      CALL NORMVCT(XI,XJ,YI,YJ,CT,ST)
      RM(1,1)=  CT
      RM(1,2)=  ST
      RM(2,1)= -ST
      RM(2,2)=  CT

      RMT=TRANSPOSE(RM)
      DAUX=MATMUL(RMT,DDSDDE)
      DDSDDET=MATMUL(DAUX,RM)

      CALL GAUSS1D(XGP,WGP)

      DO N=1,4
        ETA =XGP(N)
        ALF=WGP(N)
        CALL SHAPE1D(AUXT,ETA)

        RLL=MATMUL(AUXT,DDSDDET)
        AUX=TRANSPOSE(AUXT)
        RL=MATMUL(RLL,AUX)

        AMATRX=AMATRX-RL*ALF*DETJAC
      END DO

      RHS=MATMUL(AMATRX,V)

      RETURN

      END
C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C23456789012345678901234567890123456789012345678901234567890123456789012
C                                                                      C
C  UEL3DEXP8.for                                                       C
C  8-NODED ISOPARAMETRIC 3D ELEMENT WITH FULL GAUSS INTEGRATION        C
C  USER ELEMENT SUBROUTINE FOR EXPLICIT DYNAMIC ANALYSIS               C
C                                                                      C
C  GIVEN THE DISPLACEMENT AT TIME T AND THE DISPLACEMENT INCREMENT     C
C  IT RETURNS IN THE RHS() VECTOR THE INERTIAL FORCE CONTRIBUTION      C
C  AT TIME T+DT AND IN THE ANMASS() VECTOR THE DIAGONALIZED MASS       C
C  MATRIX                                                              C
C                                                                      C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C23456789012345678901234567890123456789012345678901234567890123456789012

      SUBROUTINE UEL3DEXP8(RHS,ANMASS,NDOFEL,PROPS,NPROPS,IPROPS,
     1                   NIPROPS,AWAVE,IWAVE,COORDS,MCRD,NNODE,U,DU,
     2                   V,A,JELEM,DT,KINC,NINCR,INOD)

      IMPLICIT REAL*8(A-H,O-Z)

      PARAMETER (ZERO=0.D0,HALF=0.5D0,ONE=1.D0,NTENS=6,TWO=2.D0,
     1           NGPTS=8,THREE=3.D0, NDI=3)

C     Parameter arrays from UEL.f

      DIMENSION RHS(NDOFEL),ANMASS(NDOFEL),PROPS(NPROPS),
     1          IPROPS(NIPROPS),AWAVE(5),COORDS(MCRD,NNODE),U(NDOFEL),
     2          DU(NDOFEL),V(NDOFEL),A(NDOFEL),AMATRX(NDOFEL,NDOFEL),
     3          AMASS(NDOFEL,NDOFEL),CDMAT(NDOFEL,NDOFEL),UP(NDOFEL),
     4          DDSDDE(NTENS,NTENS),B(NTENS,NDOFEL),BT(NDOFEL,NTENS),
     5          FRST2(NDOFEL,NDOFEL),FRST1(NDOFEL,NDOFEL),XP(3,NGPTS),
     6          XW(NGPTS),AUX1(NTENS,NDOFEL)

C     Mass density.

      RO=PROPS(3)

C     Rayleigh damping parameters.

      AALFA=PROPS(1)
      ABETA=PROPS(2)

      RHS=0.0D0
      ANMASS=0.0D0
      DDSDDE=0.0D0
      B=0.0D0
      BT=0.0D0
      FRST2=0.0D0
      FRST1=0.0D0
      XP=0.0D0
      XW=0.0D0
      AUX1=0.0D0
      AMATRX=0.0D0
      AMASS=0.0D0
      CDMAT=0.0D0

C       Elasticity tensor.

	  CALL UMAT3D(DDSDDE,NDI,NTENS,PROPS,NPROPS)

C     Generates Gauss points and weights
C     and loops around all Gauss points.

      CALL GPOINTS3D2X2(XP,XW)
      NGPT=8
      SMS=0.0D0
      SMT=0.0D0

      DO NN=1,NGPT

        RII=XP(1,NN)
        SII=XP(2,NN)
        TII=XP(3,NN)
        ALF=XW(NN)

C       Computes B matrix.

        CALL STDM3D8(NNODE,NDOFEL,NTENS,COORDS,MCRD,B,DDET,RII,SII,
     1               TII,XBAR)

        SMT=SMT+RO*DDET*XBAR*ALF

C       Assembles stiffness and mass matrix.

        AUX1=MATMUL(DDSDDE,B)
        BT=TRANSPOSE(B)
        FRST1=MATMUL(BT,AUX1)
C
        CALL AMASS3D8(FRST2,NDOFEL,RII,SII,TII)

C       Considers Gauss weight and Jacobian determinant
C       into partial stiffness and mass matrix.

        FRST1=FRST1*(ALF*DDET*XBAR)
        FRST2=FRST2*(ALF*DDET*XBAR*RO)

C       Updates stiffness and mass matrix.

        AMATRX=AMATRX+FRST1
        AMASS=AMASS+FRST2

      END DO

C     Computes elastic,inertial and damping nodal forces.

      CALL EFFECTIVEFORCE(AMASS,AMATRX,ANMASS,NDOFEL,
     1                    AALFA,ABETA,U,V,A,DT,SMT,RHS,JELEM)

      RETURN

      END
C
C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C23456789012345678901234567890123456789012345678901234567890123456789012
C                                                                      C
C  UEL3DEXP8.for                                                       C
C  8-NODED ISOPARAMETRIC 3D ELEMENT WITH FULL GAUSS INTEGRATION        C
C  USER ELEMENT SUBROUTINE FOR EXPLICIT DYNAMIC ANALYSIS               C
C                                                                      C
C  GIVEN THE DISPLACEMENT AT TIME T AND THE DISPLACEMENT INCREMENT     C
C  IT RETURNS IN THE RHS() VECTOR THE INERTIAL FORCE CONTRIBUTION      C
C  AT TIME T+DT AND IN THE ANMASS() VECTOR THE DIAGONALIZED MASS       C
C  MATRIX                                                              C
C                                                                      C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C23456789012345678901234567890123456789012345678901234567890123456789012

      SUBROUTINE UEL3DWED10(RHS,ANMASS,NDOFEL,PROPS,NPROPS,IPROPS,
     1                   NIPROPS,AWAVE,IWAVE,COORDS,MCRD,NNODE,U,DU,
     2                   V,A,JELEM,DT,KINC,NINCR,INOD)

      IMPLICIT REAL*8(A-H,O-Z)

      PARAMETER (ZERO=0.D0,HALF=0.5D0,ONE=1.D0,NTENS=6,TWO=2.D0,
     1           NGPTS=8,THREE=3.D0, NDI=3)

C     Parameter arrays from UEL.f

      DIMENSION RHS(NDOFEL),ANMASS(NDOFEL),PROPS(NPROPS),
     1          IPROPS(NIPROPS),AWAVE(5),COORDS(MCRD,NNODE),U(NDOFEL),
     2          DU(NDOFEL),V(NDOFEL),A(NDOFEL),AMATRX(NDOFEL,NDOFEL),
     3          AMASS(NDOFEL,NDOFEL),CDMAT(NDOFEL,NDOFEL),UP(NDOFEL),
     4          DDSDDE(NTENS,NTENS),B(NTENS,NDOFEL),BT(NDOFEL,NTENS),
     5          FRST2(NDOFEL,NDOFEL),FRST1(NDOFEL,NDOFEL),XP(3,NGPTS),
     6          XW(NGPTS),AUX1(NTENS,NDOFEL)

C     Mass density.

      RO=PROPS(3)

C     Rayleigh damping parameters.

      AALFA=PROPS(1)
      ABETA=PROPS(2)

      CALL CLEARV(RHS,NDOFEL)
      CALL CLEARV(ANMASS,NDOFEL)
      CALL CLEAR(DDSDDE,NTENS,NTENS)
      CALL CLEAR(B,NTENS,NDOFEL)
      CALL CLEAR(BT,NDOFEL,NTENS)
      CALL CLEAR(FRST2,NDOFEL,NDOFEL)
      CALL CLEAR(FRST1,NDOFEL,NDOFEL)
      CALL CLEAR(XP,3,NGPTS)
      CALL CLEARV(XW,NGPTS)
      CALL CLEAR(AUX1,NTENS,NDOFEL)
      CALL CLEAR(AMATRX,NDOFEL,NDOFEL)
      CALL CLEAR(AMASS,NDOFEL,NDOFEL)
      CALL CLEAR(CDMAT,NDOFEL,NDOFEL)

C       Elasticity tensor.

	  CALL UMAT3D(DDSDDE,NDI,NTENS,PROPS,NPROPS)

C     Generates Gauss points and weights
C     and loops around all Gauss points.

      CALL GPOINTSW10(XP,XW)
      NGPT=8
      SMS=0.0D0
      SMT=0.0D0

      DO NN=1,NGPT

        RII=XP(1,NN)
        SII=XP(2,NN)
        TII=XP(3,NN)
        ALF=XW(NN)

C       Computes B matrix.
ccccccccc ESTA ES LA RUTINA CON EL PROBLEMA.
C       CALL STDM3D8(JELEM,NNODE,NDOFEL,NTENS,COORDS,MCRD,B,DDET,RII,SII,
        CALL STDM3D8(NNODE,NDOFEL,NTENS,COORDS,MCRD,B,DDET,RII,SII,
     1               TII,XBAR)

c	    CALL STDM9(NNODE,NDOFEL,NTENS,COORDS,MCRD,B,DDET,RII,SII,
c    1             XBAR)

        SMT=SMT+RO*DDET*XBAR*ALF

C       Assembles stiffness and mass matrix.

        CALL MMULT(DDSDDE,NTENS,NTENS,B,NTENS,NDOFEL,AUX1)
        CALL MTRAN(B,NTENS,NDOFEL,BT)
        CALL MMULT(BT,NDOFEL,NTENS,AUX1,NTENS,NDOFEL,FRST1)
C
C       CALL AMASS3D8(FRST2,NDOFEL,RII,SII)
        CALL AMASS3D8(FRST2,NDOFEL,RII,SII,TII)

C       Considers Gauss weight and Jacobian determinant
C       into partial stiffness and mass matrix.

        CALL SMULT(FRST1,NDOFEL,NDOFEL,ALF*DDET*XBAR)
        CALL SMULT(FRST2,NDOFEL,NDOFEL,ALF*DDET*XBAR*RO)

C       Updates stiffness and mass matrix.

        CALL UPDMAT(AMATRX,NDOFEL,NDOFEL,FRST1)
        CALL UPDMAT(AMASS ,NDOFEL,NDOFEL,FRST2)

      END DO

C     Computes elastic,inertial and damping nodal forces.

      CALL EFFECTIVEFORCE(AMASS,AMATRX,ANMASS,NDOFEL,
     1                    AALFA,ABETA,U,V,A,DT,SMT,RHS,JELEM)

      RETURN

      END
C
C23456789012345678901234567890123456789012345678901234567890123456789012
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C                                                                      C
C   SUBROUTINE EFFECTIVEFORCE(AMASS,AMATRX,ANMASS,NDOFEL,AALFA,ABETA,U,C
C    1                      DU,UP,DT,SMT,RHS)                          C
C                                                                      C
C   Diagonalizes the mass matrix and computes the strain and inertial  C
C   force contributions                                                C
C                                                                      C
C   AMASS(,)     :Mass matrix output in diagaonal form                 C
C   AMATRX(,)    :Stiffness matrix                                     C
C   ANMASS()     :Diagonalized mass matrix in vector form              C
C   CDMAT(,)     :Rayleigh damping matrix                              C
C   NDOFEL       :Nodal D.O.F per element                              C
C   AALFA        :Rayleigh damping parameter                           C
C   ABETA        :Rayleigh damping parameter                           C
C   U()          :Nodal displacements vector at the current increment  C
C   DU()         :Nodal incremental displacements vector               C
C   UM()         :Nodal displacements vector at the previous increment C
C   DT           :Time increment                                       C
C   SMT          :Total element mass                                   C
C   RHS()        :Right Hand Side vector                               C
C   JELEM        :Element identifier                                   C
C                                                                      C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C23456789012345678901234567890123456789012345678901234567890123456789012

      SUBROUTINE EFFECTIVEFORCE(AMASS,AMATRX,ANMASS,NDOFEL,AALFA,
     1                          ABETA,U,V,A,DT,SMT,RHS,JELEM)

      IMPLICIT REAL*8(A-H,O-Z)

      DIMENSION AMATRX(NDOFEL,NDOFEL),AMASS(NDOFEL,NDOFEL),
     1          ANMASS(NDOFEL),U(NDOFEL),V(NDOFEL),A(NDOFEL),
     2          RSC(NDOFEL),RDC(NDOFEL),RIC(NDOFEL),RIM(NDOFEL),
     3          RSM(NDOFEL),RHS(NDOFEL)

C     Diagonalizes the mass matrix

      SMS=0.0D0
      DO I=1,NDOFEL
        SMS=SMS+AMASS(I,I)
      END DO
      DO I=1,NDOFEL
        ANMASS(I)=2.0*(AMASS(I,I)/SMS)*SMT
      END DO
C
      AMASS=0.0D0
      DO I=1,NDOFEL
        AMASS(I,I)=ANMASS(I)
      END DO

C     Forms the effective forces vector

      CALL MAVEC(AMATRX,NDOFEL,NDOFEL,U,RSC)    ! Elastic contribution
      CALL SMULTV(RSC,NDOFEL,-1.D0)
      CALL MAVEC(AMASS,NDOFEL,NDOFEL,A, RIC)    ! Inertial contribution
      CALL SMULTV(RIC,NDOFEL,-1.D0)

cc      CALL MAVEC(AMATRX,NDOFEL,NDOFEL,V,RDC)  ! Damping contribution
cc      CALL SMULTV(RDC,NDOFEL,-ABETA)
cc      CALL MAVEC(AMASS,NDOFEL,NDOFEL,V, RIM)
cc      CALL SMULTV(RIM,NDOFEL,-AALFA)

C     Puts everything into the RHS vector.

      CALL UPDVEC(RHS,NDOFEL,RSC)
      CALL UPDVEC(RHS,NDOFEL,RIC)
cc      CALL UPDVEC(RHS,NDOFEL,RDC)
cc      CALL UPDVEC(RHS,NDOFEL,RIM)

      RETURN

      END

C23456789012345678901234567890123456789012345678901234567890123456789012
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C                                                                      C
C   SUBROUTINE LINJAC(IDF,COORDS,MCRD,NNODE,IELCON,II,IM,IJ,DETJAC,    C
C    1                CT,ST)                                           C
C                                                                      C
C   Using the local connectivity array IELCON for an 8-noded 2D        C
C   element and the face ID computes the Jacobian for a 3-noded        C
C   1D-element and the outward normal vector.                          C
C                                                                      C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C23456789012345678901234567890123456789012345678901234567890123456789012

      SUBROUTINE LINJAC(IDF,COORDS,MCRD,NNODE,IELCON,II,IM,IJ,DETJAC,
     1                  XM,ZM,CT,ST)

      IMPLICIT REAL*8(A-H,O-Z)

      DIMENSION COORDS(MCRD,NNODE),IELCON(4,3)

      CALL LOCIEL(IELCON)

      II=IELCON(IDF,1)
      IM=IELCON(IDF,3)
      IJ=IELCON(IDF,2)

      XI=COORDS(1,II)
      ZI=COORDS(2,II)
      XM=COORDS(1,IM)
      ZM=COORDS(2,IM)
      XJ=COORDS(1,IJ)
      ZJ=COORDS(2,IJ)
      DXS=(XI-XJ)**2
      DZS=(ZI-ZJ)**2
      DL=DSQRT(DXS+DZS)
      DETJAC=DL/2.0

      CALL NORMVCTINT(XI,XJ,ZI,ZJ,CT,ST)

      RETURN

      END

C23456789012345678901234567890123456789012345678901234567890123456789012
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C                                                                      C
C   SUBROUTINE ISOCART8(RR,COORDS,NDOFDIM,XX)                          C
C                                                                      C
C   RECOVERS THE PHYSICAL CARTESIAN COORDINATES OF A POINT             C
C   THAT BELONGS TO AN 8-NODED ELEMENT GIVEN ITS NATURAL COORDINATES   C
C                                                                      C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C23456789012345678901234567890123456789012345678901234567890123456789012

      SUBROUTINE ISOCART8(RR,COORDS,MCRD,NNODES,XX)

      IMPLICIT REAL*8(A-H,O-Z)

      DIMENSION RR(2),XX(2),COORDS(MCRD,NNODES),SN(8)

      R=RR(1)
      S=RR(2)
      CALL SHAPEF8(SN,R,S)

      XXX=0.0D0
      ZZZ=0.0D0
      DO JJ=1,8
        XXX=XXX+SN(JJ)*COORDS(1,JJ)
        ZZZ=ZZZ+SN(JJ)*COORDS(2,JJ)
      END DO

      XX(1)=XXX
      XX(2)=ZZZ

      RETURN

      END

C23456789012345678901234567890123456789012345678901234567890123456789012
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C                                                                      C
C   SUBROUTINE LOCASSEM(RHS,FF,II,IM,IJ)                               C
C                                                                      C
C   Assembles the surface force vector FF() into the elemental force   C
C   vector RHS() according to II,IM,IJ.                                C
C                                                                      C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C23456789012345678901234567890123456789012345678901234567890123456789012

      SUBROUTINE LOCASSEM(RHS,FF,II,IM,IJ)

      IMPLICIT REAL*8(A-H,O-Z)

      DIMENSION RHS(16),FF(6)

      RHS(2*II-1)=FF(1)
      RHS(2*II  )=FF(2)
      RHS(2*IM-1)=FF(5)
      RHS(2*IM  )=FF(6)
      RHS(2*IJ-1)=FF(3)
      RHS(2*IJ  )=FF(4)

      RETURN

      END

C23456789012345678901234567890123456789012345678901234567890123456789012
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C                                                                      C
C   SUBROUTINE RSETUP(IDF,RR)                                          C
C                                                                      C
C   According to IDF sets up the natural coordinates variation.        C
C                                                                      C
C                                                                      C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C23456789012345678901234567890123456789012345678901234567890123456789012

      SUBROUTINE RSETUP(IDF,RR,IIF)

      IMPLICIT REAL*8(A-H,O-Z)

      DIMENSION RR(2)

      SELECT CASE (IDF)
        CASE (1)
        RR(2)=-1.0
        IIF=1

        CASE (2)
        RR(1)= 1.0D0
        IIF=2

        CASE (3)
        RR(2)= 1.0D0
        IIF=1

        CASE (4)
        RR(1)=-1.0D0
        IIF=2

      END SELECT

      RETURN

      END


      subroutine qlbox11(Y,musq,Ires)
      implicit none
C  I^{\{D=4-2 \epsilon\}}_4(0,m_3^2,\pt^2,m_4^2;s_{12},s_{23};0,0,m_3^2,m_4^2)

c y11=
c [                              m3sq - s12                            ]
c [     0           0            ----------                0           ]
c [                                  2                                 ]
c [                                                                    ]
c [                                                    m4sq - s23      ]
c [     0           0                0                 ----------      ]
c [                                                        2           ]
c [                                                                    ]
c [ m3sq - s12                                    - p3sq + m4sq + m3sq ]
c [ ----------      0               m3sq          -------------------- ]
c [     2                                                  2           ]
c [                                                                    ]
c [             m4sq - s23  - p3sq + m4sq + m3sq                       ]
c [     0       ----------  --------------------          m4sq         ]
c [                 2                2                                 ]
      include 'qlconstants.f'
      integer iep
      logical qlzero
      double precision Y(4,4),p3sq,m3sq,m4sq,musq,
     . m3mu,m4mu,sibar,tabar,x43p,x43m,x43pm1,x43mm1,ieps2
      double complex wlogt,wlogs,qllnrat,Ires(-2:0),Intbit,
     . root,cln,ln43m,ln43p,ga43p,ga43pm1,ga43m,ga43mm1,rat2p,rat2m

      m3sq=Y(3,3)
      m4sq=Y(4,4)
      sibar=2d0*Y(1,3)
      tabar=2d0*Y(2,4)
      p3sq=-(2d0*Y(3,4)-Y(3,3)-Y(4,4))

      m3mu=sqrt(m3sq*musq)
      m4mu=sqrt(m4sq*musq)
      wlogt=qllnrat(tabar,m4mu)
      wlogs=qllnrat(sibar,m3mu)

C----evaluate gamma's for the case p3sq=0
      if (qlzero(p3sq)) then
      root=cone
      x43p=-one
      x43pm1=-one
      x43m=m3sq
      x43mm1=m4sq
      else
      root=dcmplx((p3sq+m3sq-m4sq)**2-4d0*m3sq*p3sq)
      root=sqrt(root)
      ga43p=  dcmplx(+p3sq+m3sq-m4sq)+root
      ga43pm1=dcmplx(-p3sq+m3sq-m4sq)+root
      ga43m=  dcmplx(+p3sq+m3sq-m4sq)-root
      ga43mm1=dcmplx(-p3sq+m3sq-m4sq)-root

      x43p=  -dreal(ga43p)
      x43pm1=-dreal(ga43pm1)
      x43m=   dreal(ga43m)
      x43mm1= dreal(ga43mm1)
      endif

C----deal with real roots
      if (qlzero(dimag(root))) then
      ln43p=qllnrat(x43p,x43pm1)
      ln43m=qllnrat(x43m,x43mm1)
      else
      call qlratgam(rat2p,rat2m,ieps2,p3sq,m4sq,m3sq)
      ln43p=cln(rat2p,ieps2)
      ln43m=cln(rat2m,ieps2)

      endif

      if (qlzero(p3sq)) then
      Intbit=-chalf*log(m3sq/m4sq)**2
      else
      Intbit=-chalf*(ln43p**2+ln43m**2)
      endif

      Ires(-2)=cone
      Ires(-1)=-wlogt-wlogs
      Ires( 0)=Intbit
     . +ctwo*wlogt*wlogs-dcmplx(0.5d0*pisq)
     . +dcmplx(0.25d0*log(m3sq/m4sq)**2)
      do iep=-2,0
      Ires(iep)=Ires(iep)/dcmplx(sibar*tabar)
      enddo
      return
      end


      double complex function D2six(k1,k2,k3,k4,k5,k6)
      implicit none
C----- six dimensional box corresponding to
C----- qlI4(s56,0d0,0d0,s34,s156,s12,mtsq,0d0,0d0,0d0,musq,e)
C----- multiplied by a factor of -C(0)/2
      include 'constants.f'
      include 'sprods_com.f'
      include 'masses.f'
      include 'scale.f'
      double complex qlI4,qlI3,IntC(4),IntD
      double precision s12,s34,s56,s134,s156,C(0:4),mtsq
      integer e,k1,k2,k3,k4,k5,k6
      mtsq=mt**2
      s12=s(k1,k2)
      s34=s(k3,k4)
      s56=s(k5,k6)
      s134=s(k1,k3)+s(k1,k4)+s(k3,k4)
      s156=s(k1,k5)+s(k1,k6)+s(k5,k6)

      C(1)=2d0/(mtsq-s156)
      C(2)=2d0*(s156-s34)/(s12*(mtsq-s156))
      C(3)=2d0*((s156+mtsq)*(s56+s34-s12)-2d0*s156*mtsq-2d0*s34*s56)
     & /(s12*(mtsq-s156)**2)
      C(4)=2d0*(s156-s56)/(s12*(mtsq-s156))
      C(0)=4d0*(s134*s156-s34*s56)/(s12*(mtsq-s156)**2)

      e=0
      IntC(1)=qlI3(0d0,0d0,s12,0d0,0d0,0d0,musq,e)   !C1
      IntC(2)=qlI3(0d0,s34,s156,0d0,0d0,mtsq,musq,e) !C5
      IntC(3)=qlI3(s12,s56,s34,0d0,0d0,mtsq,musq,e)  !C6
      IntC(4)=qlI3(0d0,s156,s56,0d0,0d0,mtsq,musq,e) !C4
      IntD=qlI4(s56,0d0,0d0,s34,s156,s12,mtsq,0d0,0d0,0d0,musq,e)
      D2six=0.5d0*(C(1)*IntC(1)+C(2)*IntC(2)+C(3)*IntC(3)+C(4)*IntC(4)
     & +2d0*IntD)

c---debug
C---real sixdim box
c      D2six=-(C(1)*IntC(1)+C(2)*IntC(2)+C(3)*IntC(3)+C(4)*IntC(4)
c     & +2d0*IntD)/C(0)
c---debug
      return
      end


c=======================================================================
c
c     subroutine RNLSX
c
c     Robust Non-Linear Least-Square Solver - Expert version
c
c------------------------------------------------------------------------
      SUBROUTINE RNLSX ( SIMEXT, mxpar, xini, dxmin, df1, epsabs,
     &                   mode, maxitr, maxsim, binf, bsup,
     &                   nobs, moyobs, covobs, skobs, spadim, grid,
     &                   liudat, iudata, ldudat, dudata, iwork, dwork,
     &                   xopt, fxopt, gxopt, lopt, glopt,
     &                   totitr, totsim, info )
c-----------------------------------------------------------------------
c
c     INPUT
c            SIMEXT : entry point of an external subroutine
c            mxpar  : number of parameters                       integer
c            xini   : initial solution + Lagrang.(mxpar+1)        double
c            dxmin  : precision param. + Lagrang.(mxpar+1)        double
c            df1    : estimation of the first decrease of the criter
c                     used if mode=1 computed if =<0
c                     must be nearly abs( f(xvar)-f(xopt) ) )     double
c            epsabs : precision stop test                         double
c            mode   : type of initialization                     integer
c                     = 1 : nothing to initialize
c            maxitr : maximum of iterations authorized           integer
c            maxsim : maximum of calls of simul authorized       integer
c                     3*maxitr if largely good
c            binf   : inferior bounds on parameters +Lagrang.,
c                     vector(mxpar+1)                             double
c            bsup   : superior bounds on parameters +Lagrang.,
c                     vector(mxpar+1)                             double
c            nobs   : number of functions (observations)         integer
c            moyobs : mean observations  vector(nobs)             double
c            covobs : covariance matrix of observations
c                     vectorized matrix(nobs*nobs)                double
c            skobs  : stress coefficient of observations          double
c            spadim : space dimension                            integer
c            grid   : grid     vector(nobs*spadim)                double
c            liudat : size of integer user data for SIMEXT       integer
c            iudata : integer user data for SIMEXT               integer
c                     vector(liudat)
c            ldudat : size of double prec. user data for SIMEXT  integer
c            dudata : double precision user data for SIMEXT       double
c                     vector(ldudat)
c
c     WORKSPACE
c            iwork  : vector( 2*mxopt + 6 + 12*nobs + liudat )   integer
c            dwork  : vector(  mxopt*(mxopt+13)/2                 double
c                            + nobs*(7*nobs+mxpar+spadim+33)
c                            + 2 + ldudat )
c                     with mxopt = mxpar + 1
c
c     OUTPUT
c            xopt   : optimal point (mxpar)                       double
c            fxopt  : function value at the minimum               double
c            gxopt  : gradient value at the minimum (mxpar)       double
c            lopt   : optimal Lagragian value                     double
c            glopt  : Lagrangian gradient value at optimal        double
c            totitr : total of iterations                        integer
c            totsim : total of calls (to simulator)              integer
c            info   : = 0 successful exit                        integer
c
c     CALL
c        INIRNLS : initial computing of RNLSX
c        YV      : copy a vector in a vector
c        YVI     : copy a vector of integers in a vector of integers
c        PMV     : computing M*V = vector
c                  ( M matrix(n*m), V vector(m), gives M*V vector(n) )
c        BFGSBOX : quasi-Newton optimizer with BFGS method
c                  Expert version
c        SIMRNLS : subroutine used by BFGS to compute the value of the
c                  function and its gradient
c
c-----------------------------------------------------------------------
c
c     SIMEXT SIGNATURE
c
c     INPUT
c            nfct   : number of functions                        integer
c            mxopt  : size of the vector solution                integer
c            xopt   : solution  vector(mxopt)                     double
c            spadim : space dimension                            integer
c            grid   : grid     vector(nfct*spadim)                double
c            liudat : size of integers data provided by the user integer
c            iusdat : integers user data provided by the user
c                     vector(liudat)                             integer
c            ldudat : size of doubles data provided by the user  integer
c            dusdat : doubles user data provided by the user
c                     vector(ldudat)                              double
c
c     OUTPUT
c            funct  : functions   vector(nfct)                    double
c            jacob  : jacobian    matrix(nfct*mx)                 double
c            info   : = 0 successful exit                        integer
c
c-----------------------------------------------------------------------
c
      IMPLICIT NONE
c
c     external functions
      EXTERNAL SIMEXT, SIMRNLS, YV, YVI, INIRNLS, BFGSBOX
c
c     arguments i/o
      INTEGER mxpar, mode, maxitr, maxsim, nobs, spadim, totitr, totsim,
     &        liudat, ldudat, info
      INTEGER iudata(*)
      DOUBLE PRECISION df1, epsabs, skobs
      DOUBLE PRECISION dudata(*), xini(*), dxmin(*), binf(*), bsup(*),
     &                 moyobs(*), grid(*), covobs(nobs,*),
     &                 xopt(*), fxopt, gxopt(*), lopt, glopt
c
c     workspaces
      INTEGER iwork(*)
      DOUBLE PRECISION dwork(*)
c
c     local variables
      INTEGER mxopt, piwbf, pnobs, pspad, pliu, pldu, pinfo, piwu,
     &        pdwbf, pwsnls, pwsext, piwini, pdwini, pbinf, pbsup,
     &        pdxmin, pgrid, psk, palpha, pbeta, pvp, prspec, prcov,
     &        pdwu, pxsol, pgrad, pxini
      DOUBLE PRECISION inilam, lplus, infini, eigmax
      PARAMETER ( inilam = 10.0, lplus = 0.7, infini = 1.E20 )
c
c-----------------------------------------------------------------------
c     initializations
      info  = 0
      fxopt = 0
      lopt  = 0
      glopt = 0
      mxopt = mxpar + 1
      CALL YV ( mxpar, xini, gxopt )
c
c     pointers for integer work space  : iwork
c     ----------------------------------------
      piwini = 1
c     piwini : pointer for INIRNLS who needs (12*nobs), so 12*nobs more
      piwbf  = piwini + 12*nobs
c     piwbf  : pointer for BFGSBOX who needs (2*mxopt + 1),
c              so (2*mxopt + 1) more
      pnobs  = piwbf + (2*mxopt + 1)
c     pnobs  : pointer for the number of functions, communication
c              with SIMEXT ( simulator of user )
      pspad  = pnobs + 1
c     pspad  : pointer for the space dimension
      pliu   = pspad + 1
c     pliu   : pointer for size of integers data provided by the user,
c              ( communication with SIMEXT, user simulator )
      pldu   = pliu + 1
c     pldu   : pointer for size of doubles data provided by the user,
c              ( communication with SIMEXT, user simulator )
      pinfo  = pldu + 1
c     pinfo  : pointer for info (errors of simnls)
      piwu   = pinfo + 1
c     piwu   : pointer for user SIMEXT workspace, so (liudat) more
c
c     Total size of iwork array = ( 2*mxopt + 6 + 12*nobs + liudat )
c
c     pointers for double precision work space  : dwork
c     -------------------------------------------------
      pxini = 1
c     pxsol : pointer for the optimal solution so (mxopt)
c
      pxsol = pxini + ( mxopt )
c     pxsol : pointer for the optimal solution so (mxopt)
c
      pbinf = pxsol + mxopt
c     pbinf : pointer for inferior bounds binf, so mxopt more
      pbsup = pbinf + mxopt
c     pbsup : pointer for superior bounds bsup, so mxopt more
      pdxmin = pbsup + ( mxopt )
c     pdxmin : pointer for superior bounds dxmin, so mxopt more
      pgrad = pdxmin + ( mxopt )
c     pgrad : pointer for the gradient so (mxopt)
c
      prcov = pgrad + ( mxopt )
c     prcov : pointer for the reverse covariance matrix,
c             so (nobs*nobs) more
      pdwini = prcov + nobs*nobs
c     pdwini: pointer for INIRNLS who needs nobs*(2*nobs+27),
c             so nobs*(2*nobs+27) more
c
      pdwbf = pdwini + nobs*(2*nobs+27)
c     pdwbf : pointer for BFGSBOX who needs ( mxopt*(mxopt+9)/2 )
c             so ( mxopt*(mxopt+9)/2 ) more
c
      pwsnls = pdwbf + mxopt*(mxopt+9)/2
c     pwsnls: pointer for internal workspace of SIMRNLS,
c             so (nobs*(3*nobs+mxpar+3)) more
      pwsext = pwsnls + nobs*(3*nobs+mxpar+4)
c     pwsext: pointer for workspace ( communication with SIMRNLS,
c             and SIMEXT ),
c             so ( nobs*(spadim+nobs+2) + 2 + ldudat ) more
      pgrid = pwsext
c     pgrid : pointer for grid matrix ( communication with SIMEXT,
c             user simulator ), so (nobs*spadim) more
      psk = pgrid + (nobs*spadim)
c     psk   : pointer for the stress coefficient k ( communication
c             with SIMRNLS, BFGSBOX simulator ), so 1 more
      palpha = psk + 1
c     palpha: pointer for the coefficient alpha ( communication
c             with SIMRNLS, BFGSBOX simulator ), so 1 more
      pbeta = palpha + 1
c     pbeta : pointer for the vector beta ( communication with SIMRNLS,
c             BFGSBOX simulator ), so (nobs) more
      pvp = pbeta + nobs
c     pvp   : pointer for the eigenvestors matrix ( communication
c             with SIMRNLS BFGSBOX simulator ), so (nobs*nobs) more
      prspec = pvp + nobs*nobs
c     prspec: pointer for eigenvalues reverse vector ( communication
c             with SIMRNLS, BFGSBOX simulator ), so nobs more
      pdwu = prspec + nobs
c     pdwu   : pointer for user SIMEXT workspace, so (ldudat) more
c
c     Total size of dwork array = nobs*nobs + nobs*(2*nobs+27)
c                               + mxopt*(mxopt+13)/2
c                               + nobs*(3*nobs+mxpar+4)
c                               + nobs*(spadim+nobs+2) + 2 + ldudat
c     = mxopt*(mxopt+17)/2 + nobs*(7*nobs+mxpar+spadim+33) + 2 + ldudat
c            with mxopt = mxpar + 1
c
c-----------------------------------------------------------------------
c
c     initial computing for SIMRNLS
      CALL INIRNLS ( nobs, moyobs, covobs, skobs,
     &               iwork(piwini), dwork(pdwini),
     &               dwork(palpha), dwork(pbeta), dwork(pvp),
     &               dwork(prspec), dwork(prcov), eigmax, info )
      IF ( info .LT. 0 ) RETURN
c
c     initialization of solution
      CALL YV ( mxpar, xini, dwork(pxini) )
c
c     initialization of lambda > eigmax + epsilon
      dwork(pxini+mxopt-1) = inilam*eigmax
      CALL YV (mxpar, binf, dwork(pbinf) )
      CALL YV (mxpar, bsup, dwork(pbsup) )
      CALL YV (mxpar, dxmin, dwork(pdxmin) )
      dwork(pbsup+mxpar) = infini
      dwork(pbinf+mxopt-1) = eigmax * ( 1 + lplus )
      dwork(pdxmin+mxopt-1) =  dwork(pdxmin+mxopt-2)
c
c     communication with SIMEXT (user simulator)
      iwork(pnobs) = nobs
      iwork(pspad) = spadim
      iwork(pliu)  = liudat
      iwork(pldu)  = ldudat
      iwork(pinfo) = 0
      CALL YV ( nobs*spadim, grid, dwork(pgrid) )
      CALL YV ( ldudat, dudata, dwork(pdwu) )
      CALL YVI ( liudat, iudata, iwork(piwu) )
      dwork(psk) = skobs
c
c     optimization BFGS-box
      CALL BFGSBOX ( SIMRNLS, SIMEXT, mxopt, dwork(pxini),
     &        dwork(pdxmin), df1, epsabs, mode, maxitr, maxsim,
     &        dwork(pbinf), dwork(pbsup), iwork(piwbf), dwork(pdwbf),
     &        dwork(pxsol), fxopt, dwork(pgrad), totitr, totsim, info )
c
c     optimal point
      CALL YV ( mxpar, dwork(pxsol), xopt )
c
c     optimal Lagrangian
      lopt = dwork(pxsol + mxopt)
c
c     gradient value at the minimum
      CALL YV ( mxpar, dwork(pgrad), gxopt )
      glopt = dwork(pgrad + mxopt)
c
c     error management
      IF (iwork(pinfo) .NE. 0) THEN
         info = iwork(pinfo)
         RETURN
      ENDIF
c
      RETURN
      END