!
!
!
!     perturb initial multidimensional model
!
!
!
subroutine perturb_ccp_two_layers

  implicit none
  include 'dimen.inc'
  include 'float.inc'
  include 'intgrs.inc'
  include 'physcs.inc'
  include 'vnew.inc'
  include 'mesh.inc'
  include 'constants.inc'
  include 'mpif.h'
  include 'mpicom.inc'

  integer*4 i, j, k     , ii
  real*8 vsound, phi, mag, r8rand
  real*8 x,y,z,prtb,rho0
  real*8 fheat(nx)

  if(ilog.eq.1) then
     print*,'MSG(perturb_ccp_two_layers): density/temp perturb_ccp_two_layersations in convection zone'
  endif

  pi = 4.d0*datan(1.d0)

  do i=1,nx
     x = xzn(i)/onelu
     if((x.ge.1.d0).and.(x.le.1.125d0)) then
        fheat(i) = sin(8.d0*pi*(x-1.d0))
     else
        fheat(i) = 0.d0
     endif
  enddo

  rho0 = 0.d0
  prtb = 0.d0

  ! LOOP OVER ALL ZONES
  do k = 1, qz
     do j = 1, qy
        do  i = 1, qx
           y = yzn(j)/onelu
           z = zzn(k)/onelu
           rho0 = densty(1,j,k)
           prtb = &
                0.00005d0*rho0*fheat(i)*((sin(3.d0*pi*y))+cos(pi*y))*(sin(3.d0*pi*z)-cos(pi*z))
           densty(i,j,k) = densty(i,j,k) + prtb
        enddo
     enddo
  enddo

  return

end subroutine perturb_ccp_two_layers


! This source file is part of the Limited-area GAME version (L-GAME), which is released under the MIT license.
! Github repository: https://github.com/OpenNWP/L-GAME

module manage_rkhevi

  ! In this file, the RKHEVI time stepping is managed.

  use definitions,                only: t_grid,t_state,t_diag,wp,t_tend
  use linear_combine_two_states,  only: lin_combination
  use run_nml,                    only: slow_fast_ratio,dtime,nlins,ncols
  use pressure_gradient,          only: manage_pressure_gradient
  use explicit_vector_tendencies, only: expl_vector_tend
  use thermodynamics,             only: spec_heat_cap_diagnostics_v, gas_constant_diagnostics
  use explicit_scalar_tendencies, only: expl_scalar_tend
  use column_solvers,             only: three_band_solver_ver
  use boundaries,                 only: bc

  implicit none

  private

  public :: rkhevi

  contains

  subroutine rkhevi(state_old,state_new,tend,grid,diag,total_step_counter)

    type(t_state),  intent(inout) :: state_old          ! the state at the old timestep
    type(t_state),  intent(inout) :: state_new          ! the state at the new timestep
    type(t_tend),   intent(inout) :: tend               ! the tendency
    type(t_grid),   intent(in)    :: grid               ! the grid of the model
    type(t_diag),   intent(inout) :: diag               ! diagnostic quantities
    integer,        intent(in)    :: total_step_counter ! time step counter

    ! local variables
    integer  :: rk_step          ! index of the Runge-Kutta step
    logical  :: slow_update_bool ! switch to determine if slow terms will be updated

    ! slow terms (momentum advection and diffusion) update switch
    slow_update_bool = .false.
    ! check if slow terms have to be updated
    if (mod(total_step_counter, slow_fast_ratio) == 0) then
      ! set the respective update switch to one
      slow_update_bool = .true.
    endif

    do rk_step = 1,2

      ! state_old remains unchanged the whole time.
      ! At rk_step == 1, it is state_old == state_new.

      ! 1.) Explicit component of the momentum equation.
      ! ------------------------------------------------
      ! Update of the pressure gradient.
      if (rk_step == 1) then
        call manage_pressure_gradient(state_new,diag,grid,total_step_counter==0)
      endif
      ! Only the horizontal momentum is a forward tendency.
      call expl_vector_tend(state_new,tend,diag,grid,slow_update_bool,rk_step,total_step_counter)
      ! time stepping for the horizontal momentum can be directly executed
      state_new%wind_u(2:nlins+1,2:ncols  ,:) = state_old%wind_u(2:nlins+1,2:ncols  ,:) + dtime*tend%wind_u(:,:,:)
      state_new%wind_v(2:nlins  ,2:ncols+1,:) = state_old%wind_v(2:nlins  ,2:ncols+1,:) + dtime*tend%wind_v(:,:,:)
      ! Horizontal velocity can be considered to be updated from now on.

      ! 2.) Explicit component of the generalized density equations.
      ! ------------------------------------------------------------
      call expl_scalar_tend(grid,state_new,tend,diag)

      ! 3.) implicit dynamic vertical solver
      ! ------------------------------------
      call three_band_solver_ver(state_old,state_new,tend,grid,rk_step)

    enddo

    ! calling the boundary conditions subroutine
    call bc()

  end subroutine rkhevi

end module manage_rkhevi


subroutine vis_bot(Nm,Nx,Ny,boundary,psi,vis_bott,boundaries)

implicit none

type boundary_grid
  real(8), allocatable,dimension (:,:,:) :: psi
  real(8), allocatable,dimension (:,:,:) :: chi
end type

integer, intent(in) :: boundary(4)
integer, intent(in) :: Nx,Ny,Nm
real(8), dimension(Nm,Nx,Ny), intent(in)  :: psi
real(8), dimension(Nm,Nx,Ny), intent(out) :: vis_bott
type(boundary_grid) :: boundaries(4)

integer :: i,j,m

vis_bott(:,:,:) = 0.d0

do m=1,Nm
 do i=2,Nx-1
  do j=2,Ny-1

   vis_bott(m,i,j) = psi(m,i+1,j)+psi(m,i-1,j) &
                   &+psi(m,i,j+1)+psi(m,i,j-1)-4.d0*psi(m,i,j)

  end do
 end do
end do

!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
! BOUNDARY VALUES -- necessary for the JACOBIAN !!!
! but note: if you only have first or second order derivatives (e.g., the Laplacian only),
! then free slip is your default boundary condition!!!!!!!!!!!!!!!!!!!!
! (Because you cannot prescribe the second velocity component.)
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
if( boundary(1) == 1) then
 ! nothing to do
else if( boundary(1) == 0) then
  do m=1,Nm
   vis_bott(m,1,:) = 2.d0*psi(m,2,:) ! : was 2:Ny-1 to fix boundary(2 or 3)==2 (otherwise psi will zero anyway)
  end do
else if(boundary(1) == 2) then
  do m=1,Nm
    i=1
    do j=2,Ny-1
     vis_bott(m,i,j) = psi(m,i+1,j)+boundaries(1)%psi(m,i-1,j) &
                     &+psi(m,i,j+1)+psi(m,i,j-1)-4.d0*psi(m,i,j)
    end do
    if(boundary(3)==2) then
      j=1
      vis_bott(m,i,j) = psi(m,i+1,j)+boundaries(1)%psi(m,i-1,j) &
                     &+psi(m,i,j+1)+boundaries(3)%psi(m,i,j-1)-4.d0*psi(m,i,j)
    endif
  enddo
endif

if( boundary(2) == 1) then
 ! nothing to do
else if( boundary(2) == 0) then
  do m=1,Nm
   vis_bott(m,Nx,:) = 2.d0*psi(m,Nx-1,:) ! : was 2:Ny-1
  end do
else if(boundary(2) == 2) then
  do m=1,Nm
    i=Nx
    do j=2,Ny-1
     vis_bott(m,i,j) = boundaries(2)%psi(m,i+1,j)+psi(m,i-1,j) &
                     &+psi(m,i,j+1)+psi(m,i,j-1)-4.d0*psi(m,i,j)
    end do
    if(boundary(4)==2) then
      j=Ny
      vis_bott(m,i,j) = boundaries(2)%psi(m,i+1,j)+psi(m,i-1,j) &
                     &+boundaries(4)%psi(m,i,j+1)+psi(m,i,j-1)-4.d0*psi(m,i,j)
    endif
  enddo
endif

if( boundary(3) == 1) then
 ! nothing to do
else if( boundary(3) == 0) then
  do m=1,Nm
   vis_bott(m,:,1) = 2.d0*psi(m,:,2) !: was 2:Nx-1
  end do
else if(boundary(3) == 2) then
  do m=1,Nm
    j=1
    do i=2,Nx-1
     vis_bott(m,i,j) = psi(m,i+1,j)+psi(m,i-1,j) &
                     &+psi(m,i,j+1)+boundaries(3)%psi(m,i,j-1)-4.d0*psi(m,i,j)
    end do
    if(boundary(2)==2) then
      i=Nx
      vis_bott(m,i,j) = boundaries(2)%psi(m,i+1,j)+psi(m,i-1,j) &
                     &+psi(m,i,j+1)+boundaries(3)%psi(m,i,j-1)-4.d0*psi(m,i,j)
    endif
  enddo
endif

if( boundary(4) == 1) then
 ! nothing to do
else if( boundary(4) == 0) then
  do m=1,Nm
   vis_bott(m,:,Ny) = 2.d0*psi(m,:,Ny-1) !: was 2:Nx-1
  end do
else if(boundary(4) == 2) then
  do m=1,Nm
    j=Ny
    do i=2,Nx-1
     vis_bott(m,i,j) = psi(m,i+1,j)+psi(m,i-1,j) &
                     &+boundaries(4)%psi(m,i,j+1)+psi(m,i,j-1)-4.d0*psi(m,i,j)
    end do
    if(boundary(1)==2) then
      i=1
      vis_bott(m,i,j) = psi(m,i+1,j)+boundaries(1)%psi(m,i-1,j) &
                     &+boundaries(4)%psi(m,i,j+1)+psi(m,i,j-1)-4.d0*psi(m,i,j)
    endif
  enddo
endif

end


C    @(#)pkqk1.f	20.3 2/13/96
      subroutine pkqk1 (kt, ls, ybr, ai)

      integer kt, ls, mt
      double precision ybr, ai

      dimension ybr(3,*), ai(*)

      include 'ipfinc/parametr.inc'

      include 'ipfinc/alpha.inc'
c	Global variables used:
c		inetr(r*8), ineti(r*8), pnetu(r*8), qnetu(r*8)
      include 'ipfinc/bus.inc'
c	Global variables used:
c		e(r*8), f(r*8)
      include 'ipfinc/intbus.inc'
c	Global variables used:
c		intbus, intbas
      include 'ipfinc/prt.inc'
c	Global variables used:
c		errbuf
      include 'ipfinc/slnopt.inc'
c	Global variables used:
c		option

      common /pkqkxx/ pk,qk
C
      double precision ek, fk, em, fm, gkm, bkm, aik, bik,
     &                 vk, ak, bk, pkd, qkd, dp, dq

c
c      integer
c
c      real
c
      ek = e(kt)
      fk = f(kt)
      aik = 0.0d0
      bik = 0.0d0
      do 100 l = 1,ls
         mt = ybr(1,l)
         if (mt.lt.0) go to 100
         em = e(mt)
         fm = f(mt)
         gkm = ybr(2,l)
         bkm = ybr(3,l)
         aik = aik + em*gkm - fm*bkm
         bik = bik + em*bkm + fm*gkm
  100 continue
      pk = sngl(ek*aik + fk*bik)
      qk = sngl(-ek*bik + fk*aik)
      vk = dsqrt (ek**2 + fk**2)
      ak = vk*inetr(kt)
      bk = -vk*ineti(kt)
      aik = ai(1) + ai(3) + ai(5)
      bik = ai(2) + ai(4) + ai(6)
      pkd = aik*ek + bik*fk
      qkd = aik*fk - bik*ek
      dp = pk + ak - pnetu(kt) - pkd
      dq = qk + bk - qnetu(kt) - qkd
      if (dp**2 + dq**2 .gt. option(4)**2) then
         write (errbuf(1),110) intbus(kt), intbas(kt)
  110    format(' Y-matrix injection error - bus ',a8,f7.1)
         write (errbuf(2),120) pnetu(kt), qnetu(kt), pkd, qkd
  120    format(' -- Original    =', 2e11.3, ' Distributed =',2e11.3)
         write (errbuf(3),130) ak, bk, pk, qk
  130    format(' -- Injected    =', 2e11.3, ' Calculated  =',2e11.3)
         write (errbuf(4),140) dp,dq
  140    format(' -- ERROR       =',2e11.3)
         call prterx ('W',4)
      endif
      return
      end


      SUBROUTINE MELBOW
C
C     THIS ROUTINE COMPUTES THE MASS MATRIX M(NPVT,NPVT) FOR AN ELBOW.
C
C     ECPT FOR THE ELBOW
C
C     ECPT( 1)  -  IELID        ELEMENT ID. NUMBER
C     ECPT( 2)  -  ISILNO(2)    * SCALAR INDEX NOS. OF THE GRID POINTS
C     ECPT( 3)  -    ...        *
C     ECPT( 9)  -  A            CROSS-SECTIONAL AREA
C     ECPT(13)  -  NSM          NON-STRUCTURAL MASS
C     ECPT(29)  -  R            RADIUS OF CURVATURE
C     ECPT(30)  -  BETAR        ANGLE FROM GA TO GB
C
      LOGICAL          HEAT
      INTEGER          IZ(1),EOR,CLSRW,CLSNRW,FROWIC,TNROWS,OUTRW,BGGIND
      REAL             NSM
      DOUBLE PRECISION TA(9),TB(9),DP(6),VECI(3),DELA(6),DELB(6),FL,
     1                 M(36),DUMDP,FM
      DIMENSION        ECPT(9),IECPT(1)
      COMMON /SMA2HT/  HEAT
      COMMON /SMA2IO/  IFCSTM,IFMPT,IFDIT,IDUM1,IFECPT,IGECPT,IFGPCT,
     1                 IGGPCT,IDUM2,IDUM3,IFMGG,IGMGG,IFBGG,IGBGG,
     2                 IDUM4,IDUM5,INRW,OUTRW,CLSNRW,CLSRW,NEOR,EOR,
     3                 MCBMGG(7),MCBBGG(7)
      COMMON /ZZZZZZ/  Z(1)
C
C     SMA2 VARIABLE CORE BOOKKEEPING PARAMETERS
C
      COMMON /SMA2BK/  ICSTM,NCSTM,IGPCT,NGPCT,IPOINT,NPOINT,I6X6M,
     1                 N6X6M,I6X6B,N6X6B
C
C     SMA2 PROGRAM CONTROL PARAMETERS
C
      COMMON /SMA2CL/  IOPT4,BGGIND,NPVT,LEFT,FROWIC,LROWIC,NROWSC,
     1                 TNROWS,JMAX,NLINKS,LINK(10),NOGO
C
C     ECPT COMMON BLOCK
C
      COMMON /SMA2ET/  IELID,ISILNO(2),SMALLV(3),ICSSV,IMATID,A,I1,I2,
     1                 FJ,NSM,FE,DUM(14),R,BETAR,DUMM(8),TEMPEL
C
C     SMA2 LOCAL VARIABLES
C
      COMMON /SMA2DP/  TA,TB,DP,VECI,DELA,DELB,FL,M,DUMDP
C
C     INPUT AND OUTPUT BLOCKS FOR SUBROUTINE MAT
C
      COMMON /MATIN /  MATIDC,MATFLG,ELTEMP,STRESS,SINTH,COSTH
      COMMON /HMTOUT/  CP
      COMMON /MATOUT/  RHO,PROP(8)
      EQUIVALENCE      (Z(1),IZ(1),DZ),(ECPT(1),IECPT(1),IELID)
      DATA    DCR   /  0.01745329/
C
C     COMPUTE LENGTH OF ELBOW, FL
C
      DP(1) = R
      DP(2) = BETAR
      DP(3) = DCR
      FL    = DP(1)*DP(2)*DP(3)
      IF (FL .EQ. 0.0D0) GO TO 200
      IF (HEAT) GO TO 300
C
C     GET RHO FROM MPT BY CALLING MAT
C
      MATIDC = IMATID
      MATFLG = 4
      ELTEMP = TEMPEL
      CALL MAT (ECPT(1))
      DO 40 I = 1,36
   40 M(I) = 0.0D0
      FM = 0.5*FL*(RHO*A + NSM)
C
C     PUT MASS IN M-ARRAY
C
      M(1)  = FM
      M(8)  = M(1)
      M(15) = M(1)
C
C     INSERT THE 6 X 6
C
      CALL SMA2B (M,NPVT,-1,IFMGG,DUMDP)
      RETURN
C
  200 CALL MESAGE (30,26,IECPT(1))
C
C     SET FLAG FOR FATAL ERROR WHILE ALLOWING ERROR MESSAGES TO
C     ACCUMULATE
C
      NOGO = 1
      RETURN
C
C     HEAT FORMULATION
C
C     GET CP USING -HMAT- ROUTINE.
C
  300 MATIDC = IMATID
      MATFLG = 4
      CALL HMAT (IELID)
      M(1) = FL*DBLE(ECPT(9))*DBLE(CP)/2.0D0
C
C     OUTPUT THE MASS FOR HEAT PROBLEM.
C
      CALL SMA2B (M(1),NPVT,NPVT,IFBGG,DUMDP)
      RETURN
      END


! Windowed Green function method matrices and functions
! without windowing
module WGFM_matrices_nowindowed
    use mpi
    use meshread_mod
    use tools
    implicit none

    real(8), parameter, private  :: pi = 4d0 * atan(1d0)
    complex(8), parameter, private :: iu = (0.0d0, 1.0d0)

contains
    ! Computes the WGFM matrices
    subroutine genWGFMMat(msh, k1, k2, ep1, ep2, mu1, mu2,  &
                          Z1, Z2, Z3, E)
        type(Mesh), intent(in) :: msh
        real(8), intent(in) :: k1, k2    ! Wavenumbers [1/m]
        real(8), intent(in) :: ep1, ep2  ! Permittivities [F/m]
        real(8), intent(in) :: mu1, mu2  ! Permeabilities [H/m]

        ! Operators
        complex(8), allocatable, intent(out) :: Z1(:,:)  ! mu2 * K2Mat - mu1 * K1Mat
        complex(8), allocatable, intent(out) :: Z2(:,:)  ! k2**2 * T2Mat - k1**2 * T1Mat)
        complex(8), allocatable, intent(out) :: Z3(:,:)  ! ep2 * K2Mat - ep1 * K1Mat
        complex(8), allocatable, optional, intent(out) :: E(:,:)  ! identity

        complex(8), allocatable :: Z1_bff(:,:)
        complex(8), allocatable :: Z2_bff(:,:)
        complex(8), allocatable :: Z3_bff(:,:)
        complex(8), allocatable :: E_bff(:,:)

        complex(8) :: K1Mat, K2Mat  ! MFIE operators entries
        complex(8) :: T21Mat        ! EFIE operator entries (k2*T2Mat-k1*T1Mat)
        real(8) :: qweight

        integer ::i,j,n,m,ii,jj
        integer :: nd_i(3),nd_j(3)
        integer :: edg_j(3),edg_i(3)
        integer :: opp_nod_j(3),opp_nod_i(3)
        real(8) :: p(3,3),q(3,3)
        real(8) :: n_j(3)
        integer, parameter :: nQ = 6     ! number of Gauss's quadrature points
        integer, parameter :: nSG = 6    ! number of Sauter-Schwab's quadrature points
        real(8) :: qq(nQ,3),pp(nQ,3)
        real(8) :: V(nQ,3),wei(nQ)
        real(8) :: A_j,A_i,len_j(3),len_i(3)
        real(8) :: f_m(3), f_n(3), df_n, fm_cross(3)
        real(8) :: Rvec(3),R
        real(8) :: q_src_nod(3,3),p_src_nod(3,3)
        complex(8) :: G1, G2, Gp1, Gp2, Ggrad1(3), Ggrad2(3)
        integer :: start, finish , ierr,id
        integer :: pos(3, 2), cnt
        complex(8) :: intg(3, 3)

        ! for parallelization
        call divide_work(start, finish, msh%nbELm)

        ! allocate buffer matrix
        allocate(Z1_bff(1:msh%nbEdg, 1:msh%nbEdg))
        allocate(Z2_bff(1:msh%nbEdg, 1:msh%nbEdg))
        allocate(Z3_bff(1:msh%nbEdg, 1:msh%nbEdg))
        Z1_bff=0.0d0
        Z2_bff=0.0d0
        Z3_bff=0.0d0

        if (present(E)) then
            allocate(E_bff(1:msh%nbEdg, 1:msh%nbEdg))
            E_bff = 0.0d0
        endif

        call gaussQuadratureTriangles(V, wei, nQ)

        do j = start, finish ! loop over the elements
            nd_j      = msh%ELE_NODES(j,1:3)  ! node indices
            edg_j     = msh%ELE_EDGES(j,1:3)  ! edge indices
            opp_nod_j = msh%ELE_EDGES(j,4:6)  ! index of the node opposed to the edge
            len_j     = msh%EDG_LEN(edg_j)    ! length of the edges
            A_j       = msh%A(j)              ! area of the triangle
            n_j = msh%NRM(j,:) ! normal to i-th element

            q  = msh%POS(nd_j,1:3) ! coordinates of the triangular nodes
            q_src_nod  = msh%POS(abs(opp_nod_j),1:3)
            qq = matmul(V,q)

            do i = 1, msh%nbElm ! loop over the elements to compute inner integral
                nd_i      = msh%ELE_NODES(i,1:3) ! node indices
                edg_i     = msh%ELE_EDGES(i,1:3)  ! edge indices
                opp_nod_i = msh%ELE_EDGES(i,4:6)  ! index of the node opposed to the edge
                len_i     = msh%EDG_LEN(edg_i)
                A_i       = msh%A(i)

                p = msh%POS(nd_i,1:3) ! mesh nodes in i-th element
                p_src_nod = msh%POS(abs(opp_nod_i),1:3) ! mesh nodes in i-th element
                pp = matmul(V,p)

                ! determine if the triangles are distinct,
                ! share a vertex, an edge or are the same
                call findIndices(cnt, pos, nd_j, nd_i)

                if (cnt == 3) then
                    ! if same triangle, compute EFIE with Sauter-Schwab
                    ! MFIE is not computed
                    call intSauterSchwabIdentical_RWG(intg,k1,k2,p,p_src_nod,len_i,A_i,opp_nod_i,n_j,nSG)
                    Z2_bff(edg_j,edg_i) = Z2_bff(edg_j,edg_i) + A_i*A_j*intg/pi  ! EFIE

                else if (cnt == 2) then
                    ! if shared edge, compute EFIE with Sauter-Schwab
                    ! MFIE is also computed later
                    call intSauterSchwabEdge_RWG(intg,k1,k2,pos,&
                                                 q,q_src_nod,len_j,A_j,opp_nod_j,&
                                                 p,p_src_nod,len_i,A_i,opp_nod_i, n_j, nSG)
                    Z2_bff(edg_j,edg_i) = Z2_bff(edg_j,edg_i) + A_i*A_j*intg/pi  ! EFIE

                else if (cnt == 1) then
                    ! if shared vertex, compute EFIE with Sauter-Schwab
                    ! MFIE is also computed later
                    call intSauterSchwabVertex_RWG(intg,k1,k2,pos,&
                                                   q,q_src_nod,len_j,A_j,opp_nod_j,&
                                                   p,p_src_nod,len_i,A_i,opp_nod_i,n_j, nSG)
                    Z2_bff(edg_j,edg_i) = Z2_bff(edg_j,edg_i) + A_i*A_j*intg/pi  ! EFIE
                end if

                if (cnt /= 3) then  ! not same triangle
                    do jj=1,nQ !quadrature exterior integration
                        do ii=1,nQ !quadrature interior integration
                            Rvec = qq(jj,:)-pp(ii,:)
                            R = sqrt(sum(Rvec*Rvec))
                            qweight = A_i*A_j*wei(jj)*wei(ii)  ! quadrature weight

                            G1 = exp(iu*k1*R)/R/(4.0d0*pi)
                            Gp1 = (iu*k1-1.0d0/R) * G1
                            G2 = exp(iu*k2*R)/R/(4.0d0*pi)
                            Gp2 = (iu*k2-1.0d0/R) * G2
                            Ggrad1 = Gp1 * Rvec/R
                            Ggrad2 = Gp2 * Rvec/R

                            do m=1,3 !basis functions exterior
                                f_m  = sign(1,opp_nod_j(m))*len_j(m)*(q_src_nod(m,:)-qq(jj,:))/(2.0d0*A_j)
                                fm_cross = cross(f_m, n_j)   ! RWG x n

                                do n=1,3 !basis functions interior
                                    f_n  = sign(1,opp_nod_i(n))*len_i(n)*(p_src_nod(n,:)-pp(ii,:))/(2.0d0*A_i)
                                    df_n = -sign(1,opp_nod_i(n))*len_i(n)/A_i

                                    ! compute MFIE matrix entries
                                    K1Mat = qweight * 1/R*sum(Rvec*(f_m*sum(f_n*n_j)-n_j*sum(f_n*f_m)))
                                    K2Mat = K1Mat * Gp2
                                    K1Mat = K1Mat * Gp1

                                    ! mu2 * K2Mat - mu1 * K1Mat
                                    Z1_bff(edg_j(m),edg_i(n)) = Z1_bff(edg_j(m),edg_i(n)) + mu2*K2Mat - mu1*K1Mat

                                    ! ep2 * K2Mat - ep1 * K1Mat
                                    Z3_bff(edg_j(m),edg_i(n)) = Z3_bff(edg_j(m),edg_i(n)) + ep2*K2Mat - ep1*K1Mat

                                    ! compute EFIE matrix entries
                                    ! only if they weren't computed before
                                    if (cnt == 0) then
                                        T21Mat = qweight * (sum(f_n*fm_cross)*(G2*k2**2-G1*k1**2) &
                                                 + df_n*sum(fm_cross*(Ggrad2-Ggrad1)))

                                        ! k2**2 * T2Mat - k1**2 * T1Mat
                                        Z2_bff(edg_j(m),edg_i(n)) = Z2_bff(edg_j(m),edg_i(n)) + T21Mat
                                    end if
                                enddo
                            enddo
                        enddo
                    enddo
                end if
            enddo
            if (present(E)) then
                do jj=1, nQ !quadrature exterior integration
                    do m=1,3 !basis functions exterior
                        f_m  = sign(1,opp_nod_j(m))*len_j(m)*(q_src_nod(m,:)-qq(jj,:))/(2.0d0*A_j)
                        do n=1,3 !basis functions interior
                            f_n  = sign(1,opp_nod_j(n))*len_j(n)*(q_src_nod(n,:)-qq(jj,:))/(2.0d0*A_j)
                            E_bff(edg_j(m),edg_j(n)) = E_bff(edg_j(m),edg_j(n)) + A_j*wei(jj)*sum(f_m*f_n)
                        enddo
                    enddo
                enddo
            endif
        enddo

        call mpi_comm_rank(MPI_COMM_WORLD,id,ierr)

        ! Assemble Z1 matrix in root process
        if (id==0) then
            allocate(Z1(1:msh%nbEdg,1:msh%nbEdg))
        endif
        call mpi_reduce(Z1_bff,Z1,msh%nbEdg**2, &
        MPI_double_complex,MPI_sum,0,MPI_comm_world,ierr)
        deallocate(Z1_bff)

        ! Assemble Z2 matrix in root process
        if (id==0) then
            allocate(Z2(1:msh%nbEdg,1:msh%nbEdg))
        endif
        call mpi_reduce(Z2_bff,Z2,msh%nbEdg**2, &
        MPI_double_complex,MPI_sum,0,MPI_comm_world,ierr)
        deallocate(Z2_bff)

        ! Assemble Z3 matrix in root process
        if (id==0) then
            allocate(Z3(1:msh%nbEdg,1:msh%nbEdg))
        endif
        call mpi_reduce(Z3_bff,Z3,msh%nbEdg**2, &
        MPI_double_complex,MPI_sum,0,MPI_comm_world,ierr)
        deallocate(Z3_bff)

        ! Assemble E matrix in root process
        if (present(E)) then
            if (id==0) then
                allocate(E(1:msh%nbEdg,1:msh%nbEdg))
            endif
            call mpi_reduce(E_bff,E,msh%nbEdg**2, &
            MPI_double_complex,MPI_sum,0,MPI_comm_world,ierr)
            deallocate(Z3_bff)
        endif
    end subroutine genWGFMMat

    ! Computes the WGFM potencials
    subroutine genWGFMPot(msh, xEvl, k1, k2, E1Pot, H1Pot, E2Pot, H2Pot)
        type(Mesh), intent(in) :: msh
        real(8), intent(in) :: xEvl(:, :)  ! [x1, x2, ..; y1, y2, ..; z1, z2, ..]
        real(8), intent(in) :: k1, k2      ! Wavenumbers [1/m]

        complex(8), allocatable, intent(out) :: E1Pot(:,:,:)
        complex(8), allocatable, intent(out) :: H1Pot(:,:,:)
        complex(8), allocatable, intent(out) :: E2Pot(:,:,:)
        complex(8), allocatable, intent(out) :: H2Pot(:,:,:)

        complex(8), allocatable :: E1Pot_bff(:,:,:)
        complex(8), allocatable :: H1Pot_bff(:,:,:)
        complex(8), allocatable :: E2Pot_bff(:,:,:)
        complex(8), allocatable :: H2Pot_bff(:,:,:)

        integer, parameter :: nQ = 6   ! number of quadrature points

        integer ::i,j,n,nd_i(3),ii
        integer :: edg_i(3),opp_nod_i(3)
        real(8) :: p(3,3),p_src_nod(3,3)
        real(8) :: A_i,len_i(3)
        real(8) :: f_n(3), df_n
        real(8) :: Rvec(3),R,x(3)
        complex(8) :: G1, Gp1, G2, Gp2
        integer :: start, finish , ierr,id
        real(8) :: wei(nQ), V(nQ,3), pp(nQ,3)
        real(8) :: qweight
        integer :: nEvl

        call gaussQuadratureTriangles(V, wei, nQ)

        ! Allocate buffer matrices
        nEvl = size(xEvl, 1)
        allocate(E1Pot_bff(1:nEvl, 1:msh%nbEdg, 3))
        allocate(H1Pot_bff(1:nEvl, 1:msh%nbEdg, 3))
        allocate(E2Pot_bff(1:nEvl, 1:msh%nbEdg, 3))
        allocate(H2Pot_bff(1:nEvl, 1:msh%nbEdg, 3))
        E1Pot_bff = 0.0d0
        H1Pot_bff = 0.0d0
        E2Pot_bff = 0.0d0
        H2Pot_bff = 0.0d0

        call divide_work(start, finish, nEvl)

        do j=start,finish
            x = xEvl(j,:)
            do i = 1, msh%nbElm
                nd_i      = msh%ELE_NODES(i,1:3)
                edg_i     = msh%ELE_EDGES(i,1:3)
                opp_nod_i = msh%ELE_EDGES(i,4:6)
                len_i     = msh%EDG_LEN(edg_i)
                A_i       = msh%A(i)

                p = msh%POS(nd_i,1:3)
                p_src_nod = msh%POS(abs(opp_nod_i),1:3)

                pp = matmul(V,p)

                do ii = 1,nQ
                    Rvec  = x-pp(ii,:)
                    R     = sqrt(sum(Rvec*Rvec))
                    G1 = exp(iu*k1*R)/R/(4.0d0*pi)
                    Gp1 = (iu*k1-1.0d0/R) * G1
                    G2 = exp(iu*k2*R)/R/(4.0d0*pi)
                    Gp2 = (iu*k2-1.0d0/R) * G2
                    qweight = wei(ii) * A_i

                    do n = 1, 3
                        f_n  = sign(1,opp_nod_i(n))*len_i(n)*(p_src_nod(n,:)-pp(ii,:))/(2.0d0*A_i)
                        df_n = -sign(1,opp_nod_i(n))*len_i(n)/A_i

                        E1Pot_bff(j,edg_i(n),:) = E1Pot_bff(j,edg_i(n),:) + qweight * (G1*f_n + 1d0/(k1**2)*Gp1*Rvec/R*df_n)
                        E2Pot_bff(j,edg_i(n),:) = E2Pot_bff(j,edg_i(n),:) + qweight * (G2*f_n + 1d0/(k2**2)*Gp2*Rvec/R*df_n)

                        H1Pot_bff(j,edg_i(n),:) = H1Pot_bff(j,edg_i(n),:) + qweight * Gp1/R*cross(Rvec,f_n)
                        H2Pot_bff(j,edg_i(n),:) = H2Pot_bff(j,edg_i(n),:) + qweight * Gp2/R*cross(Rvec,f_n)
                    enddo
                enddo
            enddo
        enddo

        call mpi_comm_rank(MPI_COMM_WORLD,id,ierr)

        ! Assemble E1Pot matrix in root process
        if (id==0) then
            allocate(E1Pot(nEvl, msh%nbEdg, 3))
        endif
        call mpi_reduce(E1Pot_bff, E1Pot, size(E1Pot_bff), &
        MPI_double_complex,MPI_sum,0,MPI_comm_world,ierr)
        deallocate(E1Pot_bff)

        ! Assemble E2Pot matrix in root process
        if (id==0) then
            allocate(E2Pot(nEvl, msh%nbEdg, 3))
        endif
        call mpi_reduce(E2Pot_bff, E2Pot, size(E2Pot_bff), &
        MPI_double_complex,MPI_sum,0,MPI_comm_world,ierr)
        deallocate(E2Pot_bff)

        ! Assemble H1Pot matrix in root process
        if (id==0) then
            allocate(H1Pot(nEvl, msh%nbEdg, 3))
        endif
        call mpi_reduce(H1Pot_bff, H1Pot, size(H1Pot_bff), &
        MPI_double_complex,MPI_sum,0,MPI_comm_world,ierr)
        deallocate(H1Pot_bff)

        ! Assemble H2Pot matrix in root process
        if (id==0) then
            allocate(H2Pot(nEvl, msh%nbEdg, 3))
        endif
        call mpi_reduce(H2Pot_bff, H2Pot, size(H2Pot_bff), &
        MPI_double_complex,MPI_sum,0,MPI_comm_world,ierr)
    end subroutine genWGFMPot

    !******************************************************************************!
    subroutine intSauterSchwabIdentical_RWG(intg, k1, k2, p, p_src, len_p, A, opp_nod, n_j, nQ)
      real(8),intent(in) :: k1, k2, p(3,3),p_src(3,3),len_p(3),A
      integer,intent(in) :: opp_nod(3),nQ
      real(8), intent(in) :: n_j(3)  ! normal to element
      complex(8),intent(out) :: intg(3,3)
      real(8) :: t(nq),w(nq)
      real(8) :: fO(3),fI(3),dfI
      real(8) :: x(3),y(3),x0(3),y0(3)
      integer :: n1,n2,n3,i,n,m,l
      real(8) :: eta1,eta2,eta3,xi,uO,vO,uI,vI
      real(8) :: R0, Rvec(3), R
      real(8) :: fO_cross(3)
      complex(8) :: G1, G2, Gd1, Gd2, Ker1(3,3), Ker2(3,3)
      ! !-------------------------------------------------------------------------!

      call gaussQuadrature(t,w,nQ)

      w = 0.5d0*w
      t = 0.5d0*(1.0d0+t)

      intg = 0.0d0

      do n1=1,nQ ! eta1
          eta1 = t(n1)
          do n2=1,nQ !eta2
              eta2 = t(n2)
              do n3=1,nQ !eta3
                  eta3 = t(n3)
                  do i=1,nQ ! xi
                      xi = t(i)
                      do l=1,6
                        if (l==1) then
                          uO = 1.0d0
                          vO = (1.0d0-eta1+eta1*eta2)
                          uI = (1.0d0-eta1*eta2*eta3)
                          vI = (1.0d0-eta1)
                        elseif (l==2) then
                          uO = (1.0d0-eta1*eta2*eta2)
                          vO = (1.0d0-eta1)
                          uI = 1.0d0
                          vI = (1.0d0-eta1+eta1*eta2)
                        elseif (l==3) then
                          uO = 1.0d0
                          vO = eta1*(1.0d0-eta2+eta2*eta3)
                          uI = (1.0d0-eta1*eta2)
                          vI = eta1*(1.0d0-eta2)
                        elseif (l==4) then
                          uO = (1.0d0-eta1*eta2)
                          vO = eta1*(1.0d0-eta2)
                          uI = 1.0d0
                          vI = eta1*(1.0d0-eta2+eta2*eta3)
                        elseif (l==5) then
                          uO = (1.0d0-eta1*eta2*eta3)
                          vO = eta1*(1.0d0-eta2*eta3)
                          uI = 1.0d0
                          vI = eta1*(1.0d0-eta2)
                        elseif (l==6) then
                          uO = 1.0d0
                          vO = eta1*(1.0d0-eta2)
                          uI = (1.0d0-eta1*eta2*eta3)
                          vI = eta1*(1.0d0-eta2*eta3)
                        endif

                        x =  param(xi*uO,xi*vO,p(1,:),p(2,:),p(3,:))
                        y =  param(xi*uI,xi*vI,p(1,:),p(2,:),p(3,:))
                        Rvec = x - y

                        x0 =  param(uO,vO,p(1,:),p(2,:),p(3,:))
                        y0 =  param(uI,vI,p(1,:),p(2,:),p(3,:))

                        do n=1,3
                          fO = sign(1,opp_nod(n))*len_p(n)*(p_src(n,:)-x)/(2.0d0*A)
                          fO_cross = cross(fO, n_j)
                          do m=1,3
                            fI = sign(1,opp_nod(m))*len_p(m)*(p_src(m,:)-y)/(2.0d0*A)
                            dfI = -sign(1,opp_nod(m))*len_p(m)/A

                            Ker1(n,m) = sum(fI*fO_cross)
                            Ker2(n,m) = sum(Rvec*fO_cross)*dfI
                          enddo
                        enddo

                        R0 = sqrt(sum((x0-y0)**2))
                        R = sqrt(sum(Rvec**2))

                        G1 = exp(iu*k1*R)/R0  ! doesn't include jacobian (xi**3)
                        G2 = exp(iu*k2*R)/R0  ! doesn't include jacobian (xi**3)

                        Gd1 = (iu*k1*xi-1d0/R0)*G1/R0  ! includes jacobian (xi**3)
                        Gd2 = (iu*k2*xi-1d0/R0)*G2/R0  ! includes jacobian (xi**3)

                        G1 = G1 * xi**2  ! includes jacobian
                        G2 = G2 * xi**2  ! includes jacobian

                        Ker1 = Ker1 * (G2*k2**2-G1*k1**2)
                        Ker2 = Ker2 * (Gd2 - Gd1)

                        intg = intg + eta1**2*eta2*w(n1)*w(n2)*w(n3)*w(i)*(Ker1 + Ker2)
                      enddo
                  enddo
              enddo
          enddo
      enddo
      return
    end subroutine intSauterSchwabIdentical_RWG
    !******************************************************************************!
    subroutine intSauterSchwabEdge_RWG(intg, k1, k2, pos, &
                            q, q_src, len_q, A_q, opp_nod_q, &
                            p, p_src, len_p, A_p, opp_nod_p, n_j, nQ)
      real(8),intent(in) :: q(3,3),p(3,3),q_src(3,3),p_src(3,3), k1, k2
      real(8),intent(in) :: A_q,A_p,len_q(3),len_p(3)
      integer,intent(in) :: pos(3,2),opp_nod_q(3),opp_nod_p(3),nQ
      real(8), intent(in) :: n_j(3)  ! normal to element
      complex(8),intent(out) :: intg(3,3)
      real(8) :: fO(3),fI(3),dfI
      real(8) :: x(3),y(3),x0(3),y0(3)
      integer :: n1,n2,n3,i,j,n,m,l
      real(8) :: eta1,eta2,eta3,xi,uO,vO,uI,vI
      integer :: nd_q(3),nd_p(3)
      complex(8) :: intgAux(3,3)
      real(8) :: qAux(3,3),pAux(3,3),q_srcAux(3,3),p_srcAux(3,3)
      real(8) :: len_qAux(3),len_pAux(3)
      integer :: opp_nod_qAux(3),opp_nod_pAux(3)
      real(8) :: t(nq),w(nq)
      real(8) :: R0, Rvec(3), R
      real(8) :: fO_cross(3)
      complex(8) :: G1, G2, Gd1, Gd2, Ker1(3,3), Ker2(3,3)

      !-------------------------------------------------------------------------!
      call gaussQuadrature(t,w,nQ)

      w = 0.5d0*w
      t = 0.5d0*(1.0d0+t)

      ! find the common edge first:
      nd_q(1:2) = pos(1:2,1)
      nd_p(1:2) = pos(1:2,2)

      if ((nd_q(1).ne.1).and.(nd_q(2).ne.1)) nd_q(3)=1
      if ((nd_q(1).ne.2).and.(nd_q(2).ne.2)) nd_q(3)=2
      if ((nd_q(1).ne.3).and.(nd_q(2).ne.3)) nd_q(3)=3

      if ((nd_p(1).ne.1).and.(nd_p(2).ne.1)) nd_p(3)=1
      if ((nd_p(1).ne.2).and.(nd_p(2).ne.2)) nd_p(3)=2
      if ((nd_p(1).ne.3).and.(nd_p(2).ne.3)) nd_p(3)=3

      pAux =p(nd_p,:)
      qAux =q(nd_q,:)
      p_srcAux = p_src(nd_p,:)
      q_srcAux = q_src(nd_q,:)
      opp_nod_pAux =opp_nod_p(nd_p)
      opp_nod_qAux =opp_nod_q(nd_q)

      len_pAux = len_p(nd_p)
      len_qAux = len_q(nd_q)

      !---------------------------
      intgAux = 0.0d0

      do n1=1,nQ ! eta1
          eta1 = t(n1)
          do n2=1,nQ !eta2
              eta2 = t(n2)
              do n3=1,nQ !eta3
                  eta3 = t(n3)
                  do i=1,nQ ! xi
                      xi = t(i)
                      do l=1,5
                      !----------------------------------------------------------
                        if (l==1) then
                          uO = 1.0d0
                          vO = eta1*eta3
                          uI = (1.0d0-eta1*eta2)
                          vI = eta1*(1.0d0-eta2)
                        elseif (l==2) then
                          uO = 1.0d0
                          vO = eta1
                          uI = (1.0d0-eta1*eta2*eta3)
                          vI = eta1*eta2*(1.0d0-eta3)
                        elseif (l==3) then
                          uO = (1.0d0-eta1*eta2)
                          vO = eta1*(1.0d0-eta2)
                          uI = 1.0d0
                          vI = eta1*eta2*eta3
                        elseif (l==4) then
                          uO = (1.0d0-eta1*eta2*eta3)
                          vO = eta1*eta2*(1.0d0-eta3)
                          uI = 1.0d0
                          vI = eta1
                        elseif (l==5) then
                          uO = (1.0d0-eta1*eta2*eta3)
                          vO = eta1*(1.0d0-eta2*eta3)
                          uI = 1.0d0
                          vI = eta1*eta2
                        endif

                        x =  param(xi*uO,xi*vO,qAux(1,:),qAux(2,:),qAux(3,:))
                        y =  param(xi*uI,xi*vI,pAux(1,:),pAux(2,:),pAux(3,:))
                        Rvec = x - y

                        x0 =  param(uO,vO,qAux(1,:),qAux(2,:),qAux(3,:))
                        y0 =  param(uI,vI,pAux(1,:),pAux(2,:),pAux(3,:))

                        do n=1,3

                          fO = sign(1,opp_nod_qAux(n))*len_qAux(n)*(q_srcAux(n,:)-x)/(2.0d0*A_q)
                          fO_cross = cross(fO, n_j)

                          do m=1,3

                            fI = sign(1,opp_nod_pAux(m))*len_pAux(m)*(p_srcAux(m,:)-y)/(2.0d0*A_p)
                            dfI = -sign(1,opp_nod_pAux(m))*len_pAux(m)/A_p

                            Ker1(n,m) = sum(fI*fO_cross)
                            Ker2(n,m) = sum(Rvec*fO_cross)*dfI
                          enddo

                        enddo

                        R0 = sqrt(sum((x0-y0)**2))
                        R = sqrt(sum(Rvec**2))

                        G1 = exp(iu*k1*R)/R0  ! doesn't include jacobian (xi**3)
                        G2 = exp(iu*k2*R)/R0  ! doesn't include jacobian (xi**3)

                        Gd1 = (iu*k1*xi-1d0/R0)*G1/R0  ! includes jacobian (xi**3)
                        Gd2 = (iu*k2*xi-1d0/R0)*G2/R0  ! includes jacobian (xi**3)

                        G1 = G1 * xi**2  ! includes jacobian
                        G2 = G2 * xi**2  ! includes jacobian

                        Ker1 = Ker1 * (G2*k2**2-G1*k1**2)
                        Ker2 = Ker2 * (Gd2 - Gd1)

                        if (l==1) then
                          intgAux = intgAux + w(n1)*w(n2)*w(n3)*w(i)*eta1**2*(Ker1 + Ker2)
                        else
                          intgAux = intgAux + w(n1)*w(n2)*w(n3)*w(i)*eta1**2*eta2*(Ker1 + Ker2)
                        endif
                      enddo
                  enddo
              enddo
          enddo
      enddo

      do i=1,3
        do j=1,3
          intg(nd_q(i),nd_p(j)) = intgAux(i,j)
        enddo
      enddo

    end subroutine intSauterSchwabEdge_RWG

    !******************************************************************************!
    subroutine intSauterSchwabVertex_RWG(intg, k1, k2, pos, &
                            q, q_src, len_q, A_q, opp_nod_q, &
                            p, p_src, len_p, A_p, opp_nod_p, n_j, nQ)
      real(8),intent(in) :: q(3,3),p(3,3),q_src(3,3),p_src(3,3), k1, k2
      real(8),intent(in) :: A_q,A_p,len_q(3),len_p(3)
      integer,intent(in) :: pos(3,2),opp_nod_q(3),opp_nod_p(3),nQ
      real(8), intent(in) :: n_j(3)  ! normal to element
      complex(8),intent(out) :: intg(3,3)
      real(8) :: fO(3),fI(3),dfI
      real(8) :: x(3),y(3),x0(3),y0(3)
      integer :: n1,n2,n3,i,j,l0,m,n,l
      real(8) :: eta1,eta2,eta3,xi,uO,vO,uI,vI
      integer :: nd_q(3),nd_p(3)
      complex(8) :: intgAux(3,3)

      real(8) :: qAux(3,3),pAux(3,3),q_srcAux(3,3),p_srcAux(3,3)
      real(8) :: len_qAux(3),len_pAux(3)
      integer :: opp_nod_qAux(3),opp_nod_pAux(3)
      real(8) :: t(nq),w(nq)
      real(8) :: R0, Rvec(3), R
      real(8) :: fO_cross(3)
      complex(8) :: G1, G2, Gd1, Gd2, Ker1(3,3), Ker2(3,3)

      !-------------------------------------------------------------------------!
      call gaussQuadrature(t,w,nQ)

      w = 0.5d0*w
      t = 0.5d0*(1.0d0+t)

      ! find the common edge first:
      !pos(1,1) in q is pos(1,2) in p
      nd_q(1) = pos(1,1)
      l0 = mod(nd_q(1)+1,3)
      if (l0==0) l0=3
      nd_q(2) = l0
      l0 = mod(nd_q(1)+2,3)
      if (l0==0) l0=3
      nd_q(3) = l0

      nd_p(1) = pos(1,2)
      l0 = mod(nd_p(1)+1,3)
      if (l0==0) l0=3
      nd_p(2) = l0
      l0= mod(nd_p(1)+2,3)
      if (l0==0) l0=3
      nd_p(3) = l0

      pAux =p(nd_p,:)
      qAux =q(nd_q,:)
      p_srcAux = p_src(nd_p,:)
      q_srcAux = q_src(nd_q,:)
      opp_nod_pAux =opp_nod_p(nd_p)
      opp_nod_qAux =opp_nod_q(nd_q)

      len_pAux = len_p(nd_p)
      len_qAux = len_q(nd_q)
      !---------------------------
      intgAux = 0.0d0

      do n1=1,nQ ! eta1
          eta1 = t(n1)
          do n2=1,nQ !eta2
              eta2 = t(n2)
              do n3=1,nQ !eta3
                  eta3 = t(n3)
                  do i=1,nQ ! xi
                    xi = t(i)
                    do l=1,2
                      if (l==1) then
                        uO = 1.0d0
                        vO = eta1
                        uI = eta2
                        vI = eta2*eta3
                      elseif (l==2) then
                        uO = eta2
                        vO = eta2*eta3
                        uI = 1.0d0
                        vI = eta1
                      endif

                      x =  param(xi*uO,xi*vO,qAux(1,:),qAux(2,:),qAux(3,:))
                      y =  param(xi*uI,xi*vI,pAux(1,:),pAux(2,:),pAux(3,:))
                      Rvec = x - y

                      x0 =  param(uO,vO,qAux(1,:),qAux(2,:),qAux(3,:))
                      y0 =  param(uI,vI,pAux(1,:),pAux(2,:),pAux(3,:))

                      do n=1,3

                        fO = sign(1,opp_nod_qAux(n))*len_qAux(n)*(q_srcAux(n,:)-x)/(2.0d0*A_q)
                        fO_cross = cross(fO, n_j)

                        do m=1,3

                          fI = sign(1,opp_nod_pAux(m))*len_pAux(m)*(p_srcAux(m,:)-y)/(2.0d0*A_p)
                          dfI = -sign(1,opp_nod_pAux(m))*len_pAux(m)/A_p

                          Ker1(n,m) = sum(fI*fO_cross)
                          Ker2(n,m) = sum(Rvec*fO_cross)*dfI
                        enddo
                      enddo

                      R0 = sqrt(sum((x0-y0)**2))
                      R = sqrt(sum(Rvec**2))

                      G1 = exp(iu*k1*R)/R0  ! doesn't include jacobian (xi**3)
                      G2 = exp(iu*k2*R)/R0  ! doesn't include jacobian (xi**3)

                      Gd1 = (iu*k1*xi-1d0/R0)*G1/R0  ! includes jacobian (xi**3)
                      Gd2 = (iu*k2*xi-1d0/R0)*G2/R0  ! includes jacobian (xi**3)

                      G1 = G1 * xi**2  ! includes jacobian
                      G2 = G2 * xi**2  ! includes jacobian

                      Ker1 = Ker1 * (G2*k2**2-G1*k1**2)
                      Ker2 = Ker2 * (Gd2 - Gd1)

                      intgAux = intgAux + w(n1)*w(n2)*w(n3)*w(i)*eta2*(Ker1 + Ker2)
                    enddo
                  enddo
              enddo
          enddo
      enddo

      do i=1,3
        do j=1,3
          intg(nd_q(i),nd_p(j)) = intgAux(i,j)
        enddo
      enddo
      return
    end subroutine intSauterSchwabVertex_RWG
    !*****************************************************************************!
    subroutine findIndices(cnt, pos, indOut, indIn)
      ! cnt: number of vertices in common
      ! pos: coincident vertices
      integer :: pos(:,:),n,indOut(:),indIn(:)
      integer :: i,j,cnt

      n = size(indOut)
      cnt = 0
      pos = 0
      do i=1,n
        do j=1,n
          if (indOut(i)==indIn(j)) then
            cnt = cnt + 1
            pos(cnt,1)=i
            pos(cnt,2)=j
          endif
        end do
      enddo
      return
    end subroutine findIndices

    function  param(u, v, p1, p2, p3) result(x)
      real(8),intent(in) :: u,v,p1(3),p2(3),p3(3)
      real(8) :: x(3)
      x =p1+u*(p2-p1)+v*(p3-p2)
    end function  param

end module


      double precision function ovdot(p1,p2)
      implicit none
      double precision p1(4),p2(4)
      ovdot=p1(4)*p2(4)-p1(1)*p2(1)-p1(2)*p2(2)-p1(3)*p2(3)
      return
      end


module RT_grid
use RT_memory
use cons
implicit none
public

public set_grid

contains

subroutine set_grid(grid,mpar,NH,N_XYZ)
type(grid_type) :: grid
type(mpi_type) :: mpar
real(kind=rkd), intent(in) :: NH
integer, intent(in) :: N_XYZ
real(kind=rkd) :: vx,vy,vz
real(kind=rkd) :: Xmin,Xmax,Ymax,Ymin,Zmin,Zmax
real(kind=rkd) :: v_exp
real(kind=rkd) :: temp1
real(kind=rkd) :: temp2
real(kind=rkd) :: temp3
real(kind=rkd) :: x,y,z
real(kind=rkd) :: pc
integer :: ix,iy,iz

!pc = 3.086d+18		! pc - cm

grid%N_XYZ = N_XYZ
grid%N_X = grid%N_XYZ
grid%N_Y = grid%N_XYZ
grid%N_Z = grid%N_XYZ

call shared_mem(grid%den, [grid%N_X,grid%N_Y,grid%N_Z], grid%w_den, mpar%h_rank, mpar%h_comm,ierr)
call shared_mem(grid%vx, [grid%N_X,grid%N_Y,grid%N_Z], grid%w_vx, mpar%h_rank, mpar%h_comm,ierr)
call shared_mem(grid%vy, [grid%N_X,grid%N_Y,grid%N_Z], grid%w_vy, mpar%h_rank, mpar%h_comm,ierr)
call shared_mem(grid%vz, [grid%N_X,grid%N_Y,grid%N_Z], grid%w_vz, mpar%h_rank, mpar%h_comm,ierr)
call shared_mem(grid%x, [grid%N_X+1], grid%w_x, mpar%h_rank, mpar%h_comm,ierr)
call shared_mem(grid%y, [grid%N_Y+1], grid%w_y, mpar%h_rank, mpar%h_comm,ierr)
call shared_mem(grid%z, [grid%N_Z+1], grid%w_z, mpar%h_rank, mpar%h_comm,ierr)

	grid%NH = NH	! column density [/cm^2]
	grid%Ri = 1.d0
	grid%Ro = 1.d0
	grid%H = 4.d0
!	v_exp = v  ! cm/s
	v_exp = 0.d5

if(mpar%h_rank .eq. master) then

grid%den = 0.d0
grid%X = 0.d0
grid%Y = 0.d0
grid%Z = 0.d0
grid%vx = 0.d0
grid%vy = 0.d0
grid%vz = 0.d0

	Xmax = grid%Ro
	Xmin = -grid%Ro
	do ix = 1,grid%N_X+1
	grid%X(ix) = Xmin + (Xmax - Xmin)*(ix-1)/(grid%N_X)
	enddo
	Ymax = grid%Ro
	Ymin = -grid%Ro
	do iy = 1,grid%N_Y+1
	grid%Y(iy) = Ymin + (Ymax - Ymin)*(iy-1)/(grid%N_Y)
	enddo
	Zmax = grid%Ro
	Zmin = -grid%Ro
	do iz = 1,grid%N_Z+1
	grid%Z(iz) = Zmin + (Zmax - Zmin)*(iz-1)/(grid%N_Z)
	enddo

	do ix = 1, grid%N_X
	x = (grid%X(ix) + grid%X(ix+1))/2.
	do iy = 1, grid%N_Y
	y = (grid%Y(iy) + grid%Y(iy+1))/2.
	do iz = 1, grid%N_Z
	z = (grid%Z(iz) + grid%Z(iz+1))/2.
	temp1 = sqrt(x**2 + y**2 + z**2)
!	temp2 = abs(z)

!	if(temp1 .gt. grid%Ri .and. temp1 .le. grid%Ro) then
	if(temp1 .le. grid%Ro) then
!	if(temp1 .gt. grid%Ri .and. temp1 .le. grid%Ro .and. temp2 .le. grid%H) then
	grid%den(ix,iy,iz) = grid%NH/grid%Ro
	grid%vx(ix,iy,iz) = (x/temp1)*v_exp
	grid%vy(ix,iy,iz) = (y/temp1)*v_exp
	grid%vz(ix,iy,iz) = (z/temp1)*v_exp
	endif

	enddo
	enddo
	enddo

endif

call MPI_BARRIER(mpar%h_comm,ierr)

end subroutine set_grid

end module RT_grid


      subroutine difrel(iter,iorb,v,ar,br,lmax,nr,a,b,r,rab,
     1 norb,no,lo,so,znuc,viod,viou,vid,viu,ev,rabkar,
     2 rabai,fa,fb,evi)
c
c  difrel integrates the relativistic Dirac equation
c  it finds the eigenvalue ev, the major and minor component
c  of the wavefunction, ar and br.  It uses an intial guess
c  for the eigenvalues from dsolv1
c
c  njtj  ***  modifications  ***
c    This routine has major modifications.
c    1)The data needed inside the loops has been calculated
c    outside the main loop(increases speed for non-opt
c    compiliers, i.e. dumb compiliers).
c    2)The predict/correct values are placed in an array.
c    Output is unchanged
c  njtj  ***  modifications  ***
c
c  njtj
c  ###  Cray conversions
c  ###    1)Comment out implicit double precision.
c  ###    2)Switch the 3 double precision parameter
c  ###      to single precision parameter statements.
c  ###  Cray conversions
c  njtj
c
c  njtj
c  &&&  Machine dependent Parameter
c  &&&    The value of expzer is machine dependent.
c  &&&    The user must switch in the correct value for
c  &&&    the machine in use from the list, or find
c  &&&    it for their machine.
c  &&&  Machine dependent Parameter
c  njtj
c
      implicit double precision (a-h,o-z)
c
      parameter (zero=0.D0,pnine=0.9D0,one=1.D0,ai=2*137.0360411D0)
      parameter (etol=-1.D-7)
Cray      parameter (zero=0.0,pnine=0.9,one=1.0,ai=2*137.0360411)
Cray      parameter (etol=-1.E-7)
c
c  Tolernce
c
      parameter (tol = 1.D-10,five=5.0D0)
Cray      parameter (tol = 1.E-10,five=5.0)
c
c  Integration coefficients
c
      parameter(abc1=190.1D0/72,abc2=-138.7D0/36,abc3=10.9D0/3,
     1 abc4=-63.7D0/36,abc5=25.1D0/72,amc0=25.1D0/72,amc1=32.3D0/36,
     2 amc2=-1.1D0/3,amc3=5.3D0/36,amc4=-1.9D0/72)
Cray      parameter(abc1=190.1/72,abc2=-138.7/36,abc3=10.9/3,
Cray     1 abc4=-63.7/36,abc5=25.1/72,amc0=25.1/72,amc1=32.3/36,
Cray     2 amc2=-1.1/3,amc3=5.3/36,amc4=-1.9/72)
c
      dimension v(nr),ar(nr),br(nr),r(nr),rab(nr),
     1 no(norb),lo(norb),so(norb),viod(lmax,nr),viou(lmax,nr),
     2 vid(nr),viu(nr),ev(norb),rabkar(nr),rabai(nr),
     3 fa(nr),fb(nr),evi(norb)
c
      dimension rs(5)
c
c------Machine dependent parameter-
c------Require exp(-2*expzer) to be within the range of the machine
c
      expzer = 3.7D2
cApollo      expzer = 3.7D2
cSun      expzer = 3.7D2
cVax      expzer = 44.D0
Cray      expzer = 2.8E3
c
      itmax = 100
      ai2 = ai * ai
      az = znuc/(2*ai)
      ka = lo(iorb)+1
      if (so(iorb) .lt. 0.1 .and. lo(iorb) .ne. 0) ka=-lo(iorb)
c
c  determine effective charge and vzero for startup of
c  outward integration
c  ar = r**s * (1  + a1 r + a2 r**2 + ... )
c  br = r**s * (b0 + b1 r + b2 r**2 + ... )
c  s = sqrt (ka**2 - az**2)    b0 = - az / (s + ka)
c  an = (az (v0 - e) a(n-1) - (s + n + ka) (v0 - e - ai**2) b(n-1))
c        / (n ai (2 s + n))
c  bn = ((v0 - e) a(n-1) - 2 znuc an ) / ( ai (s + n + ka))
c
      s = sqrt(ka*ka-az*az)
      if (ka .gt. 0) then
        b0 = -az/(s+ka)
      else
        b0 = (s-ka)/az
      endif
      if (so(iorb) .lt. 0.1) then
        vzero=vid(2)
      else
        vzero=viu(2)
      endif
c
c  njtj  ***  start major modification  ***
c    Loop data calculated only once.
c    Set ar() and br() to zero.
c
      do 1 j=1,nr
        ar(j) = zero
        br(j) = zero
 1    continue
      do 3 j=2,nr
        rabkar(j)=rab(j)*ka/r(j)
 3    continue
      do 4 j=2,nr
        rabai(j)=rab(j)/ai
 4    continue
      do 5 j=2,5
        rs(j)=r(j)**s
 5    continue
c
c  set the underflow trap, error from Berkeley version,
c  fixed by Troy Barbee, sqrt(expzer) should be expzer/2,
c  4/17/90.
c
      juflow=1
      do 42 j=2,nr
        if (s*abs(log(r(j))) .ge. expzer/2) juflow = j
 42   continue
c  njtj *** end major modification  ***
c
      emax = zero
      emin = -one*100000
      if (ev(iorb) .gt. emax) ev(iorb) = emax
 10   if (itmax .lt. 2) write(6,15) iorb,iter,ev(iorb),nodes
 15   format(' iorb =',i3,' iter =',i3,' ev =',e18.10,' nodes =',i2)
      if (itmax .eq. 0) return
      if (ev(iorb) .gt. zero) then
        write(6,1000)iorb
        call ext(620+iorb)
      endif
 1000 format(//,' error in difrel - ev(',i2,
     1 ') greater then v(infinty)')
c
c  Find practical infinity ninf and classical turning
c  point nctp for orbital.
c
      icount=0
 20   icount=icount+1
      do 22 j=nr,2,-1
        temp = v(j) - ev(iorb)
        if (temp .lt. zero) temp = zero
        if (r(j)*sqrt(temp) .lt. expzer) goto 23
 22   continue
 23   ninf=j
      nctp = ninf - 5
      do 25 j=2,ninf-5
        if (v(j) .lt. ev(iorb)) nctp = j
 25   continue
      if (ev(iorb) .ge. etol*100) nctp=ninf-5
      if (ev(iorb) .ge. etol) ev(iorb)=zero
      if (evi(iorb) .ne. zero) then
        ev(iorb)=evi(iorb)
        do 26 j=2,nr
          if (r(j) .lt. five) nctp=j
 26     continue
      endif
      if (nctp .le. 6) then
        ev(iorb) = pnine*ev(iorb)
        if (icount .gt. 100) then
          write(6,1010)iorb
          call ext(650+iorb)
        endif
        goto 20
      endif
 1010 format(//,'error in difrel - cannot find classical',
     1 /,'turning point in orbital ',i2)
c
c  Outward integration from 1 to nctp, startup.
c
      a1 = (az*(vzero-ev(iorb))-(s+1+ka)*(vzero-ev(iorb)-ai2)*b0)
     1   / (ai*(2*s+1))
      b1 = ((vzero-ev(iorb))-2*znuc*a1) / (ai*(s+1+ka))
      a2 = (az*(vzero-ev(iorb))*a1-(s+2+ka)*(vzero-ev(iorb)-ai2)*b1)
     1   / (2*ai*(2*s+2))
      b2 = ((vzero-ev(iorb))*a1-2*znuc*a2) / (ai*(s+2+ka))
      do 35 j=2,5
        ar(j) = rs(j) * (1 +(a1+a2*r(j))*r(j))
        br(j) = rs(j) * (b0+(b1+b2*r(j))*r(j))
 35   continue
      fa(1) = zero
      fb(1) = zero
      fa(2) = rabkar(2)*ar(2)+(ev(iorb)-v(2)+ai2)*br(2)*rabai(2)
      fb(2) = -rabkar(2)*br(2)-(ev(iorb)-v(2))*ar(2)*rabai(2)
      fa(3) = rabkar(3)*ar(3)+(ev(iorb)-v(3)+ai2)*br(3)*rabai(3)
      fb(3) = -rabkar(3)*br(3)-(ev(iorb)-v(3))*ar(3)*rabai(3)
      fa(4) = rabkar(4)*ar(4)+(ev(iorb)-v(4)+ai2)*br(4)*rabai(4)
      fb(4) = -rabkar(4)*br(4)-(ev(iorb)-v(4))*ar(4)*rabai(4)
      fa(5) = rabkar(5)*ar(5)+(ev(iorb)-v(5)+ai2)*br(5)*rabai(5)
      fb(5) = -rabkar(5)*br(5)-(ev(iorb)-v(5))*ar(5)*rabai(5)
c
c  Intergration loop.
c
      nodes = 0
      do 40 j=6,nctp
c
c  Predictor (Adams-Bashforth).
c
        evvai2=ev(iorb)-v(j)+ai2
        evv=ev(iorb)-v(j)
        arp = ar(j-1) + abc1*fa(j-1)+abc2*fa(j-2)+abc3*fa(j-3)
     1   +abc4*fa(j-4)+abc5*fa(j-5)
        brp = br(j-1) + abc1*fb(j-1)+abc2*fb(j-2)+abc3*fb(j-3)
     1   +abc4*fb(j-4)+abc5*fb(j-5)
        fa(j) = rabkar(j)*arp+evvai2*brp*rabai(j)
        fb(j) = -rabkar(j)*brp-evv*arp*rabai(j)
c
c  Corrector (Adams-Moulton).
c
        arc = ar(j-1) + amc0*fa(j)+amc1*fa(j-1)+amc2*fa(j-2)
     1   +amc3*fa(j-3)+amc4*fa(j-4)
        brc = br(j-1) + amc0*fb(j)+amc1*fb(j-1)+amc2*fb(j-2)
     1   +amc3*fb(j-3)+amc4*fb(j-4)
        faj = rabkar(j)*arc+evvai2*brc*rabai(j)
        fbj = -rabkar(j)*brc-evv*arc*rabai(j)
c
c  Error reduction step.
c
        ar(j) = arc + amc0*(faj-fa(j))
        br(j) = brc + amc0*(fbj-fb(j))
        fa(j) = rabkar(j)*ar(j)+evvai2*br(j)*rabai(j)
        fb(j) = -rabkar(j)*br(j)-evv*ar(j)*rabai(j)
c
c  Count nodes - if no underflow.
c
        if(j.gt.juflow.and.ar(j)*ar(j-1).lt.zero)nodes=nodes+1
 40   continue
       arout = ar(nctp)
       arpout = fa(nctp)
c
c  End outward integration.
c  If number of nodes correct, start inward integration
c  else modify energy stepwise and try again.
c
      if (evi(iorb) .ne. zero) goto 111
      if (nodes .ne. no(iorb)-lo(iorb)-1) then
c
c  too many nodes decrease ev
c
        if (nodes .gt. no(iorb)-lo(iorb)-1) then
          if (ev(iorb) .lt. emax) emax = ev(iorb)
          ev(iorb) = ev(iorb) + ev(iorb)/10
c
c  too few nodes increase ev
c
        else
          if (ev(iorb) .gt. emin) emin = ev(iorb)
          ev(iorb) = ev(iorb) - ev(iorb)/10
        endif
        itmax = itmax-1
        goto 10
      endif
c
c  Inward integration from ninf to nctp startup.
c
      do 70 j=ninf,ninf-4,-1
        alf = v(j) - ev(iorb)
        if (alf .lt. zero) alf = zero
        alf = sqrt(alf)
        ar(j) = exp(-alf*r(j))
        br(j) = ai*(alf+ka/r(j))*ar(j)/(v(j)-ev(iorb)-ai2)
 70   continue
      fa(ninf) = rabkar(ninf)*ar(ninf)+
     1    (ev(iorb)-v(ninf)+ai2)*br(ninf)*rabai(ninf)
      fb(ninf) = -rabkar(ninf)*br(ninf)
     1    -(ev(iorb)-v(ninf))*ar(ninf)*rabai(ninf)
      fa(ninf-1) = rabkar(ninf-1)*ar(ninf-1)+
     1    (ev(iorb)-v(ninf-1)+ai2)*br(ninf-1)*rabai(ninf-1)
      fb(ninf-1) = -rabkar(ninf-1)*br(ninf-1)
     1    -(ev(iorb)-v(ninf-1))*ar(ninf-1)*rabai(ninf-1)
      fa(ninf-2) = rabkar(ninf-2)*ar(ninf-2)
     1    +(ev(iorb)-v(ninf-2)+ai2)*br(ninf-2)*rabai(ninf-2)
      fb(ninf-2) = -rabkar(ninf-2)*br(ninf-2)
     1    -(ev(iorb)-v(ninf-2))*ar(ninf-2)*rabai(ninf-2)
      fa(ninf-3) = rabkar(ninf-3)*ar(ninf-3)
     1    +(ev(iorb)-v(ninf-3)+ai2)*br(ninf-3)*rabai(ninf-3)
      fb(ninf-3) = -rabkar(ninf-3)*br(ninf-3)
     1    -(ev(iorb)-v(ninf-3))*ar(ninf-3)*rabai(ninf-3)
      fa(ninf-4) = rabkar(ninf-4)*ar(ninf-4)
     1    +(ev(iorb)-v(ninf-4)+ai2)*br(ninf-4)*rabai(ninf-4)
      fb(ninf-4) = -rabkar(ninf-4)*br(ninf-4)
     1    -(ev(iorb)-v(ninf-4))*ar(ninf-4)*rabai(ninf-4)
c
c  Integration loop.
c
      istop = ninf-nctp
      if (istop .lt. 5) goto 222
      do 80 j=ninf-5,nctp,-1
c
c  Predictor (Adams-Bashforth).
c
        evvai2=ev(iorb)-v(j)+ai2
        evv=ev(iorb)-v(j)
        arp = ar(j+1)-(abc1*fa(j+1)+abc2*fa(j+2)+abc3*fa(j+3)
     1   +abc4*fa(j+4)+abc5*fa(j+5))
        brp = br(j+1)-(abc1*fb(j+1)+abc2*fb(j+2)+abc3*fb(j+3)
     1   +abc4*fb(j+4)+abc5*fb(j+5))
        fa(j) = rabkar(j)*arp+evvai2*brp*rabai(j)
        fb(j) = -rabkar(j)*brp-evv*arp*rabai(j)
c
c  Corrector (Adams-Moulton).
c
        arc = ar(j+1)-(amc0*fa(j)+amc1*fa(j+1)+amc2*fa(j+2)
     1   +amc3*fa(j+3)+amc4*fa(j+4))
        brc = br(j+1)-(amc0*fb(j)+amc1*fb(j+1)+amc2*fb(j+2)
     1   +amc3*fb(j+3)+amc4*fb(j+4))
        faj = rabkar(j)*arc+evvai2*brc*rabai(j)
        fbj = -rabkar(j)*brc-evv*arc*rabai(j)
c
c  Error reduction step.
c
        ar(j) = arc + amc0*(faj-fa(j))
        br(j) = brc + amc0*(fbj-fb(j))
        fa(j) = rabkar(j)*ar(j)+evvai2*br(j)*rabai(j)
        fb(j) = -rabkar(j)*br(j)-evv*ar(j)*rabai(j)
 80   continue
 222  arin = ar(nctp)
      arpin = fa(nctp)
c
c  End inward integration
c  Rescale ar and br outside nctp to match ar(nctp) from
c  outward integration.
c
      factor = arout/arin
      do 90 j=nctp,ninf
        ar(j) = factor * ar(j)
        br(j) = factor * br(j)
 90   continue
      arpin = factor * arpin
c
c  Find the normalizing factor.
c
      factor = zero
      ll = 4
      do 100 j=2,ninf
        factor = factor + ll*(ar(j)*ar(j)+br(j)*br(j))*rab(j)
        ll = 6 - ll
 100  continue
      factor = factor / 3
c
c  Modify the eigenvalue ev.
c
      dev = arout * (arpout-arpin) / (factor * rab(nctp))
      if (5*abs(dev) .gt. -ev(iorb)) dev=sign(ev(iorb),dev)/5
      itmax = itmax-1
      evold = ev(iorb)
      ev(iorb) = ev(iorb) + dev
      if (ev(iorb) .gt. emax) then
        ev(iorb) = (evold + emax) / 2
      elseif (ev(iorb) .lt. emin) then
        ev(iorb) = (evold + emin) / 2
      endif
      if (abs(dev) .gt. tol*(1-ev(iorb))) goto 10
c
c  Normalize the wavefunction.
c
      factor = 1 / sqrt(factor)
      do 110 j=1,ninf
        ar(j) = factor*ar(j)
        br(j) = factor*br(j)
 110  continue
 111  continue
      if (evi(iorb) .ne. zero) then
        factor = zero
        ll = 4
        do 112 j=2,nctp
          factor = factor + ll*(ar(j)*ar(j)+br(j)*br(j))*rab(j)
          ll = 6 - ll
 112    continue
        factor = factor / 3
        factor = 1 / sqrt(factor)
        do 113 j=1,nctp
          ar(j) = factor*ar(j)
          br(j) = factor*br(j)
 113    continue
      endif
      return
      end


!
!     CalculiX - A 3-dimensional finite element program
!              Copyright (C) 1998-2015 Guido Dhondt
!
!     This program is free software; you can redistribute it and/or
!     modify it under the terms of the GNU General Public License as
!     published by the Free Software Foundation(version 2);
!
!
!     This program is distributed in the hope that it will be useful,
!     but WITHOUT ANY WARRANTY; without even the implied warranty of
!     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
!     GNU General Public License for more details.
!
!     You should have received a copy of the GNU General Public License
!     along with this program; if not, write to the Free Software
!     Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
!
      subroutine shape15w(xi,et,ze,xl,xsj,shp,iflag)
!
!     shape functions and derivatives for a 15-node quadratic
!     isoparametric wedge element. 0<=xi,et<=1,-1<=ze<=1,xi+et<=1.
!
!     iflag=1: calculate only the value of the shape functions
!     iflag=2: calculate the value of the shape functions and
!              the Jacobian determinant
!     iflag=3: calculate the value of the shape functions, the
!              value of their derivatives w.r.t. the global
!              coordinates and the Jacobian determinant
!
!
!     Copyright (c) 2003 WB
!
!     Written February 2003 on the basis of the Guido's shape function files
!
      implicit none
!
      integer i,j,k,iflag
!
      real*8 shp(4,15),xs(3,3),xsi(3,3),xl(3,15),sh(3)
!
      real*8 xi,et,ze,xsj,a
!
      intent(in) xi,et,ze,xl,iflag
!
      intent(out) shp,xsj
!
!     shape functions and their glocal derivatives
!
      a=1.d0-xi-et
!
!     shape functions
!
      shp(4, 1)=-0.5*a*(1.0-ze)*(2.0*xi+2.0*et+ze)
      shp(4, 2)=0.5*xi*(1.0-ze)*(2.0*xi-2.0-ze)
      shp(4, 3)=0.5*et*(1.0-ze)*(2.0*et-2.0-ze)
      shp(4, 4)=-0.5*a*(1.0+ze)*(2.0*xi+2.0*et-ze)
      shp(4, 5)=0.5*xi*(1.0+ze)*(2.0*xi-2.0+ze)
      shp(4, 6)=0.5*et*(1.0+ze)*(2.0*et-2.0+ze)
      shp(4, 7)=2.0*xi*a*(1.0-ze)
      shp(4, 8)=2.0*xi*et*(1.0-ze)
      shp(4, 9)=2.0*et*a*(1.0-ze)
      shp(4, 10)=2.0*xi*a*(1.0+ze)
      shp(4, 11)=2.0*xi*et*(1.0+ze)
      shp(4, 12)=2.0*et*a*(1.0+ze)
      shp(4, 13)= a*(1.0-ze*ze)
      shp(4, 14)=xi*(1.0-ze*ze)
      shp(4, 15)=et*(1.0-ze*ze)
!
      if(iflag.eq.1) return
!
!     local derivatives of the shape functions: xi-derivative
!
      shp(1, 1)=  0.5*(1.0-ze)*(4.0*xi+4.0*et+ze-2.0)
      shp(1, 2)=  0.5*(1.0-ze)*(4.0*xi-ze-2.0)
      shp(1, 3)=  0.d0
      shp(1, 4)=  0.5*(1.0+ze)*(4.0*xi+4.0*et-ze-2.0)
      shp(1, 5)=  0.5*(1.0+ze)*(4.0*xi+ze-2.0)
      shp(1, 6)=  0.d0
      shp(1, 7)=  2.0*(1.0-ze)*(1.0-2.0*xi-et)
      shp(1, 8)=  2.0*et*(1.0-ze)
      shp(1, 9)= -2.0*et*(1.0-ze)
      shp(1, 10)= 2.0*(1.0+ze)*(1.0-2.0*xi-et)
      shp(1, 11)= 2.0*et*(1.0+ze)
      shp(1, 12)= -2.0*et*(1.0+ze)
      shp(1, 13)= -(1.0-ze*ze)
      shp(1, 14)=  (1.0-ze*ze)
      shp(1, 15)=  0.d0
!
!     local derivatives of the shape functions: eta-derivative
!
      shp(2, 1)=  0.5*(1.0-ze)*(4.0*xi+4.0*et+ze-2.0)
      shp(2, 2)= 0.d0
      shp(2, 3)= 0.5*(1.0-ze)*(4.0*et-ze-2.0)
      shp(2, 4)= 0.5*(1.0+ze)*(4.0*xi+4.0*et-ze-2.0)
      shp(2, 5)= 0.d0
      shp(2, 6)= 0.5*(1.0+ze)*(4.0*et+ze-2.0)
      shp(2, 7)=-2.0*xi*(1.0-ze)
      shp(2, 8)= 2.0*xi*(1.0-ze)
      shp(2, 9)= 2.0*(1.0-ze)*(1.0-xi-2.0*et)
      shp(2, 10)=-2.0*xi*(1.0+ze)
      shp(2, 11)= 2.0*xi*(1.0+ze)
      shp(2, 12)= 2.0*(1.0+ze)*(1.0-xi-2.0*et)
      shp(2, 13)=-(1.0-ze*ze)
      shp(2, 14)= 0.0d0
      shp(2, 15)= (1.0-ze*ze)
!
!     local derivatives of the shape functions: zeta-derivative
!
      shp(3, 1)=  a*(xi+et+ze-0.5)
      shp(3, 2)= xi*(-xi+ze+0.5)
      shp(3, 3)= et*(-et+ze+0.5)
      shp(3, 4)=  a*(-xi-et+ze+0.5)
      shp(3, 5)= xi*(xi+ze-0.5)
      shp(3, 6)= et*(et+ze-0.5)
      shp(3, 7)= -2*xi*a
      shp(3, 8)= -2*xi*et
      shp(3, 9)= -2*et*a
      shp(3, 10)= 2*xi*a
      shp(3, 11)= 2*xi*et
      shp(3, 12)= 2*et*a
      shp(3, 13)=-2*a*ze
      shp(3, 14)=-2*xi*ze
      shp(3, 15)=-2*et*ze
!
!     computation of the local derivative of the global coordinates
!     (xs)
!
      do i=1,3
        do j=1,3
          xs(i,j)=0.d0
          do k=1,15
            xs(i,j)=xs(i,j)+xl(i,k)*shp(j,k)
          enddo
        enddo
      enddo
!
!     computation of the jacobian determinant
!
      xsj=xs(1,1)*(xs(2,2)*xs(3,3)-xs(2,3)*xs(3,2))
     &   -xs(1,2)*(xs(2,1)*xs(3,3)-xs(2,3)*xs(3,1))
     &   +xs(1,3)*(xs(2,1)*xs(3,2)-xs(2,2)*xs(3,1))
!
      if(iflag.eq.2) return
!
!     computation of the global derivative of the local coordinates
!     (xsi) (inversion of xs)
!
      xsi(1,1)=(xs(2,2)*xs(3,3)-xs(3,2)*xs(2,3))/xsj
      xsi(1,2)=(xs(1,3)*xs(3,2)-xs(1,2)*xs(3,3))/xsj
      xsi(1,3)=(xs(1,2)*xs(2,3)-xs(2,2)*xs(1,3))/xsj
      xsi(2,1)=(xs(2,3)*xs(3,1)-xs(2,1)*xs(3,3))/xsj
      xsi(2,2)=(xs(1,1)*xs(3,3)-xs(3,1)*xs(1,3))/xsj
      xsi(2,3)=(xs(1,3)*xs(2,1)-xs(1,1)*xs(2,3))/xsj
      xsi(3,1)=(xs(2,1)*xs(3,2)-xs(3,1)*xs(2,2))/xsj
      xsi(3,2)=(xs(1,2)*xs(3,1)-xs(1,1)*xs(3,2))/xsj
      xsi(3,3)=(xs(1,1)*xs(2,2)-xs(2,1)*xs(1,2))/xsj
!
!     computation of the global derivatives of the shape functions
!
      do k=1,15
        do j=1,3
          sh(j)=shp(1,k)*xsi(1,j)+shp(2,k)*xsi(2,j)+shp(3,k)*xsi(3,j)
        enddo
        do j=1,3
          shp(j,k)=sh(j)
        enddo
      enddo
!
      return
      end


subroutine preparePointerTable ! pota
      use resultVars, only : Punto,nPts,allpoints,nZs,pota
      use debugstuff
      use glovars, only : verbose,PrintNum

      ! tabla con las coordenadas Z (sin repetir).
      implicit none
      real*8 :: ratioWL_bola
      integer :: i,j,iP
      logical :: nearby,esnueva
!      type(Punto), pointer :: PX
      integer, allocatable, dimension(:,:) :: auxpota

!     !#< r
!     bola = min(0.01_8*smallestWL,0.01_8)
!     bola = 0.1*smallestWL !#>
      ratioWL_bola = 0.01
      ! si es la primera vez que corre sólo agregamos los allpoints
!      if (firstTime) then
       if (verbose .ge. 4) write(PrintNum,'(a)') " ...generating pointer table"
       allocate(auxpota(npts,npts+2))
       auxpota = 0
       ! siempre agregamos el primer punto [ allpoints(1)% ]
       nZs = 1
       auxpota(1,1) = 1 !nXs allpoints
       auxpota(1,3) = 1 !4,5,6 ... allpoints -7,-8,-9 ... boupoints
       !         ^--- el (3) siempre está
       ! agregamos los demás sin repetir
       if (nPts>=2) then
       do iP = 2,nPts
         esnueva = .true.
         do i = 1,nZs
           if (nearby(allpoints(iP)%center%z, &
               allpoints(auxpota(i,3))%center%z,0.01_8)) then
             !agregar a coordenada Z existente
             auxpota(i,1) = 1 + auxpota(i,1)
             auxpota(i,auxpota(i,1) + 2) = iP
             esnueva = .false.
             exit
           end if
         end do
         if (esnueva) then
           !nueva coordenada Z
           nZs = nZs + 1
           auxpota(nZs,1) = 1
           auxpota(nZs,3) = iP
         end if
       end do
       end if
       j = maxval(auxpota(:,1))

       allocate(PoTa(nZs,2+j))
       Pota = auxpota(1:nZs,1:2+j)
       deallocate(auxpota)

      if (verbose .ge. 4) call showMNmatrixI(nZs,2+j,pota,"po_ta",6)
      if (verbose .ge. 4) print*, "out of preparePointerTable"
      end subroutine preparePointerTable

      function nearby(a,b,bola)
      implicit none
      real*8, intent(in) :: a,b,bola
      logical :: nearby
      nearby = .false.
      if ((b-bola .le. a) .and. (a .le. b+bola)) then
        nearby = .true.
      end if
!     print*, b-bola, "<=", a, "<=",b+bola ," :: ", nearby
      end function nearby


*     This is a modified version of the example on the Netlib,
*     which can be found at
*     http://www.netlib.org/scalapack/examples/sample_pdsyev_call.f

*     The license of the original one is the modified BSD license.
*     http://www.netlib.org/scalapack/LICENSE
*
      PROGRAM SAMPLE_PDSYEVD_CALL
*
*  -- ScaLAPACK routine (version 1.2) --
*     University of Tennessee, Knoxville, Oak Ridge National Laboratory,
*     and University of California, Berkeley.
*     May 10, 1996
*
*     This routine contains a sample call to PDSYEV.
*     When compiled and run, it produces output which can be
*     pasted directly into matlab.
*
      IMPLICIT NONE
*     .. Parameters ..
      INTEGER            N
      character(len=10) :: tmp_str
      integer arg_len, status
*     ..
*     .. Local Scalars ..
      INTEGER            IERR
      INTEGER            LWORK, LIWORK, LDA
      INTEGER            CONTEXT, I, INFO, MYCOL, MYROW,
     $                   NPCOL, NPROCS, NPROW
      INTEGER            BB, M_LOCAL, N_LOCAL
      DOUBLE PRECISION   INIT_TICK, GEN_TICK, DIAG_TICK, END_TICK
*     ..
*     .. Local Arrays ..
      INTEGER            DESC( 50 )
      DOUBLE PRECISION, pointer :: A(:,:),W(:),Z(:,:)
      DOUBLE PRECISION   TMP_WORK(1)
      INTEGER            TMP_IWORK(1)
      DOUBLE PRECISION, allocatable :: WORK(:)
      INTEGER, allocatable :: IWORK(:)
*     ..
*     .. External Subroutines ..
      EXTERNAL           BLACS_EXIT, BLACS_GET, BLACS_GRIDEXIT,
     $                   BLACS_GRIDINFO, BLACS_GRIDINIT, BLACS_PINFO,
     $                   BLACS_SETUP, DESCINIT,
     $                   PDSYEV
      INTEGER            NUMROC
*     ..
*     .. Executable Statements ..
*
*
*     Set up the problem
*
      include 'mpif.h'

      call mpi_init_thread( MPI_THREAD_MULTIPLE, i, ierr )
      print *,"MPI_THREAD_MULTIPLE=",  MPI_THREAD_MULTIPLE
      if (command_argument_count().eq.1) then
      call get_command_argument(1, tmp_str, arg_len, status)
      read(tmp_str, *) n
      else
      write(*,'(A)') "Error: argument dimension is needed"
      stop
      endif
      call mpi_barrier(mpi_comm_world, ierr)
      INIT_TICK = MPI_WTIME()
      call MPI_Comm_Size(mpi_comm_world,nprocs,ierr)
      NPROW = INT(SQRT(NPROCS + 0.5))
      DO WHILE ( (NPROW .ne. 1) .AND. (MOD(NPROCS,NPROW).ne.0) )
         NPROW = NPROW - 1
      ENDDO
      NPCOL = NPROCS / NPROW
*
*     Initialize a single BLACS context
*
      CALL BLACS_GET( -1, 0, CONTEXT )
      CALL BLACS_GRIDINIT( CONTEXT, 'R', NPROW, NPCOL )
      CALL BLACS_GRIDINFO( CONTEXT, NPROW, NPCOL, MYROW, MYCOL )
*
*     These are basic array descriptors
*
      call mpi_barrier(mpi_comm_world, ierr)
      GEN_TICK = MPI_WTIME()
      BB = 64
      M_LOCAL = NUMROC(N, BB, MYROW, 0, NPROW)
      N_LOCAL = NUMROC(N, BB, MYCOL, 0, NPCOL)
!      print*, "M_LOCAL=", M_LOCAL, " N_LOCAL=", N_LOCAL
      LDA = MAX(M_LOCAL, 1)
      allocate( A(M_LOCAL, N_LOCAL), Z(M_LOCAL, N_LOCAL), W(N) )
      CALL DESCINIT( DESC, N, N, BB, BB, 0, 0, CONTEXT, LDA, INFO )
      CALL MINIJ_MATRIX( N, A, DESC, INFO )
*      CALL PDLAPRNT( N, N, A, 1, 1, DESC, 0, 0, 'A', 6, PRNWORK )
*
*     Ask PDSYEV to compute the entire eigendecomposition
*
      call mpi_barrier(mpi_comm_world, ierr)
      DIAG_TICK = MPI_WTIME()
      CALL PDSYEVD( 'V', 'U', N, A, 1, 1, DESC, W, Z, 1, 1,
     $             DESC, TMP_WORK, -1, TMP_IWORK, -1, INFO )
      LWORK = INT(TMP_WORK(1))
      allocate ( WORK(LWORK) )
      LIWORK = TMP_IWORK(1)
      allocate ( IWORK(LIWORK) )
      CALL PDSYEVD( 'V', 'U', N, A, 1, 1, DESC, W, Z, 1, 1,
     $             DESC, WORK, LWORK, IWORK, LIWORK, INFO )
      call mpi_barrier(mpi_comm_world, ierr)
      END_TICK = MPI_WTIME()
*
*     Print out the eigenvalues and eigenvectors
*
      IF( MYROW.EQ.0 .AND. MYCOL.EQ.0 ) THEN
         write(*,'(" Eigenvalues:",5E12.5e2)') W(1:N)
         write(*,*) "init_time = ", GEN_TICK - INIT_TICK
         write(*,*) "gen_time = ", DIAG_TICK - GEN_TICK
         write(*,*) "diag_time = ", END_TICK - DIAG_TICK
      END IF

      CALL BLACS_GRIDEXIT( CONTEXT )
      call mpi_finalize(ierr)
      STOP
      END
*

*
      SUBROUTINE MINIJ_MATRIX( N, A, DESCA, INFO )
*  This is originally PDLAMODHILB in ScaLAPACK
*  -- ScaLAPACK routine (version 1.2) --
*     University of Tennessee, Knoxville, Oak Ridge National Laboratory,
*     and University of California, Berkeley.
*     May 10, 1996
*     ..
*     .. Scalar Arguments ..
      INTEGER            N
*     ..
*     .. Array Arguments ..
      INTEGER            DESCA( * )
      DOUBLE PRECISION   A( * )
*     ..
*     .. Local Scalars ..
      INTEGER            I, J
*     ..
*     .. External Subroutines ..
      EXTERNAL           PDELSET
*
*     Create minij matrix
      DO 20 J = 1, N
         DO 10 I = 1, N
            CALL PDELSET( A, I, J, DESCA, dble(MIN(I,J)))
   10    CONTINUE
   20 CONTINUE

*
*
      RETURN
*
*     End of MINIJ_MATRIX
*
      END


!  chktype.f90 --
 !
 !    The module chktype is meant to have the compiler check
 !    as much as possible if the terms in an expression all
 !    have the same precision. This can be used to find out
 !    if there are expressions like "2.1*x" with x a double
 !    precision value or "2.0*i/9" with i an integer.
 !
 !    Such statements cause serious problems:
 !    - the constant 2.1 in the first example is used as
 !      single precision whereas the expression as a whole
 !      will be of double precision. The value is, however,
 !      _not_ the same as 2.1d0*x.
 !    - Evaluating 2.0*i/9 may result in a wrong answer:
 !      set i to 1. If i/9 is computed first, then the result
 !      is 0, not 2.0/9= 0.2222...
 !
 !    The module is not intended for use in an actual program,
 !    it is merely meant for checking at run time
 !

module chktype
    type real_
        private
        real :: v
    endtype
    type double_
        private
        real(kind=kind(1.0d0)) :: v
    endtype
    type integer_
        private
        integer :: v
    endtype

    interface operator(+)
        module procedure add_real
        module procedure add_double
        module procedure add_integer
        module procedure add_real_tc
        module procedure add_double_tc
        module procedure add_integer_tc
        module procedure add_real_ct
        module procedure add_double_ct
        module procedure add_integer_ct
    end interface

    interface operator(-)
        module procedure sub_real
        module procedure sub_double
        module procedure sub_integer
        module procedure sub_real_tc
        module procedure sub_double_tc
        module procedure sub_integer_tc
        module procedure sub_real_ct
        module procedure sub_double_ct
        module procedure sub_integer_ct
    end interface

    interface operator(*)
        module procedure mult_real
        module procedure mult_double
        module procedure mult_integer
        module procedure mult_real_tc
        module procedure mult_double_tc
        module procedure mult_integer_tc
        module procedure mult_real_ct
        module procedure mult_double_ct
        module procedure mult_integer_ct
    end interface

    interface operator(/)
        module procedure div_real
        module procedure div_double
        module procedure div_integer
        module procedure div_real_tc
        module procedure div_double_tc
        module procedure div_integer_tc
        module procedure div_real_ct
        module procedure div_double_ct
        module procedure div_integer_ct
    end interface

    interface operator(**)
        module procedure expon_real
        module procedure expon_double
        module procedure expon_integer
        module procedure expon_real_tc
        module procedure expon_double_tc
        module procedure expon_integer_tc
        module procedure expon_real_ct
        module procedure expon_double_ct
        module procedure expon_integer_ct
    end interface

    interface operator(>)
        module procedure gt_real
        module procedure gt_double
        module procedure gt_integer
        module procedure gt_real_tc
        module procedure gt_double_tc
        module procedure gt_integer_tc
        module procedure gt_real_ct
        module procedure gt_double_ct
        module procedure gt_integer_ct
    end interface

    interface operator(<)
        module procedure lt_real
        module procedure lt_double
        module procedure lt_integer
        module procedure lt_real_tc
        module procedure lt_double_tc
        module procedure lt_integer_tc
        module procedure lt_real_ct
        module procedure lt_double_ct
        module procedure lt_integer_ct
    end interface

    interface operator(>=)
        module procedure ge_real
        module procedure ge_double
        module procedure ge_integer
        module procedure ge_real_tc
        module procedure ge_double_tc
        module procedure ge_integer_tc
        module procedure ge_real_ct
        module procedure ge_double_ct
        module procedure ge_integer_ct
    end interface

    interface operator(<=)
        module procedure le_real
        module procedure le_double
        module procedure le_integer
        module procedure le_real_tc
        module procedure le_double_tc
        module procedure le_integer_tc
        module procedure le_real_ct
        module procedure le_double_ct
        module procedure le_integer_ct
    end interface

    interface operator(==)
        module procedure eq_real
        module procedure eq_double
        module procedure eq_integer
        module procedure eq_real_tc
        module procedure eq_double_tc
        module procedure eq_integer_tc
        module procedure eq_real_ct
        module procedure eq_double_ct
        module procedure eq_integer_ct
    end interface

    interface operator(/=)
        module procedure ne_real
        module procedure ne_double
        module procedure ne_integer
        module procedure ne_real_tc
        module procedure ne_double_tc
        module procedure ne_integer_tc
        module procedure ne_real_ct
        module procedure ne_double_ct
        module procedure ne_integer_ct
    end interface

    interface assignment(=)
        module procedure assign_real
        module procedure assign_double
        module procedure assign_integer
        module procedure assign_real_const
        module procedure assign_double_const
        module procedure assign_integer_const
    end interface

contains

    elemental subroutine assign_real(x,y)
        type(real_), intent(in)  :: y
        type(real_), intent(out) :: x
        x%v = y%v
    end subroutine

    elemental subroutine assign_real_const(x,y)
        real, intent(in)       :: y
        type(real_), intent(out) :: x
        x%v = y
    end subroutine

    elemental subroutine assign_double(x,y)
        type(double_), intent(in)  :: y
        type(double_), intent(out) :: x
        x%v = y%v
    end subroutine

    elemental subroutine assign_double_const(x,y)
        real(kind=kind(1.0d0)), intent(in)       :: y
        type(double_), intent(out) :: x
        x%v = y
    end subroutine

    elemental subroutine assign_integer(x,y)
        type(integer_), intent(in)  :: y
        type(integer_), intent(out) :: x
        x%v = y%v
    end subroutine

    elemental subroutine assign_integer_const(x,y)
        integer, intent(in)       :: y
        type(integer_), intent(out) :: x
        x%v = y
    end subroutine

    elemental type(real_) function add_real(x,y)
        type(real_), intent(in) :: x,y
        add_real%v = x%v + y%v
    end function
    elemental type(real_) function add_real_tc(x,y)
        type(real_), intent(in) :: x
        real, intent(in)      :: y
        add_real_tc%v = x%v + y
    end function
    elemental type(real_) function add_real_ct(x,y)
        real, intent(in)      :: x
        type(real_), intent(in) :: y
        add_real_ct%v = x + y%v
    end function

    elemental type(double_) function add_double(x,y)
        type(double_), intent(in) :: x,y
        add_double%v = x%v + y%v
    end function
    elemental type(double_) function add_double_tc(x,y)
        type(double_), intent(in) :: x
        real(kind=kind(1.0d0)), intent(in)      :: y
        add_double_tc%v = x%v + y
    end function
    elemental type(double_) function add_double_ct(x,y)
        real(kind=kind(1.0d0)), intent(in)      :: x
        type(double_), intent(in) :: y
        add_double_ct%v = x + y%v
    end function

    elemental type(integer_) function add_integer(x,y)
        type(integer_), intent(in) :: x,y
        add_integer%v = x%v + y%v
    end function
    elemental type(integer_) function add_integer_tc(x,y)
        type(integer_), intent(in) :: x
        integer, intent(in)      :: y
        add_integer_tc%v = x%v + y
    end function
    elemental type(integer_) function add_integer_ct(x,y)
        integer, intent(in)      :: x
        type(integer_), intent(in) :: y
        add_integer_ct%v = x + y%v
    end function

    elemental type(real_) function sub_real(x,y)
        type(real_), intent(in) :: x,y
        sub_real%v = x%v - y%v
    end function
    elemental type(real_) function sub_real_tc(x,y)
        type(real_), intent(in) :: x
        real, intent(in)      :: y
        sub_real_tc%v = x%v - y
    end function
    elemental type(real_) function sub_real_ct(x,y)
        real, intent(in)      :: x
        type(real_), intent(in) :: y
        sub_real_ct%v = x - y%v
    end function

    elemental type(double_) function sub_double(x,y)
        type(double_), intent(in) :: x,y
        sub_double%v = x%v - y%v
    end function
    elemental type(double_) function sub_double_tc(x,y)
        type(double_), intent(in) :: x
        real(kind=kind(1.0d0)), intent(in)      :: y
        sub_double_tc%v = x%v - y
    end function
    elemental type(double_) function sub_double_ct(x,y)
        real(kind=kind(1.0d0)), intent(in)      :: x
        type(double_), intent(in) :: y
        sub_double_ct%v = x - y%v
    end function

    elemental type(integer_) function sub_integer(x,y)
        type(integer_), intent(in) :: x,y
        sub_integer%v = x%v - y%v
    end function
    elemental type(integer_) function sub_integer_tc(x,y)
        type(integer_), intent(in) :: x
        integer, intent(in)      :: y
        sub_integer_tc%v = x%v - y
    end function
    elemental type(integer_) function sub_integer_ct(x,y)
        integer, intent(in)      :: x
        type(integer_), intent(in) :: y
        sub_integer_ct%v = x - y%v
    end function

    elemental type(real_) function mult_real(x,y)
        type(real_), intent(in) :: x,y
        mult_real%v = x%v * y%v
    end function
    elemental type(real_) function mult_real_tc(x,y)
        type(real_), intent(in) :: x
        real, intent(in)      :: y
        mult_real_tc%v = x%v * y
    end function
    elemental type(real_) function mult_real_ct(x,y)
        real, intent(in)      :: x
        type(real_), intent(in) :: y
        mult_real_ct%v = x * y%v
    end function

    elemental type(double_) function mult_double(x,y)
        type(double_), intent(in) :: x,y
        mult_double%v = x%v * y%v
    end function
    elemental type(double_) function mult_double_tc(x,y)
        type(double_), intent(in) :: x
        real(kind=kind(1.0d0)), intent(in)      :: y
        mult_double_tc%v = x%v * y
    end function
    elemental type(double_) function mult_double_ct(x,y)
        real(kind=kind(1.0d0)), intent(in)      :: x
        type(double_), intent(in) :: y
        mult_double_ct%v = x * y%v
    end function

    elemental type(integer_) function mult_integer(x,y)
        type(integer_), intent(in) :: x,y
        mult_integer%v = x%v * y%v
    end function
    elemental type(integer_) function mult_integer_tc(x,y)
        type(integer_), intent(in) :: x
        integer, intent(in)      :: y
        mult_integer_tc%v = x%v * y
    end function
    elemental type(integer_) function mult_integer_ct(x,y)
        integer, intent(in)      :: x
        type(integer_), intent(in) :: y
        mult_integer_ct%v = x * y%v
    end function

    elemental type(real_) function div_real(x,y)
        type(real_), intent(in) :: x,y
        div_real%v = x%v / y%v
    end function
    elemental type(real_) function div_real_tc(x,y)
        type(real_), intent(in) :: x
        real, intent(in)      :: y
        div_real_tc%v = x%v / y
    end function
    elemental type(real_) function div_real_ct(x,y)
        real, intent(in)      :: x
        type(real_), intent(in) :: y
        div_real_ct%v = x / y%v
    end function

    elemental type(double_) function div_double(x,y)
        type(double_), intent(in) :: x,y
        div_double%v = x%v / y%v
    end function
    elemental type(double_) function div_double_tc(x,y)
        type(double_), intent(in) :: x
        real(kind=kind(1.0d0)), intent(in)      :: y
        div_double_tc%v = x%v / y
    end function
    elemental type(double_) function div_double_ct(x,y)
        real(kind=kind(1.0d0)), intent(in)      :: x
        type(double_), intent(in) :: y
        div_double_ct%v = x / y%v
    end function

    elemental type(integer_) function div_integer(x,y)
        type(integer_), intent(in) :: x,y
        div_integer%v = x%v / y%v
    end function
    elemental type(integer_) function div_integer_tc(x,y)
        type(integer_), intent(in) :: x
        integer, intent(in)      :: y
        div_integer_tc%v = x%v / y
    end function
    elemental type(integer_) function div_integer_ct(x,y)
        integer, intent(in)      :: x
        type(integer_), intent(in) :: y
        div_integer_ct%v = x / y%v
    end function

    elemental type(real_) function expon_real(x,y)
        type(real_), intent(in) :: x,y
        expon_real%v = x%v ** y%v
    end function
    elemental type(real_) function expon_real_tc(x,y)
        type(real_), intent(in) :: x
        real, intent(in)      :: y
        expon_real_tc%v = x%v ** y
    end function
    elemental type(real_) function expon_real_ct(x,y)
        real, intent(in)      :: x
        type(real_), intent(in) :: y
        expon_real_ct%v = x ** y%v
    end function

    elemental type(double_) function expon_double(x,y)
        type(double_), intent(in) :: x,y
        expon_double%v = x%v ** y%v
    end function
    elemental type(double_) function expon_double_tc(x,y)
        type(double_), intent(in) :: x
        real(kind=kind(1.0d0)), intent(in)      :: y
        expon_double_tc%v = x%v ** y
    end function
    elemental type(double_) function expon_double_ct(x,y)
        real(kind=kind(1.0d0)), intent(in)      :: x
        type(double_), intent(in) :: y
        expon_double_ct%v = x ** y%v
    end function

    elemental type(integer_) function expon_integer(x,y)
        type(integer_), intent(in) :: x,y
        expon_integer%v = x%v ** y%v
    end function
    elemental type(integer_) function expon_integer_tc(x,y)
        type(integer_), intent(in) :: x
        integer, intent(in)      :: y
        expon_integer_tc%v = x%v ** y
    end function
    elemental type(integer_) function expon_integer_ct(x,y)
        integer, intent(in)      :: x
        type(integer_), intent(in) :: y
        expon_integer_ct%v = x ** y%v
    end function

    elemental logical function gt_real(x,y)
        type(real_), intent(in) :: x,y
        gt_real = x%v > y%v
    end function
    elemental logical function gt_real_tc(x,y)
        type(real_), intent(in) :: x
        real, intent(in)      :: y
        gt_real_tc = x%v > y
    end function
    elemental logical function gt_real_ct(x,y)
        real, intent(in)      :: x
        type(real_), intent(in) :: y
        gt_real_ct = x > y%v
    end function

    elemental logical function gt_double(x,y)
        type(double_), intent(in) :: x,y
        gt_double = x%v > y%v
    end function
    elemental logical function gt_double_tc(x,y)
        type(double_), intent(in) :: x
        real(kind=kind(1.0d0)), intent(in)      :: y
        gt_double_tc = x%v > y
    end function
    elemental logical function gt_double_ct(x,y)
        real(kind=kind(1.0d0)), intent(in)      :: x
        type(double_), intent(in) :: y
        gt_double_ct = x > y%v
    end function

    elemental logical function gt_integer(x,y)
        type(integer_), intent(in) :: x,y
        gt_integer = x%v > y%v
    end function
    elemental logical function gt_integer_tc(x,y)
        type(integer_), intent(in) :: x
        integer, intent(in)      :: y
        gt_integer_tc = x%v > y
    end function
    elemental logical function gt_integer_ct(x,y)
        integer, intent(in)      :: x
        type(integer_), intent(in) :: y
        gt_integer_ct = x > y%v
    end function

    elemental logical function lt_real(x,y)
        type(real_), intent(in) :: x,y
        lt_real = x%v < y%v
    end function
    elemental logical function lt_real_tc(x,y)
        type(real_), intent(in) :: x
        real, intent(in)      :: y
        lt_real_tc = x%v < y
    end function
    elemental logical function lt_real_ct(x,y)
        real, intent(in)      :: x
        type(real_), intent(in) :: y
        lt_real_ct = x < y%v
    end function

    elemental logical function lt_double(x,y)
        type(double_), intent(in) :: x,y
        lt_double = x%v < y%v
    end function
    elemental logical function lt_double_tc(x,y)
        type(double_), intent(in) :: x
        real(kind=kind(1.0d0)), intent(in)      :: y
        lt_double_tc = x%v < y
    end function
    elemental logical function lt_double_ct(x,y)
        real(kind=kind(1.0d0)), intent(in)      :: x
        type(double_), intent(in) :: y
        lt_double_ct = x < y%v
    end function

    elemental logical function lt_integer(x,y)
        type(integer_), intent(in) :: x,y
        lt_integer = x%v < y%v
    end function
    elemental logical function lt_integer_tc(x,y)
        type(integer_), intent(in) :: x
        integer, intent(in)      :: y
        lt_integer_tc = x%v < y
    end function
    elemental logical function lt_integer_ct(x,y)
        integer, intent(in)      :: x
        type(integer_), intent(in) :: y
        lt_integer_ct = x < y%v
    end function

    elemental logical function ge_real(x,y)
        type(real_), intent(in) :: x,y
        ge_real = x%v >= y%v
    end function
    elemental logical function ge_real_tc(x,y)
        type(real_), intent(in) :: x
        real, intent(in)      :: y
        ge_real_tc = x%v >= y
    end function
    elemental logical function ge_real_ct(x,y)
        real, intent(in)      :: x
        type(real_), intent(in) :: y
        ge_real_ct = x >= y%v
    end function

    elemental logical function ge_double(x,y)
        type(double_), intent(in) :: x,y
        ge_double = x%v >= y%v
    end function
    elemental logical function ge_double_tc(x,y)
        type(double_), intent(in) :: x
        real(kind=kind(1.0d0)), intent(in)      :: y
        ge_double_tc = x%v >= y
    end function
    elemental logical function ge_double_ct(x,y)
        real(kind=kind(1.0d0)), intent(in)      :: x
        type(double_), intent(in) :: y
        ge_double_ct = x >= y%v
    end function

    elemental logical function ge_integer(x,y)
        type(integer_), intent(in) :: x,y
        ge_integer = x%v >= y%v
    end function
    elemental logical function ge_integer_tc(x,y)
        type(integer_), intent(in) :: x
        integer, intent(in)      :: y
        ge_integer_tc = x%v >= y
    end function
    elemental logical function ge_integer_ct(x,y)
        integer, intent(in)      :: x
        type(integer_), intent(in) :: y
        ge_integer_ct = x >= y%v
    end function

    elemental logical function le_real(x,y)
        type(real_), intent(in) :: x,y
        le_real = x%v <= y%v
    end function
    elemental logical function le_real_tc(x,y)
        type(real_), intent(in) :: x
        real, intent(in)      :: y
        le_real_tc = x%v <= y
    end function
    elemental logical function le_real_ct(x,y)
        real, intent(in)      :: x
        type(real_), intent(in) :: y
        le_real_ct = x <= y%v
    end function

    elemental logical function le_double(x,y)
        type(double_), intent(in) :: x,y
        le_double = x%v <= y%v
    end function
    elemental logical function le_double_tc(x,y)
        type(double_), intent(in) :: x
        real(kind=kind(1.0d0)), intent(in)      :: y
        le_double_tc = x%v <= y
    end function
    elemental logical function le_double_ct(x,y)
        real(kind=kind(1.0d0)), intent(in)      :: x
        type(double_), intent(in) :: y
        le_double_ct = x <= y%v
    end function

    elemental logical function le_integer(x,y)
        type(integer_), intent(in) :: x,y
        le_integer = x%v <= y%v
    end function
    elemental logical function le_integer_tc(x,y)
        type(integer_), intent(in) :: x
        integer, intent(in)      :: y
        le_integer_tc = x%v <= y
    end function
    elemental logical function le_integer_ct(x,y)
        integer, intent(in)      :: x
        type(integer_), intent(in) :: y
        le_integer_ct = x <= y%v
    end function

    elemental logical function eq_real(x,y)
        type(real_), intent(in) :: x,y
        eq_real = x%v == y%v
    end function
    elemental logical function eq_real_tc(x,y)
        type(real_), intent(in) :: x
        real, intent(in)      :: y
        eq_real_tc = x%v == y
    end function
    elemental logical function eq_real_ct(x,y)
        real, intent(in)      :: x
        type(real_), intent(in) :: y
        eq_real_ct = x == y%v
    end function

    elemental logical function eq_double(x,y)
        type(double_), intent(in) :: x,y
        eq_double = x%v == y%v
    end function
    elemental logical function eq_double_tc(x,y)
        type(double_), intent(in) :: x
        real(kind=kind(1.0d0)), intent(in)      :: y
        eq_double_tc = x%v == y
    end function
    elemental logical function eq_double_ct(x,y)
        real(kind=kind(1.0d0)), intent(in)      :: x
        type(double_), intent(in) :: y
        eq_double_ct = x == y%v
    end function

    elemental logical function eq_integer(x,y)
        type(integer_), intent(in) :: x,y
        eq_integer = x%v == y%v
    end function
    elemental logical function eq_integer_tc(x,y)
        type(integer_), intent(in) :: x
        integer, intent(in)      :: y
        eq_integer_tc = x%v == y
    end function
    elemental logical function eq_integer_ct(x,y)
        integer, intent(in)      :: x
        type(integer_), intent(in) :: y
        eq_integer_ct = x == y%v
    end function

    elemental logical function ne_real(x,y)
        type(real_), intent(in) :: x,y
        ne_real = x%v /= y%v
    end function
    elemental logical function ne_real_tc(x,y)
        type(real_), intent(in) :: x
        real, intent(in)      :: y
        ne_real_tc = x%v /= y
    end function
    elemental logical function ne_real_ct(x,y)
        real, intent(in)      :: x
        type(real_), intent(in) :: y
        ne_real_ct = x /= y%v
    end function

    elemental logical function ne_double(x,y)
        type(double_), intent(in) :: x,y
        ne_double = x%v /= y%v
    end function
    elemental logical function ne_double_tc(x,y)
        type(double_), intent(in) :: x
        real(kind=kind(1.0d0)), intent(in)      :: y
        ne_double_tc = x%v /= y
    end function
    elemental logical function ne_double_ct(x,y)
        real(kind=kind(1.0d0)), intent(in)      :: x
        type(double_), intent(in) :: y
        ne_double_ct = x /= y%v
    end function

    elemental logical function ne_integer(x,y)
        type(integer_), intent(in) :: x,y
        ne_integer = x%v /= y%v
    end function
    elemental logical function ne_integer_tc(x,y)
        type(integer_), intent(in) :: x
        integer, intent(in)      :: y
        ne_integer_tc = x%v /= y
    end function
    elemental logical function ne_integer_ct(x,y)
        integer, intent(in)      :: x
        type(integer_), intent(in) :: y
        ne_integer_ct = x /= y%v
    end function

end module chktype

program aha
    use chktype

    type(real_) :: x
    type(real_) :: y

    x = 1.1
    y = 1.0d0
    x = 11 * y
end program