      SUBROUTINE segd20( ibuf, obuf, nsamps )
!     SEGD20 converts the SEG-D 20 bit exponent words to floating point.
!     The SEG-D 20 bit exponent (also called 20 bit binary) groups the
!  data into groups of 5.  There are 4 data words in each group of 5.
!  The exponents for each word are 4 bits big (no sign bit) and are a
!  positive power of 2.  These 4 exponents precede the 4 data words and
!  are in the first 16 bits.  The mantissas are signed 16 bit occupying
!  the next 4 words, representing values 2**-16.
!     This here subroutine is cute because each data word requires only
!  1 multiply to convert it (rather an exponentiation).  This is very
!  similar to subroutine IBM2FP.
!
!  ARGUMENTS:
!  ibuf   - The input array (of SEG-D 20 bit exponent data).  The array
!           must be alligned correctly - the first word must be the
!           4 exponents.
!  obuf   - The output array of REAL data.  Must not be the same as ibuf
!  nsamps - The number of data values to convert.
!
!  Copyright (C) Paul Henkart, Seismic Reflection Processors, San Diego, Ca.
! mod 14 Aug 07 - g95 IAND requires arguments to be same type and kind.
!  ALL RIGHTS RESERVED.
!
      INTEGER*2 ibuf(1), rshift, i15
      REAL obuf(nsamps)
      DIMENSION exp(16), iexp(4)
      LOGICAL first
      SAVE exp, first
      DATA first/.TRUE./, i15/15/
!
      IF( first ) THEN
          exp(1) = 1. / 32768.
          DO 100 i = 2, 16
             exp(i) = exp(i-1) * 2.
  100     CONTINUE
      ENDIF
!
      i = 1
      j = 1
      DO 400 k = 1, nsamps, 4
         iexp(1) = IAND( rshift(ibuf(i),12), i15)
         iexp(2) = IAND( rshift(ibuf(i),8), i15)
         iexp(3) = IAND( rshift(ibuf(i),4), i15)
         iexp(4) = IAND( ibuf(i),i15 )
         i = i + 1
         DO 200 l = 1, 4
            temp = ibuf(i)                                               ! float the signed integer
            obuf(j) = temp * exp(iexp(l) + 1)
            i = i + 1
            j = j + 1
  200    CONTINUE
  400 CONTINUE
!
      RETURN
      END


subroutine stream_function(omega_in,psi_in,psi_out,n_x_i,n_z_i)
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!Solver linea por linea para determinar la
!la funcion de corriente y el campo de velocidades
!en la primera etapa del RK-3
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
use definiciones
implicit none

real(8)::result_1,result_2
real(8),dimension((n_x_i-1)*(n_z_i-1))::p,residuo,kk,residuo_prima,z_cg,vector_psi
real(8),dimension(n_x_i+1,n_z_i+1),intent(in)::omega_in,psi_in
real(8),dimension(n_x_i+1,n_z_i+1),intent(out)::psi_out
integer(4)::i,j,k,k_t,iter,n_x_i,n_z_i
real(8)::a_gauss,b_gauss,c_gauss,d_gauss,f_gauss,e_gauss,inv_d
real(8)::alpha,beta
real(8)::max_res
real(8)::producto,producto_1,producto_residuo_prima
integer(4)::num_fila
integer(4)::num_threads,save_nt

!include 'mkl.fi'
!num_threads=4
!save_nt = mkl_set_num_threads_local(num_threads)
num_fila=(nx_i-1)*(nz_i-1)
!---------------------------------------
!Condiciones de contorno
!Valor de la funcion de corriente =0 en las
!paredes
!---------------------------------------
!write(*,*)omega_in

psi_out=psi_in
do j=1,n_z_i+1
i=1
!psi_out(i,j)=0.0d0
psi_out(i,j)=0.0d0
i=n_x_i+1
!psi_out(i,j)=0.0d0
psi_out(i,j)=0.0d0
end do
do i=1,n_x_i+1
j=1
!psi_out(i,j)=0.0d0
psi_out(i,j)=0.0d0
j=n_z_i+1
!psi_out(i,j)=0.0d0
psi_out(i,j)=0.0d0
end do

!%%%%%%%%%%%%

!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!Coeficientes de la matriz
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
b_gauss=1.0d0/delta_z**2

a_gauss=1.0d0/delta_z**2

d_gauss=-2.0d0/delta_z**2-2.0d0/delta_x**2

e_gauss=1.0d0/delta_x**2

f_gauss=1.0d0/delta_x**2

inv_d=1.0d0/d_gauss
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!Esquina inferior izquierda
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
i=1
j=1
c_gauss=-omega_in(i+1,j+1)
c_gauss=c_gauss-f_gauss*psi_out(i,j+1)-b_gauss*psi_out(i+1,j)
residuo((i-1)*(n_z_i-1)+j)=(c_gauss-e_gauss*psi_out(i+2,j+1)-a_gauss*psi_out(i+1,j+2)-d_gauss*psi_out(i+1,j+1))

!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!Pared lateral izquierda
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
do  j=2,n_z_i-2
c_gauss=-omega_in(i+1,j+1)
c_gauss=c_gauss-f_gauss*psi_out(i,j+1)
residuo((i-1)*(n_z_i-1)+j)=(c_gauss-b_gauss*psi_out(i+1,j)-a_gauss*psi_out(i+1,j+2)-&
        e_gauss*psi_out(i+2,j+1)-d_gauss*psi_out(i+1,j+1))
end do

!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!Esquina superior izquierda
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
j=n_z_i-1
c_gauss=-omega_in(i+1,j+1)
c_gauss=c_gauss-f_gauss*psi_out(i,j+1)-a_gauss*psi_out(i+1,j+2)
residuo((i-1)*(n_z_i-1)+j)=(c_gauss-b_gauss*psi_out(i+1,j)-e_gauss*psi_out(i+2,j+1)-d_gauss*psi_out(i+1,j+1))

!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!%Interior del dominio
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

do i=2,n_x_i-2

j=1
c_gauss=-omega_in(i+1,j+1)
c_gauss=c_gauss-b_gauss*psi_out(i+1,j)
residuo((i-1)*(n_z_i-1)+j)=(c_gauss-a_gauss*psi_out(i+1,j+2)-e_gauss*psi_out(i+2,j+1)-f_gauss*psi_out(i,j+1)-&
        d_gauss*psi_out(i+1,j+1))

    do j=2,n_z_i-2
    c_gauss=-omega_in(i+1,j+1)
    residuo((i-1)*(n_z_i-1)+j)=(c_gauss-b_gauss*psi_out(i+1,j)-a_gauss*psi_out(i+1,j+2)&
    -e_gauss*psi_out(i+2,j+1)-f_gauss*psi_out(i,j+1)-d_gauss*psi_out(i+1,j+1))
    end do
j=n_z_i-1
c_gauss=-omega_in(i+1,j+1)
c_gauss=c_gauss-a_gauss*psi_out(i+1,j+2)
residuo((i-1)*(n_z_i-1)+j)=(c_gauss-b_gauss*psi_out(i+1,j)-e_gauss*psi_out(i+2,j+1)&
-f_gauss*psi_out(i,j+1)-d_gauss*psi_out(i+1,j+1))
end do

!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!%x=L
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
i=n_x_i-1
j=1
c_gauss=-omega_in(i+1,j+1)
c_gauss=c_gauss-e_gauss*psi_out(i+2,j+1)-b_gauss*psi_out(i+1,j)
residuo((i-1)*(n_z_i-1)+j)=(c_gauss-a_gauss*psi_out(i+1,j+2)-f_gauss*psi_out(i,j+1)-d_gauss*psi_out(i+1,j+1))

do j=2,n_z_i-2
c_gauss=-omega_in(i+1,j+1)
c_gauss=c_gauss-e_gauss*psi_out(i+2,j+1)
residuo((i-1)*(n_z_i-1)+j)=(c_gauss-b_gauss*psi_out(i+1,j)-a_gauss*psi_out(i+1,j+2)-&
                f_gauss*psi_out(i,j+1)-d_gauss*psi_out(i+1,j+1))
end do

j=n_z_i-1
c_gauss=-omega_in(i+1,j+1)
c_gauss=c_gauss-e_gauss*psi_out(i+2,j+1)-a_gauss*psi_out(i+1,j+2)
residuo((i-1)*(n_z_i-1)+j)=(c_gauss-b_gauss*psi_out(i+1,j)-f_gauss*psi_out(i,j+1)-d_gauss*psi_out(i+1,j+1))

iter=1
max_res=maxval(dabs(residuo))
z_cg=inv_d*residuo
p(1:(n_x_i-1)*(n_z_i-1))=z_cg(1:(n_x_i-1)*(n_z_i-1))
producto=dot_product(residuo,z_cg)
!producto=ddot(num_fila,residuo,1,z_cg,1)
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
do j=1,n_z_i-1
    do i=1,n_x_i-1
    vector_psi((i-1)*(n_z_i-1)+j)=psi_out(i+1,j+1)
    end do
end do
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

do while(max_res>eps)
!$OMP PARALLEL PRIVATE(i,j)  NUM_THREADS(4)
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

i=1
j=1
kk((i-1)*(n_z_i-1)+j)=-(-e_gauss*p((i)*(n_z_i-1)+j)-a_gauss*p((i-1)*(n_z_i-1)+j+1)-d_gauss*p((i-1)*(n_z_i-1)+j))

do  j=2,n_z_i-2
kk((i-1)*(n_z_i-1)+j)=-(-b_gauss*p((i-1)*(n_z_i-1)+j-1)-a_gauss*p((i-1)*(n_z_i-1)+j+1)-e_gauss*p((i)*(n_z_i-1)+j)-&
                    d_gauss*p((i-1)*(n_z_i-1)+j))
end do

j=n_z_i-1
kk((i-1)*(n_z_i-1)+j)=-(-b_gauss*p((i-1)*(n_z_i-1)+j-1)-e_gauss*p((i)*(n_z_i-1)+j)-d_gauss*p((i-1)*(n_z_i-1)+j))

!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!%Interior del dominio
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!$OMP DO
do i=2,n_x_i-2

j=1
kk((i-1)*(n_z_i-1)+j)=-(-a_gauss*p((i-1)*(n_z_i-1)+j+1)-e_gauss*p((i)*(n_z_i-1)+j)-&
f_gauss*p((i-2)*(n_z_i-1)+j)-d_gauss*p((i-1)*(n_z_i-1)+j))

   do j=2,n_z_i-2

kk((i-1)*(n_z_i-1)+j)=-(-b_gauss*p((i-1)*(n_z_i-1)+j-1)-a_gauss*p((i-1)*(n_z_i-1)+j+1)&
-e_gauss*p((i)*(n_z_i-1)+j)-f_gauss*p((i-2)*(n_z_i-1)+j)-d_gauss*p((i-1)*(n_z_i-1)+j))

    end do

j=n_z_i-1
kk((i-1)*(n_z_i-1)+j)=-(-b_gauss*p((i-1)*(n_z_i-1)+j-1)-e_gauss*p((i)*(n_z_i-1)+j)-f_gauss*p((i-2)*(n_z_i-1)+j)-&
        d_gauss*p((i-1)*(n_z_i-1)+j))
end do
!$OMP END DO
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!%x=L
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
i=n_x_i-1
j=1
kk((i-1)*(n_z_i-1)+j)=-(-a_gauss*p((i-1)*(n_z_i-1)+j+1)-f_gauss*p((i-2)*(n_z_i-1)+j)&
-d_gauss*p((i-1)*(n_z_i-1)+j))

do j=2,n_z_i-2
kk((i-1)*(n_z_i-1)+j)=-(-b_gauss*p((i-1)*(n_z_i-1)+j-1)-a_gauss*p((i-1)*(n_z_i-1)+j+1)-f_gauss*p((i-2)*(n_z_i-1)+j)&
-d_gauss*p((i-1)*(n_z_i-1)+j))
end do

j=n_z_i-1
kk((i-1)*(n_z_i-1)+j)=-(-b_gauss*p((i-1)*(n_z_i-1)+j-1)-f_gauss*p((i-2)*(n_z_i-1)+j)-d_gauss*p((i-1)*(n_z_i-1)+j))
!$OMP END PARALLEL
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

producto_1=dot_product(p,kk)

alpha=producto/producto_1

!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!%
!%Calculo del nuevo residuo
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!call daxpy(num_fila, alpha, kk, 1, vector_psi, 1)
vector_psi=vector_psi+alpha*p
residuo_prima=residuo-alpha*kk
z_cg=inv_d*residuo_prima
producto_residuo_prima=dot_product(residuo_prima,z_cg)
beta=producto_residuo_prima/producto
p=z_cg+beta*p
residuo=residuo_prima
producto=producto_residuo_prima
iter=iter+1;
max_res=maxval(dabs(residuo_prima))

end do
do j=1,n_z_i-1
    do i=1,n_x_i-1
    psi_out(i+1,j+1)=vector_psi((i-1)*(n_z_i-1)+j)
    end do
end do

!write(*,'(e17.9)')max_res
!write(*,*)"total iteration",iter

end subroutine stream_function


!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
!   Driver for the Adjoint (ADJ) model
!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

PROGRAM KPP_ROOT_ADJ_Driver

  USE KPP_ROOT_Model
  USE KPP_ROOT_Initialize, ONLY: Initialize

      KPP_REAL :: T, DVAL(NSPEC)
      INTEGER :: i, j, ind_1 = 1, ind_2 = 2
      ! INTEGER :: ind_1 = ind_NO2, ind_2 = ind_O3

! ---  Number of functional for which sensitivities are computed
! ---  Note: this value is set for sensitivities w.r.t. all initial values
! ---       it may have to be changed for other applications
      INTEGER NADJ
      PARAMETER (NADJ = 2)
      KPP_REAL  Y_ADJ(NVAR,NADJ)

! ---- TIME VARIABLES ------------------

      STEPMIN = 0.0d0
      STEPMAX = 0.0d0

      DO i=1,NVAR
        RTOL(i) = 1.0d-4
        ATOL(i) = 1.0d-3
      END DO

      CALL Initialize()

!~~~>  Note: the initial values below are adjoint values at the final time
      Y_ADJ(1:NVAR,1:NADJ) = 0.0d0
      Y_ADJ(ind_1,1) = 1.0d0
      Y_ADJ(ind_2,2) = 1.0d0

! ~~~~~~~~~ BEGIN TIME LOOP ~~~~~~~~~~

      CALL InitSaveData()

      T = TSTART

      CALL GetMass( C, DVAL )
      WRITE(6,991) (T-TSTART)/(TEND-TSTART)*100, T,        &
                  (TRIM(SPC_NAMES(MONITOR(i))),            &
                    C(MONITOR(i))/CFACTOR, i=1,NMONITOR),  &
                  (TRIM(SMASS(i)),DVAL(i)/CFACTOR, i=1,NMASS)

      CALL SaveData()

      CALL INTEGRATE_ADJ( NADJ, VAR, Y_ADJ, T, TEND )

      CALL GetMass( C, DVAL )
      WRITE(6,991) (TEND-TSTART)/(TEND-TSTART)*100, TEND,  &
                  (TRIM(SPC_NAMES(MONITOR(i))),            &
                    C(MONITOR(i))/CFACTOR, i=1,NMONITOR),  &
                  (TRIM(SMASS(i)),DVAL(i)/CFACTOR, i=1,NMASS)

      CALL SaveData()

! ~~~~~~~~~ END TIME LOOP ~~~~~~~~~~

      OPEN(20, FILE='KPP_ROOT_ADJ_results.m')
      WRITE(6,*) '**************************************************'
      WRITE(6,*) ' Concentrations and Sensitivities at final time '
      WRITE(6,*) ' were written in the file KPP_ROOT_ADJ_results.m'
      WRITE(6,*) '**************************************************'
      DO j=1,NADJ
        WRITE(20,993) ( Y_ADJ(i,j), i=1,NVAR )
      END DO

      WRITE(6,995) TRIM(SPC_NAMES(ind_1)),TRIM(SPC_NAMES(ind_1)), &
                   Y_ADJ(ind_1,1)
      WRITE(6,995) TRIM(SPC_NAMES(ind_2)),TRIM(SPC_NAMES(ind_2)), &
                   Y_ADJ(ind_2,2)
      WRITE(6,995) TRIM(SPC_NAMES(ind_2)),TRIM(SPC_NAMES(ind_1)), &
                   Y_ADJ(ind_1,2)
      WRITE(6,995) TRIM(SPC_NAMES(ind_1)),TRIM(SPC_NAMES(ind_2)), &
                   Y_ADJ(ind_2,1)

      CALL CloseSaveData()

 991  FORMAT(F6.1,'%. T=',E10.3,3X,20(A,'=',E10.4,';',1X))
 993  FORMAT(1000(E24.16,2X))
 995  FORMAT('ADJ: d[',A,'](tf)/d[',A,'](t0)=',E14.7)

END PROGRAM KPP_ROOT_ADJ_Driver


C
C
       subroutine fun_gcf(gammcf,a,x,gln,istat)
C      ----------------------------------------
C
C Internal subroutine returning incomplete gamma function by continued
C fraction
C
C Given:
C  parameters of function
       real*4     a,x
C Returned:
C  value of function and log(Gamma(a))
       real*4     gammcf,gln
C Updated:
C   error return code
       integer    istat
C
C P. Alexander, MRAO, Cambridge.
C Ref: Numerical recipes, Press et al., Cambridge. pg. 162
C-
       include '../include/utilities_errors.inc'

       integer    itmax, n
       real*4     eps, g, gold, a0, a1, b0, b1, an, ana, anf, fac
       parameter (itmax=100,eps=3.0E-7)

C functions used
       real*4     fun_gammln

       if (istat.ne.0) return
       gln = fun_gammln( a, istat )
       if (istat.ne.0) goto 999
       if (x.lt.0.0) then
         istat = ill_inputs
       else if (x.eq.0.0) then
         gammcf = 0.0
       else
         gold = 0.0
         a0 = 1.0
         a1 = x
         b0 = 0.0
         b1 = 1.0
         fac = 1.0
         do n=1,itmax
           an = float(n)
           ana = an - a
           a0 = (a1+a0*ana)*fac
           b0 = (b1+b0*ana)*fac
           anf = an * fac
           a1 = x*a0 + anf*a1
           b1 = x*b0 + anf*b1
           if (a1.ne.0.0) then
             fac = 1.0/a1
             g = b1*fac
             if (abs((g-gold)/g).lt.eps) goto 1
             gold = g
           end if
         end do
         istat = ill_precision
         goto 999
 1       gammcf = g*exp(-x+a*log(x)-gln)
       end if
 999   call utl_err( istat,'fun_gcf',' ' )
       end


    program test
    USE, INTRINSIC :: ISO_C_BINDING
    USE OPENST
    use omp_lib
    REAL (C_DOUBLE), TARGET, ALLOCATABLE :: U(:,:,:), V(:,:,:)
    INTEGER (C_SIZE_T) :: NI , NJ, NK
    REAL (C_DOUBLE) :: HI, HJ, HK, SRCI, SRCJ, SRCK, RCVI, RCVJ, RCVK
    TYPE (C_PTR) :: U_PTR, V_PTR
    REAL (C_DOUBLE) :: di, dj, dk, dist
    INTEGER (C_INT) :: errcode
    INTEGER (C_SIZE_T):: i,j,k
    INTEGER (C_SIZE_T) :: MAX_SEG
    double precision :: start, finish

    REAL (C_DOUBLE) :: TSTEP
    REAL (C_DOUBLE), POINTER, DIMENSION(:,:) :: RAY
    TYPE (C_PTR), TARGET :: RAY_PTR, RAY_PTR_PTR
    INTEGER (C_SIZE_T), TARGET :: RAY_NI, RAY_NJ
    TYPE (C_PTR) :: RAY_NI_PTR, RAY_NJ_PTR

    NI = 50
    NJ = 50
    NK = 50

    RCVI = 1.0
    RCVJ = 0.5
    RCVK = 0.5

    SRCI = 0.5
    SRCJ = 0.5
    SRCK = 0.5

    HI = 1.0 / (NI - 1)
    HJ = 1.0 / (NJ - 1)
    HK = 1.0 / (NK - 1)

    TSTEP = MIN(HI,HJ,HK) / 1.0 * 0.999
    MAX_SEG = (NI * NJ * NK);

    print '("H: ",E15.6,E15.6,E15.6)', HI,HJ,HK
    print '("TSTEP: ",E15.6)', TSTEP
    print '("MAX_SEG: ",I22)', MAX_SEG

    ALLOCATE ( U (NI, NJ, NK) )
    ALLOCATE ( V (NI, NJ, NK) )

    U_PTR = C_LOC(U)
    V_PTR = C_LOC(V)

    do k = 1,NK
        do j = 1,NJ
            do i = 1,NI
                V(i,j,k) = 1.0
                di = SRCI - DBLE(i - 1) * HI
                dj = SRCJ - DBLE(j - 1) * HJ
                dk = SRCK - DBLE(k - 1) * HK
                dist = SQRT(di * di + dj * dj + dk * dk)
                U(i,j,k) = dist
            end do
        end do
    end do

    RAY_PTR_PTR = C_LOC(RAY_PTR)
    RAY_NI_PTR = C_LOC(RAY_NI)
    RAY_NJ_PTR = C_LOC(RAY_NJ)

    start = omp_get_wtime()
    errcode = OpenST_BRT3D_Trace(U_PTR,V_PTR,NI,NJ,NK,HI,HJ,HK,TSTEP,RCVI,RCVJ,RCVK, &
        SRCI,SRCJ,SRCK,MAX_SEG,RAY_PTR_PTR,RAY_NI_PTR,RAY_NJ_PTR)
    finish = omp_get_wtime()
    print '("BRT3D: ",E15.6," seconds.")',finish-start

    if (errcode.NE.0) then
        print '("OPENST_ERROR: code ",i2)',errcode
        STOP 1
    end if

    CALL C_F_POINTER(RAY_PTR, RAY, [RAY_NI, RAY_NJ])
    RAY = RESHAPE( RAY, [RAY_NI,RAY_NJ], order=[2,1])

    do i = 1,RAY_NI
        print '(I3, E15.6, E15.6, E15.6)', i, RAY(i,1), RAY(i,2), RAY(i,3)
    end do

    CALL OpenST_INTEROP_FreePointer(RAY_PTR)

    end program


! PR rtl-optimization/37243
! { dg-do run }
! { dg-add-options ieee }
! Check if register allocator handles IR flattening correctly.
      SUBROUTINE SCHMD(V,M,N,LDV)
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
      LOGICAL GOPARR,DSKWRK,MASWRK
      DIMENSION V(LDV,N)
      COMMON /IOFILE/ IR,IW,IP,IS,IPK,IDAF,NAV,IODA(400)
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
      PARAMETER (ZERO=0.0D+00, ONE=1.0D+00, TOL=1.0D-10)
      IF (M .EQ. 0) GO TO 180
      DO 160 I = 1,M
      DUMI = ZERO
      DO 100 K = 1,N
  100 DUMI = DUMI+V(K,I)*V(K,I) ! { dg-warning "Obsolescent feature: DO termination statement which is not END DO or CONTINUE" }
      DUMI = ONE/ SQRT(DUMI)
      DO 120 K = 1,N
  120 V(K,I) = V(K,I)*DUMI ! { dg-warning "Obsolescent feature: DO termination statement which is not END DO or CONTINUE" }
      IF (I .EQ. M) GO TO 160
      I1 = I+1
      DO 140 J = I1,M
      DUM = -DDOT(N,V(1,J),1,V(1,I),1)
      CALL DAXPY(N,DUM,V(1,I),1,V(1,J),1)
  140 CONTINUE
  160 CONTINUE
      IF (M .EQ. N) RETURN
  180 CONTINUE
      I = M
      J = 0
  200 I0 = I
      I = I+1
      IF (I .GT. N) RETURN
  220 J = J+1
      IF (J .GT. N) GO TO 320
      DO 240 K = 1,N
  240 V(K,I) = ZERO ! { dg-warning "Obsolescent feature: DO termination statement which is not END DO or CONTINUE" }
      CALL DAXPY(N,DUM,V(1,I),1,V(1,I),1)
  260 CONTINUE
      DUMI = ZERO
      DO 280 K = 1,N
  280 DUMI = DUMI+V(K,I)*V(K,I) ! { dg-warning "Obsolescent feature: DO termination statement which is not END DO or CONTINUE" }
      IF ( ABS(DUMI) .LT. TOL) GO TO 220
      DO 300 K = 1,N
  300 V(K,I) = V(K,I)*DUMI ! { dg-warning "Obsolescent feature: DO termination statement which is not END DO or CONTINUE" }
      GO TO 200
  320 END
      program main
      DOUBLE PRECISION V
      DIMENSION V(18, 18)
      common // v

      call schmd(V, 1, 18, 18)
      end

      subroutine DAXPY(N,D,V,M,W,L)
      INTEGER :: N, M, L
      DOUBLE PRECISION D, V(1,1), W(1,1)
      end

      FUNCTION DDOT (N,V,M,W,L)
      INTEGER :: N, M, L
      DOUBLE PRECISION DDOT, V(1,1), W(1,1)
      DDOT = 1
      end


! { dg-do run }
! Test functions returning arrays of indeterminate size.
program ret_array_1
  integer, dimension(:, :), allocatable :: a
  integer, dimension(2) :: b

  allocate (a(2, 3))
  a = reshape ((/1, 2, 3, 4, 5, 6/), (/2, 3/))

  ! Using the return value as an actual argument
  b = 0;
  b = sum (transpose (a), 1);
  if (any (b .ne. (/9, 12/))) STOP 1

  ! Using the return value in an expression
  b = 0;
  b = sum (transpose (a) + 1, 1);
  if (any (b .ne. (/12, 15/))) STOP 2

  ! Same again testing a user function
! TODO: enable these once this is implemented
!  b = 0;
!  b = sum (my_transpose (a), 1);
!  if (any (b .ne. (/9, 12/))) STOP 3
!
!  ! Using the return value in an expression
!  b = 0;
!  b = sum (my_transpose (a) + 1, 1);
!  if (any (b .ne. (/12, 15/))) STOP 4
contains
subroutine test(x, n)
  integer, dimension (:, :) :: x
  integer n

  if (any (shape (x) .ne. (/3, 2/))) STOP 1
  if (any (x .ne. (n + reshape((/1, 4, 2, 5, 3, 6/), (/3, 2/))))) STOP 2
end subroutine

function my_transpose (x) result (r)
  interface
    pure function obfuscate (i)
      integer obfuscate
      integer, intent(in) :: i
    end function
  end interface
  integer, dimension (:, :) :: x
  integer, dimension (obfuscate(ubound(x, 2)), &
                      obfuscate(ubound(x, 1))) :: r
  integer i

  do i = 1, ubound(x, 1)
    r(:, i) = x(i, :)
  end do
end function
end program

pure function obfuscate (i)
  integer obfuscate
  integer, intent(in) :: i

  obfuscate = i
end function


module setup_config_mod

use constants_mod

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

real(dp), parameter :: init_time =  10.0
real(dp), parameter :: stop_time = 905.0
!real(dp), parameter :: stop_time = 705.0
!real(dp), parameter :: stop_time = 520.0

real(dp), parameter :: CFL = 0.8_dp

real(dp), parameter :: beta = 0.8_dp

real(dp), parameter :: dt_checkpoint = 50.0_dp

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

real(dp), parameter :: dt_analyze = dt_checkpoint

real(dp), parameter :: chkpt_init_time = init_time
real(dp), parameter :: chkpt_stop_time = stop_time

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

!! Ferrand (2012)
real(dp), parameter :: blast_energy = 5.25166181297794e-05
real(dp), parameter :: ejecta_mass = 1.4
real(dp), parameter :: dens0 = 0.0024535904882592957
real(dp), parameter :: pres0 = 2.1309232076296036e-13
real(dp), parameter :: rc = 0.07906945269055088
real(dp), parameter :: dc = 386.34489645765456

real(dp), parameter :: velx0 = 0.0
real(dp), parameter :: vely0 = 0.0

real(dp), parameter :: kappa = 5.0_dp/3.0_dp

real(dp), parameter :: blast_sigma = 0.5_dp*rc

real(dp), parameter :: blast_ener_normalized = blast_energy/SQRT((2*pi)**N_DIMS)/blast_sigma**N_DIMS

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

real(dp), parameter :: diameter = 5.0

real(dp), parameter :: xlim(2) = diameter * ((/0.0,1.0/) - 0.0)
real(dp), parameter :: ylim(2) = diameter * ((/0.0,1.0/) - 0.0)

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

integer, parameter :: mesh_minlevel = 6
integer, parameter :: mesh_maxlevel = 6

real(dp), parameter :: setup_amr_threshold_refine = -6
real(dp), parameter :: setup_amr_threshold_coarsen = -7

real(dp), parameter :: dens_refine_threshold = 1.3*dens0
real(dp), parameter :: dens_coarse_threshold = 1.2*dens0

# if DO_PROFILING
integer, parameter :: prof_report_rate = 64
# endif

end module


!!# FUNCTION MODULE: <FUN_xyPOLYGON>
MODULE FUN_xyPOLYGON

!!## PURPOSE
!! Determine a polygon as a (properly) ordered list of points,
!! from the minimum x/y valued point, counter-clockwise.

!!## EXTERNAL KINDS
USE KND_IntrinsicTypes,ONLY: KIND_Rsp,KIND_Rdp !!((01-A-KND_IntrinsicTypes.f90))

!!## EXTERNAL PARAMETERS
USE PAR_ComputationalGeometry                  !!((02-A-PAR_ComputationalGeometry.f90))

!!## EXTERNAL PROCEDURES
USE FUN_Error                                  !!((04-A-FUN_Error.f90))
USE FUN_xyCONTIGUOUS                           !!((06-B-FUN_xyCONTIGUOUS.f90))
USE FUN_xyCONVEXHULL                           !!((07-B-FUN_xyCONVEXHULL.f90))
USE FUN_xyORDER                                !!((04-B-FUN_xyORDER.f90))
USE FUN_Reorder                                !!((05-A-FUN_Reorder.f90))

!!## DEFAULT IMPLICIT
IMPLICIT NONE

!!## DEFAULT ACCESS
PRIVATE

!!## PROCEDURE OVERLOADING
INTERFACE xyPOLYGON_Px
 MODULE PROCEDURE xyPOLYGON_Px_Rsp
 MODULE PROCEDURE xyPOLYGON_Px_Rdp
 MODULE PROCEDURE xyPOLYGON_Px_order_Rsp
 MODULE PROCEDURE xyPOLYGON_Px_order_Rdp
END INTERFACE

INTERFACE xyPOLYGON_Lsx
 MODULE PROCEDURE xyPOLYGON_Lsx_Rsp
 MODULE PROCEDURE xyPOLYGON_Lsx_Rdp
END INTERFACE

INTERFACE xyPOLYGON_
 MODULE PROCEDURE xyPOLYGON__Rsp
 MODULE PROCEDURE xyPOLYGON__Rdp
END INTERFACE

!!## PUBLIC ACCESS LIST
PUBLIC :: xyPOLYGON_Px
PUBLIC :: xyPOLYGON_Lsx
PUBLIC :: xyPOLYGON_

!!## MODULE PROCEDURES
CONTAINS

PURE FUNCTION xyPOLYGON_Px_Rsp( N , Px ) RESULT( xyPg )
!!#### LOCAL KINDS
USE KND_IntrinsicTypes,ONLY: KIND_R=>KIND_Rsp  !!((01-A-KND_IntrinsicTypes.f90))
INCLUDE "08-A-FUN_xyPOLYGON_Px.f90.hdr"
!!--begin--
INCLUDE "08-A-FUN_xyPOLYGON_Px.f90.bdy"
!!--end--
END FUNCTION

PURE FUNCTION xyPOLYGON_Px_Rdp( N , Px ) RESULT( xyPg )
!!#### LOCAL KINDS
USE KND_IntrinsicTypes,ONLY: KIND_R=>KIND_Rdp  !!((01-A-KND_IntrinsicTypes.f90))
INCLUDE "08-A-FUN_xyPOLYGON_Px.f90.hdr"
!!--begin--
INCLUDE "08-A-FUN_xyPOLYGON_Px.f90.bdy"
!!--end--
END FUNCTION

FUNCTION xyPOLYGON_Px_order_Rsp( N , Px , order ) RESULT( xyPg )
!!#### LOCAL KINDS
USE KND_IntrinsicTypes,ONLY: KIND_R=>KIND_Rsp  !!((01-A-KND_IntrinsicTypes.f90))
INCLUDE "08-A-FUN_xyPOLYGON_Px_order.f90.hdr"
!!--begin--
INCLUDE "08-A-FUN_xyPOLYGON_Px_order.f90.bdy"
!!--end--
END FUNCTION

FUNCTION xyPOLYGON_Px_order_Rdp( N , Px , order ) RESULT( xyPg )
!!#### LOCAL KINDS
USE KND_IntrinsicTypes,ONLY: KIND_R=>KIND_Rdp  !!((01-A-KND_IntrinsicTypes.f90))
INCLUDE "08-A-FUN_xyPOLYGON_Px_order.f90.hdr"
!!--begin--
INCLUDE "08-A-FUN_xyPOLYGON_Px_order.f90.bdy"
!!--end--
END FUNCTION

PURE FUNCTION xyPOLYGON_Lsx_Rsp( N , Lsx ) RESULT( xyPg )
!!#### LOCAL KINDS
USE KND_IntrinsicTypes,ONLY: KIND_R=>KIND_Rsp  !!((01-A-KND_IntrinsicTypes.f90))
INCLUDE "08-A-FUN_xyPOLYGON_Lsx.f90.hdr"
!!--begin--
INCLUDE "08-A-FUN_xyPOLYGON_Lsx.f90.bdy"
!!--end--
END FUNCTION

PURE FUNCTION xyPOLYGON_Lsx_Rdp( N , Lsx ) RESULT( xyPg )
!!#### LOCAL KINDS
USE KND_IntrinsicTypes,ONLY: KIND_R=>KIND_Rdp  !!((01-A-KND_IntrinsicTypes.f90))
INCLUDE "08-A-FUN_xyPOLYGON_Lsx.f90.hdr"
!!--begin--
INCLUDE "08-A-FUN_xyPOLYGON_Lsx.f90.bdy"
!!--end--
END FUNCTION

PURE FUNCTION xyPOLYGON__Rsp( ARRAY ) RESULT( xyPg )
!!#### LOCAL KINDS
USE KND_IntrinsicTypes,ONLY: KIND_R=>KIND_Rsp  !!((01-A-KND_IntrinsicTypes.f90))
INCLUDE "08-A-FUN_xyPOLYGON_.f90.hdr"
!!--begin--
INCLUDE "08-A-FUN_xyPOLYGON_.f90.bdy"
!!--end--
END FUNCTION

PURE FUNCTION xyPOLYGON__Rdp( ARRAY ) RESULT( xyPg )
!!#### LOCAL KINDS
USE KND_IntrinsicTypes,ONLY: KIND_R=>KIND_Rdp  !!((01-A-KND_IntrinsicTypes.f90))
INCLUDE "08-A-FUN_xyPOLYGON_.f90.hdr"
!!--begin--
INCLUDE "08-A-FUN_xyPOLYGON_.f90.bdy"
!!--end--
END FUNCTION

END MODULE


subroutine timestep
!
!
! Determine maximum safe timestep for the simulation
! Must account for viscous evolution and planetary torques
! Timestep cannot exceed predefined maximum
!
!

use gravdata
use unitdata, only: yr,tdump
use planetdata, only: torque_term, planetchoice

implicit none

integer :: i
real(kind=8) :: dtmin,C0,C1,dr2,dr
real :: dtvisc, dtmin_visc, dttorq, dtmin_torque

dtmin_visc = 1.0e30
dtmin_torque = dtmin_visc

If (t .lt. 1.0d6) Then
   C0 = 0.01d0
Else If (t .lt. 1.0d7) Then
   C0 = 0.05d0
Else
   C0 = 0.25d0
EndIf
C1 = 0.5d0

!C0 = C0/10.0

do i = isr, ier

   ! Compute minimum viscous timestep
   dr  = (rf(i+1)-rf(i))
   dr2 = dr**2
   dtvisc  = C0 * dr2 / (6.0d0 * nu_tc(i))
   dtmin_visc = min(dtmin_visc,dtvisc)
   !dtmin = min(dtmin,0.001*tcool(i))

   ! If planets present, compute minimum timestep due to torques
   if(planetchoice=='y') then
      if(torque_term(i)>1.0e-30) then
         dttorq = C0*dr*rz(i)*sigma(i)/torque_term(i)
      else
         dttorq = 1.0e30
      endif

      dtmin_torque = min(dtmin_torque, dttorq)
   endif

enddo

dt = dtmin_visc
dt = min(dtmin_visc, dtmin_torque)
dt = min(dt,maxstep*yr) ! timestep can not exceed maxstep

!print*, t/yr,dt/yr, dtmin_visc/dtmin_torque
IF(dt>tdump) then
   print*, 'Reducing dt for rapid snapshotting'
   dt = tdump/10.0
endif

end subroutine timestep


program main ! Интерполяция сплайнами с использованием библиотеки FGSL
use Task ! Модуль с процедурами
implicit none

     real(fgsl_double), allocatable, dimension(:) :: x_array, y_array ! Входные массивы
     real(fgsl_double) x ! Аргумент, при котором будем искать значение аппроксимирующей функции

     integer n ! Размер входных массивов
     integer ier ! Вспомогательная переменная

     ! Считывание размера входных массивов
     read(*,'()'); read(*,*) n

     ! Считывание аргумента, при котором будем искать значение аппроксимирующей функции
     read(*,'(/)'); read(*,*) x

     ! Выделение памяти под массивы
     allocate(x_array(n), stat = ier)
     if (ier .ne. 0) stop 'Не могу выделить память для массива x_array'

     allocate(y_array(n), stat = ier)
     if (ier .ne. 0) stop 'Не могу выделить память для массива y_array'

     ! Считывание входных массивов
     read(*,'(/)'); read(*,*) x_array
     read(*,'(/)'); read(*,*) y_array

     ! Вызов функции, вывод результата
     write(*,'(/,f10.5,1X,/)') GetSplineValue(x, x_array, y_array)

     deallocate(x_array, y_array)

end


C
C**************************  BASIS6 ************************************
C
C  calculate the local basis function coefficients.
C  Basis function coefficients are divided by 6.
C
C***********************************************************************
C
      SUBROUTINE BASIS6(IP4,TETRAL,X,Y,Z,AIL,BIL,CIL,DIL)
C
      IMPLICIT  NONE
      INTEGER   I,J,M,II,NN,LC,LR
      INTEGER   IP4(4,4),IP3(3,3),TETRAL(5)
      REAL*8    A2,A3
      REAL*8    X(*),Y(*),Z(*),AIL(4),BIL(4),CIL(4),DIL(4)
      REAL*8    AMEN(5)
      DATA      AMEN/-1.0D0,1.0D0,-1.0D0,1.0D0,-1.0D0/
C
      DO NN=1,4
         DO II=2,4
            IP3(II-1,1)=IP4(II,NN)
         END DO
         DO LC=2,3
            DO 7 LR=1,3
               IF(LR.EQ.3) IP3(LR,LC)=IP3(1,LC-1)
               IF(LR.EQ.3) GO TO 7
               IP3(LR,LC)=IP3(LR+1,LC-1)
    7       CONTINUE
         END DO
         A3=0.0D0
         DO II=1,3
            I=TETRAL(IP3(II,1))
            J=TETRAL(IP3(II,2))
            M=TETRAL(IP3(II,3))
            A3=A3 + X(M) * (Y(I)*Z(J) - Z(I)*Y(J))
         END DO
         AIL(NN)=AMEN(NN+1)*A3/6.0D0
         A2=0.0D0
         A3=0.0D0
         DO II=1,3
            I=TETRAL(IP3(II,1))
            J=TETRAL(IP3(II,2))
            M=TETRAL(IP3(II,3))
            A3=Y(I)*Z(J) + A3
            A2=Y(I)*Z(M) + A2
         END DO
         BIL(NN)=AMEN(NN)*(A3-A2)/6.0D0
         A2=0.0D0
         A3=0.0D0
         DO II=1,3
            I=TETRAL(IP3(II,1))
            J=TETRAL(IP3(II,2))
            M=TETRAL(IP3(II,3))
            A3=X(I)*Z(J) + A3
            A2=X(I)*Z(M) + A2
         END DO
         CIL(NN)=AMEN(NN+1)*(A3-A2)/6.0D0
         A2=0.0D0
         A3=0.0D0
         DO II=1,3
            I=TETRAL(IP3(II,1))
            J=TETRAL(IP3(II,2))
            M=TETRAL(IP3(II,3))
            A3=X(I)*Y(J) + A3
            A2=X(I)*Y(M) + A2
         END DO
         DIL(NN)=AMEN(NN)*(A3-A2)/6.0D0
      END DO
C
      RETURN
      END


!==============================================================================!
  real function U_Plus_Log_Law(y_plus)
!------------------------------------------------------------------------------!
!   Calculates U+ from log law.                                                !
!------------------------------------------------------------------------------!
!----------------------------------[Modules]-----------------------------------!
  use Rans_Mod, only: e_log, kappa
!------------------------------------------------------------------------------!
  implicit none
!---------------------------------[Arguments]----------------------------------!
  real :: y_plus
!==============================================================================!

  U_Plus_Log_Law = log( max(y_plus, 1.05) * e_log ) / kappa

  end function


C
C**************************  CONCUPD ***********************************
C
C  update surface CONCENTRATION FOR COUPLING SURFACE AND SUBSURFACE TRANSPORT
C
C***********************************************************************
C
      SUBROUTINE CONCUPD(NNOD,IFATM,IFATMP,DELTAT,PONDNOD,
     1     ARENOD,ATMPOT,ATMACT,CONCNOD,ATMCONC,
     2     CONCNODUPD)
C
      IMPLICIT NONE
      INTEGER  NNOD,I
      INTEGER  IFATM(*),IFATMP(*)
      REAL*8   DELTAT
      REAL*8   PONDNOD(*),ARENOD(*),ATMPOT(*),ATMACT(*)
      REAL*8   CONCNOD(*),ATMCONC(*),CONCNODUPD(*)
      REAL*8   VOLTOT(NNOD),MASSURF(NNOD),MASSPOT(NNOD)
      INCLUDE  'IOUNITS.H'
C

      DO I = 1,NNOD
         CONCNODUPD(I) = CONCNOD(I)
         IF (IFATMP(I) .EQ. 2 .AND. IFATM(I) .EQ. 2) THEN
C     RAINFALL/INFILTRATION CASE
            IF ((ATMPOT(I) .GE. 0.) .AND. (ATMACT(I) .GE. 0.)) THEN
               VOLTOT(I) = PONDNOD(I)*ARENOD(I) + ATMPOT(I)*DELTAT
               MASSURF(I) =  PONDNOD(I)*ARENOD(I)*CONCNOD(I)
               MASSPOT(I) = ATMPOT(I)*DELTAT*ATMCONC(I)
C
               CONCNODUPD(I) = (MASSURF(I)+MASSPOT(I))/VOLTOT(I)
C     EVAPORATION/INFILTRATION CASE
            ELSEIF ((ATMPOT(I) .LT. 0.) .AND. (ATMACT(I) .GT. 0.)) THEN
               VOLTOT(I) = PONDNOD(I)*ARENOD(I) + ATMPOT(I)*DELTAT
               MASSURF(I) =  PONDNOD(I)*ARENOD(I)*CONCNOD(I)
C
               CONCNODUPD(I) = MASSURF(I)/VOLTOT(I)
            END IF
         END IF
      END DO
C
      RETURN
      END


      SUBROUTINE M50MDT(TSEC50,KFLAG,ROTMTX)
      IMPLICIT REAL*8(A-H,O-Z)
C
C  THIS ROUTINE COMPUTES THE MATRICES USED TO ROTATE VECTORS BETWEEN
C  MEAN OF 1950.0 AND MEAN OF DATE COORDINATES.
C
C  MEAN OF 1950.0 IS A COORDINATE SYSTEM ASSOCIATED WITH THE
C  BEGINNING OF THE BESSELIAN YEAR 1950. IT HAS JULIAN EPHEMERIS
C  DATE 2433282.423, 0.077 DAYS BEFORE EPHEMERIS DATE 1/1/50, 0.0 HRS.
C
C  VARIABLE DIM TYPE I/O DESCRIPTION
C  -------- --- ---- --- -----------
C
C  TSEC50    1  R*8   I  TIME ASSOCIATED WITH THE MEAN OF DATE
C                        COORDINATE SYSTEM. I.E., ROTATION IS BETWEEN
C                        THE MEAN OF 1950.0 AND THE MEAN OF TSEC50
C                        COORDINATE SYSTEMS. IN SECONDS SINCE
C                        0.0 HOURS, 1/1/50, ET. ACCURACY IS NOT HIGH
C                        ENOUGH TO WARRANT ET-UT CORRECTION. TIME MAY BE
C                        UT IF IT IS MORE CONVENIENT.
C
C  KFLAG     1  I*4   I  FLAG TELLING ROUTINE DIRECTION OF ROTATION.
C                        = NEGATIVE, FROM MEAN OF DATE TO MEAN OF 1950.0
C                        = OTHERWISE, FROM MEAN OF 1950.0 TO MEAN OF DATE.
C
C  ROTMTX   3,3 R*8   O  THE ROTATION MATRIX. ROTATION IS DONE
C                        EXTERNALLY BY:
C                         VEC2(I)=ROTMTX(I,J)*VEC1(J), SUMMING ON J.
C                         IF KFLAG IS NEGATIVE, VEC1 IS MEAN OF DATE.
C                         OTHERWISE, VEC1 IS MEAN OF 1950.0
C
C**********************************************************************
C
C  BY C PETRUZZO, 12/82.
C   MODIFIED.........
C           7/83. CJP. CHANGED DAYCENT VALUE.
C
C**********************************************************************
C
C  >> NOTE: FORMULAE AND CONSTANTS WERE TAKEN FROM THE EXPLANATORY
C           SUPPLEMENT TO THE ASTRONOMICAL EPHEMERIS AND THE AMERICAN
C           EPHEMERIS AND NAUTICAL ALMANAC, 1974(=1961 + AMMENDMENTS).
C           IN THE GSFC LIBRARY, NUMBER= QB8.U5, E96.
C
      REAL*8  A(3,3),ROTMTX(3,3),SECDAY/86400.D0/,TLAST/-1.D30/
C     SET NUMBER OF DAYS IN A TROPICAL CENTURY. SUPPLEMENT, PAGE 22.
      REAL*8  DAYCENT/36524.21988D0/
C
      IF(TSEC50.EQ.TLAST) GO TO 800
C
      TLAST=TSEC50
      T=TSEC50/SECDAY+0.077D0     ! DAYS SINCE BESSELIAN YEAR 1950.0
      T1 = T/DAYCENT              ! TROPICAL CENTURIES SINCE BYR 1950.0
      T2 = T1 * T1
      T3 = T2 * T1
C
C     GET ROTATION MATRIX FOR MEAN OF 1950.0 TO MEAN OF DATE. PAGE 34.
      A(1,1) = 1.D0                   - 29696.D-8 * T2  -  13.D-8 * T3
      A(1,2) =      -2234941.D-8 * T1 -   676.D-8 * T2  + 221.D-8 * T3
      A(1,3) =      - 971690.D-8 * T1 +   207.D-8 * T2  +  96.D-8 * T3
      A(2,1) = -A(1,2)
      A(2,2) = 1.D0                   - 24975.D-8 * T2  -  15.D-8 * T3
      A(2,3) =                        - 10858.D-8 * T2
      A(3,1) = -A(1,3)
      A(3,2) =  A(2,3)
      A(3,3) = 1.D0                   -  4721.D-8 * T2
C
  800 CONTINUE
      IF(KFLAG.LT.0) THEN
C       MEAN OF DATE TO MEAN OF 1950.
        DO 20 I=1,3
        DO 20 J=1,3
   20   ROTMTX(I,J)=A(J,I)
      ELSE
C       MEAN OF 1950.0 TO MEAN OF DATE.
        DO 30 I=1,3
        DO 30 J=1,3
   30   ROTMTX(I,J)=A(I,J)
        END IF
C
      RETURN
      END


      subroutine krnlupdateandreducecolumn( m, n, v, cs, ldcs )

      implicit none

*
*     PURPOSE
*     =======
*
*     TODO Describe the purpose.
*
*
*     ARGUMENTS
*     =========
*
*     TODO Describe the arguments.
*

*
*     Scalar arguments.
*
      integer m, n, ldcs

*
*     Array arguments.
*
      double precision v( * ), cs( ldcs, * )

*
*     Externals.
*
      external dlartg

*
*     Local scalars.
*
      integer i, j
      double precision c, s, x, y

*
*     EXECUTABLE STATEMENTS
*     =====================
*

*
*     Apply the n - 1 previous sequences.
*
      do j = 1, n - 1
         y = v( m )
         do i = m, j + 1, -1
            c = cs( i, 2 * j - 1 )
            s = cs( i, 2 * j     )
            x = v( i - 1 )
            v( i ) = - s * x + c * y
            y      =   c * x + s * y
         end do
         v( j ) = y
      end do

*
*     Generate the n-th sequence.
*
      do i = m, n + 1, -1
         x = v( i - 1 )
         call dlartg( x, v( i ),
     $      cs( i, 2 * n - 1 ), cs( i, 2 * n ),
     $      v( i - 1 ) )
      end do

      end subroutine


SUBROUTINE force_lj1
USE PARACLUSTER
USE CLUSTER
USE POTENTIAL
USE ENFORCE
USE DISTANCE
!
Implicit None
Intrinsic sqrt
Integer :: i,k!,j,icolor,ierr
Integer :: nat3d!,itypik
Real  :: fDx(nsiz),fDy(nsiz),fDz(nsiz)
Real :: rik,rik2,rik3,rik6,rik12
Real :: dik,xik,yik,zik!dik0,xuar,yvar,zwar
Real :: wtot,wtote
Real :: eneri!,eri!,f,for,forsudik,denik
!!Real :: fbx,fby,fbz

!aretebim=arete(1)
! pay attention to the units: in fact,
! we have all the routine which calculates the velocities and the positions
! in eV (for energy!) and arete (for position!)
! Initially considers energy in eV BUT position in Angstrom

      ener=0.d0
      eneri=0.d0
!!      dik0=dc1  !! distance NN in arete
!do i=1,natom-1
! do k=i+1,natom
!          if((itype(i).eq.1).and.(itype(k).eq.1)) then
!             itypik=1   ! same A
!          else if((itype(i).eq.2).and.(itype(k).eq.2)) then
!             itypik=2   ! same B
!          else
!             itypik=3  ! alloy A-B
!          endif
!        dik0=dist(itypik)
!  enddo
!enddo

! old values for force dfx,dfy,dfz
nat3d=natom
      do i=1,nat3d
       dfx(i)=fx(i)
       dfy(i)=fy(i)
       dfz(i)=fz(i)
      enddo
      do i=1,nat3d
        fx(i)=0.d0
        fy(i)=0.d0
        fz(i)=0.d0
        fDx(i)=0.d0
        fDy(i)=0.d0
        fDz(i)=0.d0
      enddo

 do i=1,nat3d
   do  k=1+i,nat3d

          xik=x(k)+u(k)-x(i)-u(i)
          yik=y(k)+v(k)-y(i)-v(i)
          zik=z(k)+w(k)-z(i)-w(i)

          dik=sqrt(xik*xik+yik*yik+zik*zik)   !Arete units
          rik=aretebim*dik         !in A
          rik=rik/R0

!          if((ipas.eq.1).or.(ipas.eq.3))write(*,*) rik,'rik',i,k

          rik2=rik*rik
          rik3=rik2*rik
          rik6=rik3*rik3
          rik12=rik6*rik6

 !!calculate the forces in 1/arete
 !!then is converted again to eV and arete
 !! f(i)= f(i) in eV/arete  !!

               wtot=(1.d0/rik6-1.d0/rik12)  !in A
               wtote=(1.d0/rik12-2.d0/rik6) !in A

    ! this is the potential
         ener=ener+wtote

    ! this is the force  in 1/arete

                           !e' il meno della derivata
              fDx(i)=fDx(i)+aretebim*xik*wtot/rik2
              fDy(i)=fDy(i)+aretebim*yik*wtot/rik2
              fDz(i)=fDz(i)+aretebim*zik*wtot/rik2

              fDx(k)=fDx(k)-aretebim*xik*wtot/rik2
              fDy(k)=fDy(k)-aretebim*yik*wtot/rik2
              fDz(k)=fDz(k)-aretebim*zik*wtot/rik2

        enddo

        fx(i)=fDx(i)*12.d0*U0*aretebim    !in ev/arete
        fy(i)=fDy(i)*12.d0*U0*aretebim
        fz(i)=fDz(i)*12.d0*U0*aretebim

!        fx(k)=fDx(k)*12.d0*U0*aretebim    !in ev/arete
!        fy(k)=fDy(k)*12.d0*U0*aretebim
!        fz(k)=fDz(k)*12.d0*U0*aretebim

enddo

          !ener=0.25*ener*U0   ! in eV
          ener=ener*U0   ! in eV

END SUBROUTINE force_lj1


! Windowed Green function method matrices and functions
module WGFM_matrices
    use mpi
    use meshread_mod
    use tools
    use window_mod
    use WGFM_SauterSchwab
    implicit none

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

    private :: gather_MPImatrix, assemble_matrix

contains
    ! Computes the WGFM matrices
    subroutine genWGFMMat(msh, w, k1, k2, ep1, ep2, mu1, mu2, ZMat)
        type(Mesh), intent(in) :: msh
        real(8), intent(in) :: w         ! Angular frequency [rad/s]
        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]

        complex(8), allocatable, intent(out) :: ZMat(:,:)  ! WGFM matrix

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

        complex(8), allocatable :: Z1_bff(:,:,:), Z1_gather(:,:,:)
        complex(8), allocatable :: Z2_bff(:,:,:), Z2_gather(:,:,:)
        complex(8), allocatable :: Z3_bff(:,:,:), Z3_gather(:,:,:)
        complex(8), allocatable :: E_bff(:,:,:), E_gather(:,:,:)

        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, N_procs
        integer :: pos(3, 2), cnt
        complex(8) :: intg(3, 3)

        real(8) :: window_weights(nQ)           ! contains the window weights of a single element
        real(8) :: window_data(nQ, msh%nbELm)   ! contains the window weights of all elements
        integer :: n1, n2, n3, n4
        integer :: n_triangle
        type(SSDataType) :: ssdata    ! holds Sauter-Schwab quadrature data

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

        ! allocate buffer matrix
        allocate(Z1_bff(3, msh%nbEdg, finish-start+1))
        allocate(Z2_bff(3, msh%nbEdg, finish-start+1))
        allocate(Z3_bff(3, msh%nbEdg, finish-start+1))
        allocate(E_bff(3, msh%nbEdg, finish-start+1))
        Z1_bff = 0.0d0
        Z2_bff = 0.0d0
        Z3_bff = 0.0d0
        E_bff = 0.0d0

        ! initialize quadratures
        call gaussQuadratureTriangles(V, wei, nQ)
        call init_ssdata(ssdata, nSG)

        n_triangle = 0
        do j = start, finish ! loop over the elements
            n_triangle = n_triangle + 1
            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)

                ! compute window weights
                ! if not already computed
                if (j == start) then
                    window_data(:, i) = compute_window_weights(pp)
                end if
                window_weights = window_data(:, i)

                ! 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_WGF(ssdata,intg,k1,k2,p,p_src_nod,len_i,A_i,opp_nod_i,n_j)
                    Z2_bff(:,edg_i,n_triangle) = Z2_bff(:,edg_i,n_triangle) + 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_WGF(ssdata,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)
                    Z2_bff(:,edg_i,n_triangle) = Z2_bff(:,edg_i,n_triangle) + 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_WGF(ssdata,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)
                    Z2_bff(:,edg_i,n_triangle) = Z2_bff(:,edg_i,n_triangle) + 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

                            ! Windowed Green's functions
                            G1 = exp(iu*k1*R)/R/(4.0d0*pi) * window_weights(ii)
                            G2 = exp(iu*k2*R)/R/(4.0d0*pi) * window_weights(ii)

                            Gp1 = (iu*k1-1.0d0/R) * G1
                            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 = 1d0/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(m,edg_i(n),n_triangle) = Z1_bff(m,edg_i(n),n_triangle) + qweight*(mu2*K2Mat - mu1*K1Mat)

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

                                    ! compute EFIE matrix entries
                                    ! only if they weren't computed before
                                    if (cnt == 0) then
                                        T21Mat = 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(m,edg_i(n),n_triangle) = Z2_bff(m,edg_i(n),n_triangle) + qweight*T21Mat
                                    end if
                                enddo
                            enddo
                        enddo
                    enddo
                end if
            enddo

            ! Identity operator computation
            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(m,edg_j(n),n_triangle) = E_bff(m,edg_j(n),n_triangle) + A_j*wei(jj)*sum(f_m*f_n)
                    enddo
                enddo
            enddo
        enddo

        call mpi_comm_rank(MPI_comm_world,id,ierr)
        call mpi_comm_size(MPI_comm_world, N_procs, ierr)

        ! Gather matrices data into the root process
        call gather_MPImatrix(3, msh%nbEdg, msh%nbELm, id, N_procs, Z1_bff, Z1_gather)
        deallocate(Z1_bff)

        call gather_MPImatrix(3, msh%nbEdg, msh%nbELm, id, N_procs, Z2_bff, Z2_gather)
        deallocate(Z2_bff)

        call gather_MPImatrix(3, msh%nbEdg, msh%nbELm, id, N_procs, Z3_bff, Z3_gather)
        deallocate(Z3_bff)

        call gather_MPImatrix(3, msh%nbEdg, msh%nbELm, id, N_procs, E_bff, E_gather)
        deallocate(E_bff)

        if (id == 0) then
            ! Assemble matrices in root process
            call assemble_matrix(msh, Z1_gather, Z1)
            deallocate(Z1_gather)

            call assemble_matrix(msh, Z2_gather, Z2)
            deallocate(Z2_gather)

            call assemble_matrix(msh, Z3_gather, Z3)
            deallocate(Z3_gather)

            call assemble_matrix(msh, E_gather, EMat)
            deallocate(E_gather)

            ! Assemble WGFM matrix in root process
            n1 = 1
            n2 = msh%nbEdg
            n3 = msh%nbEdg + 1
            n4 = 2 * msh%nbEdg
            allocate(ZMat(n4, n4))
            ZMat(n1:n2, n1:n2) = -IU*w/2d0*(mu2+mu1)*EMat + IU*w*Z1
            ZMat(n3:n4, n3:n4) = IU*w/2d0*(ep2+ep1)*EMat - IU*w*Z3
            ZMat(n1:n2, n3:n4) = Z2
            ZMat(n3:n4, n1:n2) = Z2
            deallocate(Z1, Z2, Z3, EMat)
        end if
    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(:,:,:) ! S1 potential
        complex(8), allocatable, intent(out) :: H1Pot(:,:,:) ! D1 potential
        complex(8), allocatable, intent(out) :: E2Pot(:,:,:) ! S2 potential
        complex(8), allocatable, intent(out) :: H2Pot(:,:,:) ! D2 potential

        complex(8), allocatable :: E1Pot_bff(:,:,:), E1Pot_aux(:,:,:)
        complex(8), allocatable :: H1Pot_bff(:,:,:), H1Pot_aux(:,:,:)
        complex(8), allocatable :: E2Pot_bff(:,:,:), E2Pot_aux(:,:,:)
        complex(8), allocatable :: H2Pot_bff(:,:,:), H2Pot_aux(:,:,:)

        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, N_procs
        real(8) :: wei(nQ), V(nQ,3), pp(nQ,3)
        real(8) :: qweight
        integer :: nEvl, jEvl

        real(8) :: window_weights(nQ)           ! contains the window weights of a single element
        real(8) :: window_data(nQ, msh%nbELm)   ! contains the window weights of all elements

        call gaussQuadratureTriangles(V, wei, nQ)

        nEvl = size(xEvl, 1)
        call divide_work(start, finish, nEvl)

        ! Allocate buffer matrices
        allocate(E1Pot_bff(3, msh%nbEdg, finish-start+1))
        allocate(H1Pot_bff(3, msh%nbEdg, finish-start+1))
        allocate(E2Pot_bff(3, msh%nbEdg, finish-start+1))
        allocate(H2Pot_bff(3, msh%nbEdg, finish-start+1))
        E1Pot_bff = 0.0d0
        H1Pot_bff = 0.0d0
        E2Pot_bff = 0.0d0
        H2Pot_bff = 0.0d0

        jEvl = 0
        do j=start,finish
            jEvl = jEvl + 1
            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)

                ! compute window weights
                ! if not already computed
                if (j == start) then
                    window_data(:, i) = compute_window_weights(pp)
                end if
                window_weights = window_data(:, i)

                do ii = 1,nQ
                    Rvec  = x-pp(ii,:)
                    R     = sqrt(sum(Rvec*Rvec))

                    ! Windowed Green's functions
                    G1 = exp(iu*k1*R)/R/(4.0d0*pi) * window_weights(ii)
                    G2 = exp(iu*k2*R)/R/(4.0d0*pi) * window_weights(ii)

                    Gp1 = (iu*k1-1.0d0/R) * G1
                    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(:,edg_i(n),jEvl) = E1Pot_bff(:,edg_i(n),jEvl) + qweight * (G1*f_n + 1d0/(k1**2)*Gp1*Rvec/R*df_n)
                        E2Pot_bff(:,edg_i(n),jEvl) = E2Pot_bff(:,edg_i(n),jEvl) + qweight * (G2*f_n + 1d0/(k2**2)*Gp2*Rvec/R*df_n)

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

        call mpi_comm_rank(MPI_comm_world,id,ierr)
        call mpi_comm_size(MPI_comm_world, N_procs, ierr)

        ! Gather matrix data into the root process
        call gather_MPImatrix(3, msh%nbEdg, nEvl, id, N_procs, E1Pot_bff, E1Pot_aux)
        deallocate(E1Pot_bff)

        call gather_MPImatrix(3, msh%nbEdg, nEvl, id, N_procs, E2Pot_bff, E2Pot_aux)
        deallocate(E2Pot_bff)

        call gather_MPImatrix(3, msh%nbEdg, nEvl, id, N_procs, H1Pot_bff, H1Pot_aux)
        deallocate(H1Pot_bff)

        call gather_MPImatrix(3, msh%nbEdg, nEvl, id, N_procs, H2Pot_bff, H2Pot_aux)
        deallocate(H2Pot_bff)

        ! Transpose matrices
        if (id == 0) then
            allocate(E1Pot(nEvl, msh%nbEdg, 3))
            E1Pot(:, :, 1) = transpose(E1Pot_aux(1, :, :))
            E1Pot(:, :, 2) = transpose(E1Pot_aux(2, :, :))
            E1Pot(:, :, 3) = transpose(E1Pot_aux(3, :, :))
            deallocate(E1Pot_aux)

            allocate(E2Pot(nEvl, msh%nbEdg, 3))
            E2Pot(:, :, 1) = transpose(E2Pot_aux(1, :, :))
            E2Pot(:, :, 2) = transpose(E2Pot_aux(2, :, :))
            E2Pot(:, :, 3) = transpose(E2Pot_aux(3, :, :))
            deallocate(E2Pot_aux)

            allocate(H1Pot(nEvl, msh%nbEdg, 3))
            H1Pot(:, :, 1) = transpose(H1Pot_aux(1, :, :))
            H1Pot(:, :, 2) = transpose(H1Pot_aux(2, :, :))
            H1Pot(:, :, 3) = transpose(H1Pot_aux(3, :, :))
            deallocate(H1Pot_aux)

            allocate(H2Pot(nEvl, msh%nbEdg, 3))
            H2Pot(:, :, 1) = transpose(H2Pot_aux(1, :, :))
            H2Pot(:, :, 2) = transpose(H2Pot_aux(2, :, :))
            H2Pot(:, :, 3) = transpose(H2Pot_aux(3, :, :))
            deallocate(H2Pot_aux)
        end if
    end subroutine genWGFMPot

    ! Computes the right hand side
    ! of the WGFM
    subroutine genWGFMRHS(msh, Esrc, Hsrc, MJsrc)
        type(Mesh), intent(in) :: msh
        complex(8), intent(in) :: Esrc(msh%nbNod, 3)  ! Electric field src at mesh nodes
        complex(8), intent(in) :: Hsrc(msh%nbNod, 3)  ! Magnetic field src at mesh nodes
        complex(8), allocatable, intent(out) :: MJsrc(:) ! [Msrc, Jsrc] vector

        complex(8) :: Msrc(msh%nbEdg), Jsrc(msh%nbEdg)
        complex(8) :: E1(3),E2(3),E3(3)
        complex(8) :: H1(3),H2(3),H3(3)
        real(8) :: A_j,len_j(3),q(3,3),q_src_nod(3,3)
        real(8) :: f_j(3,3),n_j(3)
        integer  :: nd_j(3),edg_j(3),opp_nod_j(3)
        integer :: j,m

        ! initialize with zeros
        Msrc = 0.0d0
        Jsrc = 0.0d0

        do j = 1,msh%nbELm ! 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,:)

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

            do m=1,3 ! loop over the edges
                f_j  = sign(1,opp_nod_j(m))*len_j(m)*(spread(q_src_nod(m,:),1,3)-q)/(2.0d0*A_j)

                ! Msrc
                E1 = cross(n_j,real(Esrc(nd_j(1),:)))+iu*cross(n_j,aimag(Esrc(nd_j(1),:)))
                E2 = cross(n_j,real(Esrc(nd_j(2),:)))+iu*cross(n_j,aimag(Esrc(nd_j(2),:)))
                E3 = cross(n_j,real(Esrc(nd_j(3),:)))+iu*cross(n_j,aimag(Esrc(nd_j(3),:)))
                Msrc(edg_j(m)) = Msrc(edg_j(m)) + A_j/3.0d0 * sum(f_j(1,:)*E1 + f_j(2,:)*E2 + f_j(3,:)*E3)

                ! Jsrc
                H1 = cross(n_j,real(Hsrc(nd_j(1),:)))+iu*cross(n_j,aimag(Hsrc(nd_j(1),:)))
                H2 = cross(n_j,real(Hsrc(nd_j(2),:)))+iu*cross(n_j,aimag(Hsrc(nd_j(2),:)))
                H3 = cross(n_j,real(Hsrc(nd_j(3),:)))+iu*cross(n_j,aimag(Hsrc(nd_j(3),:)))
                Jsrc(edg_j(m)) = Jsrc(edg_j(m)) + A_j/3.0d0 * sum(f_j(1,:)*H1 + f_j(2,:)*H2 + f_j(3,:)*H3)
            end do
        end do

        ! assemble MJsrc vector
        allocate(MJsrc(2*msh%nbEdg))
        MJsrc(1 : msh%nbEdg) = Msrc
        MJsrc(msh%nbEdg+1 : 2*msh%nbEdg) = Jsrc
    end subroutine genWGFMRHS

    ! Subroutine to gather a 3D array of shape (size1, size2, size3)
    ! into the root process using MPI.
    ! Each process stores a subarray of shape (size1, size2, size3/N_procs)
    subroutine gather_MPImatrix(size1, size2, size3, id, N_procs, Z_bff, Z_gather)
        integer, intent(in) :: size1, size2, size3
        integer, intent(in) :: id                        ! MPI id of each process
        integer, intent(in) :: N_procs                   ! MPI number of processes
        complex(8), intent(in) :: Z_bff(:,:,:)           ! Local matrix
        complex(8), allocatable, intent(out) :: Z_gather(:,:,:)  ! Full matrix

        integer :: i, ierr
        integer :: lWork
        integer :: rcounts(N_procs)          ! list of number of elements sent from each process
        integer :: displs(N_procs)           ! list of relative displacement between blocks of data
        integer :: mattype  ! MPI custom type

        ! Declare MPI custom type
        call MPI_TYPE_CONTIGUOUS(size1*size2, MPI_double_complex, mattype, ierr)
        call mpi_type_commit(mattype, ierr)

        if (id==0) then
            allocate(Z_gather(size1, size2, size3))
            Z_gather = 0d0

            ! MPI gatherv variables
            lWork = size3 / N_procs
            rcounts = lWork
            rcounts(N_procs) = size3 - (N_procs-1)*lWork
            displs = [((i-1)*lWork, i=1,N_procs)]
        end if

        call mpi_gatherv(Z_bff, size(Z_bff, 3), mattype, Z_gather,  &
            rcounts, displs, mattype, 0, MPI_comm_world, ierr)
        call mpi_type_free(mattype, ierr)
    end subroutine gather_MPImatrix

    ! Subroutine to assemble the system matrix (Z)
    ! from previously gathered data (Z_gather)
    subroutine assemble_matrix(msh, Z_gather, Z)
        type(Mesh), intent(in) :: msh
        complex(8), intent(in) :: Z_gather(:,:,:)
        complex(8), allocatable, intent(out) :: Z(:,:)
        integer :: j, edg_j(3)

        allocate(Z(msh%nbEdg, msh%nbEdg))
        Z = 0d0
        do j = 1, msh%nbELm                  ! loop over the elements
            edg_j = msh%ELE_EDGES(j, 1:3)    ! edge indices
            Z(edg_j, :) = Z(edg_j, :) + Z_gather(:, :, j)
        end do
    end subroutine assemble_matrix
end module


c FORTRAN Code: Monte Carlo Simulation for fraction of muons showing an RID event
c Author: Robert J. Nemiroff
c Computes fraction of HAWC events that show RID.
       program fractionRID
c
c      integer*4, parameter :: n=10
       integer*4 i, ntot, nRID, n, nmax
       real*8 c, pi, seed, pin, eps, Cangle
       real*8 R, H, Rd
       real*8 xd(4), yd(4), zd(4), th(4)
       real*8 xg, yg, zg, rg
       real*8 xs, ys, zs, rs
       real*8 xm, ym, zm, rm
       real*8 xe, ye, ze, re
       real*8 x_ge, y_ge, z_ge
       real*8 x_de(4), y_de(4), z_de(4), r_de(4)
       real*8 top, bot
       character*3 before, now, RID
c                             Constants
       nmax=1000000000
       c=3.0d8
       pi=dacos(-1.0d0)
       seed=2.8d0
       eps=0.1d0
       Cangle=dacos(1.0d0/1.33d0)*(180.0d0/pi)
       write (*,*) ' Input seed, please: '
       read (*,*) seed
c                             R=radius of tank (meters)
c                             H=height of tank (m)
c Source: https://www.sciencedirect.com/
c science/article/pii/S0273117713001695?via%3Dihub
       R=7.30d0/2.0d0
       H=4.5d0
c                             Ground dist. to detectors (check)
       Rd=7.3d0/4.0d0
       Rd=1.850d0
c                             Location of four ground detectors
       xd(1)=0.0d0
       yd(1)=0.0d0
       zd(1)=0.0d0
       xd(2)=-Rd
       yd(2)=0.0d0
       zd(2)=0.0d0
       xd(3)=Rd*cos(pi/3.0d0)
       yd(3)=Rd*sin(pi/3.0d0)
       zd(3)=0.0d0
       xd(4)=Rd*cos(pi/3.0d0)
       yd(4)=-Rd*sin(pi/3.00)
       zd(4)=0.0d0
c
       ntot=0
       nRID=0
c ********************
c                             Grand loop over muons
c ********************
       do 700 n=1, nmax
c                             Location muon hits ground
       xg=3.0d0*R*(2.0d0*pin(seed) - 1.0d0)
       yg=3.0d0*R*(2.0d0*pin(seed) - 1.0d0)
       zg=0.0d0
       rg=sqrt(xg**2 + yg**2)
       if (rg.ge.5.0d0*R) goto 700
c                             Direction muon arrived on sky
 200   xs=(2.0d0*pin(seed) - 1.0d0)
       ys=(2.0d0*pin(seed) - 1.0d0)
       zs=pin(seed)
       phi=atan(ys,xs)
c                             Angular direction of muon
       phi=2.0d0*pi*pin(seed)
       theta=acos(zs)
c                             Horizon dimming
       if (pin(seed).gt.zs**2) goto 200
c
c ********************** Find where muon enters tank ***
c
       xm=xg
       ym=yg
       zm=zg
       rm=sqrt(xm**2 + ym**2)
c                             Is muon in the tank?
       now='out'
       if (rm.lt.R.and.zm.lt.H) now='in'
c                             Step the photon back along track
 300   xm=xm + xs*eps
       ym=ym + ys*eps
       zm=zm + zs*eps
       rm=sqrt(xm**2 + ym**2)
c      write (*,310) xm/R, ym/R, zm/H, rm/R
c310   format (2x, 4(f7.4, 3x))
c                             If muon missed tank try again
c      if (rm.gt.3.0d0*R) write (*,*) ' Muon missed tank: wide'
       if (rm.gt.3.0d0*R) goto 700
c      if (zm.gt.H) write (*,*) ' Muon missed tank: high'
       if (zm.gt.H) goto 700
       before=now
c
       now='out'
       if (rm.lt.R.and.zm.lt.H) now='in'
c      if (before.eq.'out'.and.now.eq.'in') write (*,*) "In"
c                             If muon left tank then analyze
c      if (before.eq.'in'.and.now.eq.'out') write (*,*) "Out"
       if (before.eq.'in'.and.now.eq.'out') goto 500
       goto 300

c                             The muon has just entered the tank
c                             Three points: g, e, d
c                             For ground, entry, detector
c                             Find the vertex angles
 500   xe=xm
       ye=ym
       ze=zm
       re=rm
c      write (*,*)
c      write (*,*) ' xm / R = ', xm/R
c      write (*,*) ' ym / R = ', ym/R
c      write (*,*) ' zm / H = ', zm/H
c      write (*,*) ' rm / R = ', rm/R
c      write (*,*) ' rg / R = ', rg/R
c
       x_ge=xg - xe
       y_ge=yg - ye
       z_ge=zg - ze
       r_ge=sqrt(x_ge**2 + y_ge**2 + z_ge**2)
c      write (*,*) '   phi = ', phi*(180.0d0/pi)
c      write (*,*) ' theta = ', theta*(180.0d0/pi)
c      write (*,*)
c
       RID='no'
       ntot=ntot + 1
       do 600 i=1, 4
       x_de(i)=xd(i) - xe
       y_de(i)=yd(i) - ye
       z_de(i)=zd(i) - ze
       r_de(i)=sqrt(x_de(i)**2 + y_de(i)**2 + z_de(i)**2)
c
       top=x_ge*x_de(i) + y_ge*y_de(i) + z_ge*z_de(i)
       bot=r_ge * r_de(i)
       th(i)=acos(top/bot)*(180.0d0/pi)
c      write (*,*) ' th(i) = ', th(i)
       if (th(i).lt.Cangle) RID='yes'
 600   continue
       if (RID.eq.'yes') nRID=nRID + 1
 700   continue
c
       write (*,*) ' nRID, ntot = ', nRID, ntot
       write (*,*) ' RID fraction = ', float(nRID)/float(ntot)

c                             Stop the madness.
 999   stop
       end
c
c*******************************************************
c
c  Subroutine that uses pi**n algorithm.
       real*8 function pin(pseed)
       implicit real*8 (a-h,o-z)
c
       pi=dacos(-1.0d0)
       pseed=pseed*pi
       if (pseed.gt.10.0d0) pseed=pseed/10.0d0
       pin=pseed*10000.0d0 - int(pseed*10000.0d0)
c
       return
       end


      SUBROUTINE DCOSTI (N,WSAVE)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      DIMENSION       WSAVE(1)
      DATA PI /3.14159265358979323846D0/
      IF (N .LE. 3) RETURN
      NM1 = N-1
      NP1 = N+1
      NS2 = N/2
      DT = PI/FLOAT(NM1)
      FK = 0.0D0
      DO 101 K=2,NS2
         KC = NP1-K
         FK = FK+1.0D0
         WSAVE(K) = 2.0D0*SIN(FK*DT)
         WSAVE(KC) = 2.0D0*COS(FK*DT)
  101 CONTINUE
      CALL DFFTI (NM1,WSAVE(N+1))
      RETURN
      END


module DDrate

use utils
use modulation
use expt, only: resolution, resolution_integrated, lon_det, lat_det, sigma_E, E_min, E_max, A_det, mass_frac, N_elements

implicit none

double precision :: rho0, amu
parameter (rho0 = 4d-1)
parameter (amu = 931.5d3) !Define conversion factor from amu-->keV

integer :: N_smooth
parameter (N_smooth = 20)

contains

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

! Minimum velocity
function vmin(E, A, m_x)
    double precision :: E,A,m_x,vmin
    !double precision :: hour,JulianDay

    double precision :: m_A, mu
    m_A = A*0.9315
    mu =  (m_A*m_x)/(m_A+m_x)
    vmin = 3d5*SQRT((E/1d6)*(m_A)/(2*mu*mu))
end function vmin

!Reduced mass - input A as nucleon number and m_x in GeV
function reduced_m(A, m_x)
    double precision :: A, m_x, m_A, reduced_m

    m_A = 0.9315*A
    reduced_m =  (m_A * m_x)/(m_A + m_x)
end function reduced_m

! A helper function for calculating the prefactors to dRdE
function rate_prefactor(m_x)
    double precision :: m_x, rate_prefactor, mu

    mu = reduced_m(1d0, m_x)
    rate_prefactor = 4.34d41*rho0/(2.0*m_x*mu*mu)
end function rate_prefactor

! Convert an NREFT coupling to a cross section
! Coupling in GeV^-2 -> cross section in cm^2
function coupling_to_xsec(c, m_x)
    double precision :: c, m_x, coupling_to_xsec

    !0.197 GeV  = 1e13/cm
    ! -> GeV^-1 = 1.97e-14 cm
    coupling_to_xsec = (1.97e-14)**2*c**2*(reduced_m(1d0, m_x)**2)/pi
end function coupling_to_xsec

! Standard Helm Form Factor for SI scattering
function calcSIFormFactor(E, A)
    double precision :: calcSIFormFactor, E, A

    double precision :: q1, q2, s, a1, c, R1, x, J1, F

    !Convert recoil energy to momentum transfer q in keV
    q1 = SQRT(2*A*amu*E)
    !Convert q into fm^-1
    q2 = q1*(1d-12/1.97d-7)

    !Calculate nuclear parameters
    s = 0.9
    a1 = 0.52
    c = 1.23*(A**(1.0/3.0)) - 0.60
    R1 = SQRT(c*c + 7*pi*pi*a1*a1/3.0 - 5*s*s)

    x = q2*R1
    J1 = SIN(x)/x**2 - COS(x)/x
    F = 3*J1/x

    calcSIFormFactor = (F**2)*(EXP(-(q2*s)**2))

end function calcSIFormFactor

! Calculation of the free velocity integral
! now takes place in modulation.f90
!function calcEta_free(v)
!    double precision :: aplus, aminus, aesc
!    double precision :: v
!    double precision :: N, eta, calcEta_free
!
!    aplus = min(v + vlag, vesc)/(sqrt(2d0)*sigmav)
!    aminus = min(v - vlag, vesc)/(sqrt(2d0)*sigmav)
!    aesc = vesc/(sqrt(2d0)*sigmav)
!
!    N = 1.0/(erfun(aesc) - sqrt(2d0/pi)*(vesc/sigmav)*exp(-0.5*(vesc/sigmav)**2))
!
!    eta = (0.5/vlag)*(erfun(aplus) - erfun(aminus))
!    eta = eta - (1.0/(sqrt(pi)*vlag))*(aplus - aminus)*exp(-0.5*(vesc/sigmav)**2)
!
!    if (eta < 0) then
!        eta = 0
!    end if
!
!    calcEta_free = eta*N
!
!end function calcEta_free

! Spin-Independent recoil rate
! including energy and time
! depending on Earth-scattering effects
function dRdE(E, t, m_x, sigma_SI)
    double precision :: E, m_x, sigma_SI, dRdE, int_factor
    double precision :: t, angle

    integer :: i

    angle = calcIsoAngle(t, lon_det, lat_det)
    !angle = 0.5*pi
    !angle = 0

    dRdE = 0
    do i = 1, N_elements
       !For light DM, we set the form factor equal to 1
       !For consistency with DAMASCUS
       int_factor = sigma_SI*A_det(i)**2 !*calcSIFormFactor(E, A)

        dRdE = dRdE + mass_frac(i)*(interp_rho_scalar(m_x, sigma_SI, angle)/rho0)*rate_prefactor(m_x) &
            *int_factor*interp_eta_full(m_x, sigma_SI, angle, vmin(E, A_det(i), m_x))

    end do

end function dRdE

!Standard Spin-Independent recoil rate
! as above, but includes resolution correction
function dRdE_res(E, t, m_x, sigma_SI)
    double precision :: E, m_x, sigma_SI, dRdE_res
    double precision :: t

    double precision :: Elist(N_smooth), reslist(N_smooth), dRdElist(N_smooth)

    integer :: i

    Elist = 10**linspace(log10(max(E - sigma_E*5.0, 1d-4)), log10(E + sigma_E*5.0), N_smooth)

    do i = 1, N_smooth
        reslist(i) = resolution(Elist(i),E)

        if (Elist(i) < 0) then
            dRdElist(i) = 0
        else
            dRdElist(i) = dRdE(Elist(i), t, m_x, sigma_SI)
        end if
    end do

    dRdE_res = trapz(Elist, reslist*dRdElist)
end function dRdE_res

!Standard Spin-Independent recoil rate
! 'Free' (i.e. no Earth-scattering effects)
function dRdE_free(E, m_x, sigma_SI)
    double precision :: E, m_x, sigma_SI, dRdE_free, int_factor

    integer :: i

    dRdE_free = 0

    do i = 1, N_elements

        int_factor = sigma_SI*(A_det(i)**2) !*calcSIFormFactor(E, A)

        dRdE_free = dRdE_free + mass_frac(i)*rate_prefactor(m_x)*int_factor*calcEta_free(vmin(E, A_det(i), m_x))

    end do
end function dRdE_free

! Recoil rate
! Including resolution and integrating over time [t0, t1]
function dRdE_res_tint(E, t0, t1, m_x, sigma_SI)
    double precision :: A, m_x, sigma_SI, dRdE_res_tint
    double precision :: E, t0, t1
    integer :: Nt = 200

    double precision, allocatable :: tlist(:)
    double precision, allocatable :: integvals(:,:), tmp(:)

    double precision :: Elist(N_smooth), reslist(N_smooth)
    double precision :: dt

    integer :: i_t, i_E

    allocate(tlist(Nt))
    allocate(integvals(N_smooth,Nt))
    allocate(tmp(Nt))

    dt = (t1 - 1d0 - t0)/3d0

    !Note: you have to do more than 4 days of exposure for this to work...
    !Do 50 samples on each of 4 separate days
    do i_t = 0,3
        tlist((1+i_t*50):((i_t+1)*50)) = linspace(t0 + i_t*dt, t0 + i_t*dt + 1d0, 50)
    end do

    Elist = 10**linspace(log10(max(E - sigma_E*5.0, 1d-4)), log10(E + sigma_E*5.0), N_smooth)

    !write(*,*) Elist
    do i_t = 1, Nt
        do i_E = 1, N_smooth
            integvals(i_E, i_t) = resolution(E, Elist(i_E))*dRdE(Elist(i_E), tlist(i_t), m_x, sigma_SI)
        end do
    end do

    !dRdE_res_tint = trapz(tlist, integvals)
    !Integrate over energies
    do i_t = 1, Nt
        tmp(i_t) = trapz(Elist, integvals(:, i_t))
    end do

    !Integrate over time
    dRdE_res_tint = trapz(tlist, tmp)

    deallocate(tlist)
    deallocate(integvals)
    deallocate(tmp)

end function dRdE_res_tint

! Total number of events in the energy range [E0, E1]
! and over time interval [t0, t1]
function Nevents(E0, E1, t0, t1,  m_x, sigma_SI)
    double precision :: A, m_x, sigma_SI, Nevents
    double precision :: E0, E1, t0, t1
    integer :: Nt = 200
    integer :: NE = 100
    double precision, allocatable :: tlist(:), Elist(:), tmp(:)
    double precision, allocatable :: integvals(:,:)
    double precision :: dt

    integer :: i_t, i_E

    double precision, allocatable :: reslist(:)

    allocate(tlist(Nt))
    allocate(Elist(NE))
    allocate(tmp(Nt))
    allocate(integvals(NE, Nt))
    allocate(reslist(NE))

    dt = (t1 - 1d0 - t0)/3d0

    if ((t1 - t0) < 4d0) then
        write (*,*) "    WARNING! DDrate.f90: Nevents: Calculation may not work for exposures"
        write (*,*) "    shorter than a few days. Try Nevents_short instead..."
    end if

    !Note: you have to do more than 4 days of exposure for this to work...
    !Do 50 samples on each of 4 separate days
    do i_t = 0,3
        tlist((1+i_t*50):((i_t+1)*50)) = linspace(t0 + i_t*dt, t0 + i_t*dt + 1d0, 50)
    end do

    Elist = 10**(linspace(log10(E0), log10(E1), NE))

    do i_E = 1, NE
        reslist(i_E) = resolution_integrated(Elist(i_E))
    end do

    ! Calculate the rate (including resolution) on a grid of (E, t) values
    do i_E = 1, NE
        do i_t = 1, Nt
            integvals(i_E, i_t) = reslist(i_E)*dRdE(Elist(i_E), tlist(i_t),  m_x, sigma_SI)
        end do
    end do

    !Integrate over energies
    do i_t = 1, Nt
        tmp(i_t) = trapz(Elist, integvals(:, i_t))
    end do

    !Integrate over time
    Nevents = trapz(tlist, tmp)

    deallocate(tlist)
    deallocate(Elist)
    deallocate(tmp)
    deallocate(integvals)
    deallocate(reslist)

end function Nevents

! Total number of events in the energy range [E0, E1]
! and over a (short ~ days) time interval [t0, t1]
function Nevents_short(E0, E1, t0, t1,  m_x, sigma_SI)
    double precision :: A, m_x, sigma_SI, Nevents_short
    double precision :: E0, E1, t0, t1
    integer :: Nt

    parameter (Nt = 12)

    double precision :: tlist(Nt), Elist(N_smooth), tmp(Nt)
    double precision :: integvals(N_smooth, Nt), reslist(N_smooth)
    double precision :: dt

    integer :: i_t, i_E
    tlist = linspace(t0, t1, Nt)

    Elist = 10**(linspace(log10(E_min), log10(E_max), N_smooth))

    do i_E = 1, N_smooth
        reslist(i_E) = resolution_integrated(Elist(i_E), E0, E1)
    end do

    ! Calculate the rate (including resolution) on a grid of (E, t) values
    do i_E = 1, N_smooth
        do i_t = 1, Nt
            integvals(i_E, i_t) = reslist(i_E)*dRdE(Elist(i_E), tlist(i_t), m_x, sigma_SI)
        end do
    end do

    !Integrate over energies
    do i_t = 1, Nt
        tmp(i_t) = trapz(Elist, integvals(:, i_t))
    end do

    !Integrate over time
    Nevents_short = trapz(tlist, tmp)

end function Nevents_short

! Number of events in recoil range [E0, E1] at fixed time t
function Nevents_fixedt(E0, E1, t, m_x, sigma_SI)
    double precision :: m_x, sigma_SI, Nevents_fixedt
    double precision :: E0, E1, t
    integer :: NE = 100
    double precision, allocatable ::  Elist(:)
    double precision, allocatable :: integvals(:)

    integer :: i_E

    allocate(Elist(NE))
    allocate(integvals(NE))

    Elist = 10**(linspace(log10(E0), log10(E1), NE))

    do i_E = 1, NE
        integvals(i_E) = resolution_integrated(Elist(i_E))*dRdE(Elist(i_E), t, m_x, sigma_SI)
    end do

    Nevents_fixedt = trapz(Elist, integvals)

    deallocate(Elist)
    deallocate(integvals)

end function Nevents_fixedt

end module DDrate


C  ********************************************************************
      subroutine CMPMAX (KUG,PR,W,W2,W3,WD,D,DT,ZD,ZV,ZA, UG)
C * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
C
C   THIS ROUTINE COMPUTES RESPONSE VALUES FOR ONE SINGLE DEGREE OF
C   FREEDOM SYSTEM USING STEP BY STEP METHOD
C
C   EXPLANATIOS to PARAMETERS GIVEN IN DRCTSP
C
C   CODED BY I. M. IDRISS  1967
C * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
C
C     TODO: These arrays need to be checked for size
      dimension XD(2), XV(2), T(3)
      dimension UG(1)
C
      ZA = 0.
      ZD = 0.
      ZV = 0.
      XD(1) = 0.
      XV(1) = 0.
      F1 = 2.*D/(W3*DT)
      F2 = 1./W2
      F3 = D*W
      F4 = 1./WD
      F5 = F3*F4
      F6 = 2.*F3
       E = EXP(-F3*DT)
       S = SIN(WD*DT)
       C= COS(WD*DT)
      G1 = E*S
      G2 = E*C
      H1 = WD*G2 - F3*G1
      H2 = WD*G1 + F3*G2
      do K = 1, KUG
        Y = K-1
        DUG = UG(K+1) - UG(K)
        Z1 = F2*DUG
        Z2 = F2*UG(K)
        Z3 = F1*DUG
        Z4 = Z1/DT
        B = XD(1) + Z2 -Z3
        A = F4*XV(1) + F5*B + F4*Z4
        XD(2) = A*G1 + B*G2 + Z3 - Z2 - Z1
        XV(2) = A*H1 - B*H2 - Z4
        XD(1) = XD(2)
        XV(1) = XV(2)
        AA = -F6*XV(1) - W2*XD(1)
        F = ABS(XD(1))
        G = ABS(XV(1))
        H = ABS(AA)
        if (F .gt. ZD) then
          T(1) = Y
          ZD = F
        end if
        if (G .gt. ZV) then
          T(2) = Y
          ZV = G
        end if
        if (H .gt. ZA) then
          T(3) = Y
          ZA = H
        end if
      end do
      do L = 1, 3
        T(L) = DT*T(L)
      end do
      write(6,112) PR, (T(L),L=1,3)
  112 format(5X,5HPER = F5.2,5X,19HTIMES FOR MAXIMA -- ,3X,
     14HTD = F8.4,3X,4HTV = F8.4,3X,4HTA = F8.4)
      return
      end


      subroutine ire_mk(ctfm,ctfmp,n_A,n_Athth,n_Axx,n_B,n_K,n_Sx,n_psi,
     &x,Nx,hx,myzero,phys_bdy,res)
      implicit none
      integer i
      integer Nx
      real*8 hx
      real*8 myzero
      real*8 ctfm(Nx)
      real*8 ctfmp(Nx)
      real*8 n_A(Nx)
      real*8 n_Athth(Nx)
      real*8 n_Axx(Nx)
      real*8 n_B(Nx)
      real*8 n_K(Nx)
      real*8 n_Sx(Nx)
      real*8 n_psi(Nx)
      real*8 x(Nx)
      integer phys_bdy(2)
      real*8 res(Nx)
      real*8 qb
      if (phys_bdy(1) .eq. 1) then
      do i=1, 1, 1
      qb = -0.1D1 * n_psi(i) ** 6 / n_A(i) * n_Sx(i)
      res(i)=qb
      end do
      endif
      do i=2, Nx-1, 1
      qb = -0.1D1 * n_psi(i) ** 6 / n_A(i) * n_Sx(i) + (0.2D1 * n_psi(i)
     # ** 6 / n_A(i) ** 2 * n_Axx(i) - 0.2D1 * n_psi(i) ** 6 / n_A(i) /
     #n_B(i) * n_Athth(i)) / ctfm(i) + (-0.5000000000000000D0 * n_psi(i)
     # ** 6 / n_A(i) ** 3 * n_Axx(i) * (-0.1D1 * n_A(i - 1) + n_A(i + 1)
     #) + 0.5000000000000000D0 * n_psi(i) ** 6 / n_A(i) ** 2 * (-0.1D1 *
     # n_Axx(i - 1) + n_Axx(i + 1)) + 0.5000000000000000D0 * n_psi(i) **
     # 6 / n_A(i) ** 2 / n_B(i) * (-0.1D1 * n_B(i - 1) + n_B(i + 1)) * n
     #_Axx(i) - 0.5000000000000000D0 * n_psi(i) ** 6 / n_A(i) / n_B(i) *
     #* 2 * (-0.1D1 * n_B(i - 1) + n_B(i + 1)) * n_Athth(i) + 0.33333333
     #33333333D0 * n_psi(i) ** 6 / n_A(i) * (n_K(i - 1) - 0.1D1 * n_K(i
     #+ 1)) + 0.3D1 * n_psi(i) ** 5 / n_A(i) ** 2 * (-0.1D1 * n_psi(i -
     #1) + n_psi(i + 1)) * n_Axx(i)) / ctfmp(i) / hx
      res(i)=qb
      end do
      if (phys_bdy(2) .eq. 1) then
      do i=Nx, Nx, 1
      qb = myzero * x(i)
      res(i)=qb
      end do
      endif
      END


      ! This is UMAT subroutine made by yossy11
      ! yield function : Hill48
      ! plastic potential : Hill48
      ! hardening rule : Kim-Tuan
      ! flow rule : non-AFR
      ! integration algorithm : CCP(convex cutting plane)
      ! using numerical differentiation for the calculation of dfdS

      ! Umat interface
      SUBROUTINE UMAT(STRESS,STATEV,DDSDDE,SSE,SPD,SCD,RPL,DDSDDT,
     & DRPLDE,DRPLDT,STRAN,DSTRAN,TIME,DTIME,TEMP,DTEMP,PREDEF,DPRED,
     & CMNAME,NDI,NSHR,NTENS,NSTATV,PROPS,NPROPS,COORDS,DROT,PNEWDT,
     & CELENT,DFGRD0,DFGRD1,NOEL,NPT,LAYER,KSPT,KSTEP,KINC)

      INCLUDE 'ABA_PARAM.INC'
      CHARACTER*80 CMNAME
      DIMENSION STRESS(NTENS),STATEV(NSTATV),
     & DDSDDE(NTENS,NTENS),DDSDDT(NTENS),DRPLDE(NTENS),
     & STRAN(NTENS),DSTRAN(NTENS),TIME(2),PREDEF(1),DPRED(1),
     & PROPS(NPROPS),COORDS(3),DROT(3,3),DFGRD0(3,3),DFGRD1(3,3)

      ! define variables, and their dimensions
      INTEGER i,iterationNum
      DOUBLE PRECISION TOLER,YOUNG,POISSON,HARDK,HARDT,HARDA,HARDH,
     & HARDSTRESS0,lame,shearMod,eStrain(6),pStrain(6),eqpStrain,
     & totalStrain(6),hillFParams(4),hillGParams(4),eqStress,
     & flowStress,calc_eqStress,calc_FlowStress,dfdS(6),dGdS(6),
     & eqGStress,calc_eqGStress,dLambda,F,H,calc_H,lambda

      ! define constants
      PARAMETER(TOLER=1.0D-5,YOUNG=22.58D4,POISSON=0.39D0,
     & HARDK=944.03D0,HARDT=23.58D0,HARDA=0.534D0,HARDH=0.185D0,
     & HARDSTRESS0=519.73D0)

      ! anisotropic params
      hillFParams(1) = 0.42610421732178394D0
      hillFParams(2) = 0.5913660555884093D0
      hillFParams(3) = 0.4086339444115908D0
      hillFParams(4) = 1.5770789230107995D0

      hillGParams(1) = 0.42610421732178394D0
      hillGParams(2) = 0.5913660555884093D0
      hillGParams(3) = 0.4086339444115908D0
      hillGParams(4) = 1.5770789230107995D0

      ! this subroutine can be used only on the condition of NDI=NSHR=3
      IF (NDI/=3 .or. NSHR/=3) THEN
        WRITE(7,*) 'invalid element type, please check about that'
        CALL XIT
      END IF

      ! initialize DDSDDE
      lame = YOUNG*POISSON/((1.0D0 - 2.0D0*POISSON)*(1.0D0 + POISSON))
      shearMod = YOUNG/(2.0D0*(1.0D0 + POISSON))
      DDSDDE(:,:) = 0.0D0
      DDSDDE(1:3,1:3) = lame
      DO i=1,3
        DDSDDE(i,i) = lame + 2*shearMod
        DDSDDE(i+3,i+3) = shearMod
      END DO

      ! read STATEV
      CALL ROTSIG(STATEV(1), DROT, eStrain, 2, NDI, NSHR)
      CALL ROTSIG(STATEV(NTENS+1), DROT, pStrain, 2, NDI, NSHR)
      eqpStrain = STATEV(2*NTENS+1)
      eStrain(:) = eStrain(:) + DSTRAN(:)
      totalStrain(:) = eStrain(:) + pStrain(:)

      ! calculate trial stress
      STRESS(:) = STRESS(:) + MATMUL(DDSDDE,DSTRAN)
      iterationNum = 0
      lambda = 0.0D0

      DO WHILE (iterationNum < 1000000)
        ! calculate eqStress and flowStress
        eqStress = calc_eqStress(hillFParams,STRESS)
        flowStress = calc_FlowStress(HARDK,HARDT,HARDA,HARDH,
     &   HARDSTRESS0,eqpStrain)
        F = eqStress - flowStress
        IF (ISNAN(F)) THEN
          WRITE(7,*) "F is NaN"
          CALL XIT
        END IF

        ! if not yield
        IF (F < flowStress*TOLER) THEN
          CALL updateSTATEV(NSTATV,STATEV,eStrain,pStrain,eqpStrain)
          IF (iterationNum /= 0) THEN
            CALL updateDDSDDE(hillFParams,hillGParams,STRESS,DDSDDE,
     &       lambda,eqStress,HARDK,HARDT,HARDA,HARDH,HARDSTRESS0,
     &       eqpStrain)
          END IF
          RETURN
        END IF

        ! if yield
        eqGStress = calc_eqGStress(hillGParams,STRESS)
        H = calc_H(HARDK,HARDT,HARDA,HARDH,HARDSTRESS0,eqpStrain)
        CALL calc_dfdS(hillFParams,STRESS,dfdS)
        CALL calc_dGdS(hillGParams,STRESS,dGdS)

        dLambda = F/(DOT_PRODUCT(dfdS,MATMUL(DDSDDE,dGdS)) +
     &   H*eqGStress/eqStress)
        IF (dLambda<0) THEN
          WRITE(7,*) "dLambda < 0, invalid!!"
          CALL XIT
        END IF

        lambda = lambda + dLambda

        STRESS(:) = STRESS(:) - dLambda*MATMUL(DDSDDE,dGdS)
        eqpStrain = eqpStrain + dLambda*eqGStress/eqStress
        pStrain(:) = pStrain(:) + dLambda*dGdS(:)
        eStrain(:) = eStrain(:) - dLambda*dGdS(:)
        iterationNum = iterationNum + 1
      END DO
      WRITE(7,*) "not converged!!!"
      WRITE(7,*) "F",F
      CALL XIT
      RETURN
      END SUBROUTINE UMAT

      ! calculate equivalent stress
      DOUBLE PRECISION FUNCTION calc_eqStress(hillParams,STRESS)
      IMPLICIT NONE
      DOUBLE PRECISION hillParams(4),STRESS(6),numerator
      numerator = hillParams(1)*(STRESS(2) - STRESS(3))**2 +
     & hillParams(2)*(STRESS(3)-STRESS(1))**2 +
     & hillParams(3)*(STRESS(1)-STRESS(2))**2 +
     & 2.0D0*hillParams(4)*SUM(STRESS(4:6)**2)
      calc_eqStress = SQRT(1.5D0*numerator/SUM(hillParams(1:3)))
      RETURN
      END FUNCTION calc_eqStress

      ! calculate equivalent stress with plastic potential G
      DOUBLE PRECISION FUNCTION calc_eqGStress(hillParams,STRESS)
      IMPLICIT NONE
      DOUBLE PRECISION hillParams(4),STRESS(6),numerator
      numerator = hillParams(1)*(STRESS(2) - STRESS(3))**2 +
     & hillParams(2)*(STRESS(3)-STRESS(1))**2 +
     & hillParams(3)*(STRESS(1)-STRESS(2))**2 +
     & 2.0D0*hillParams(4)*SUM(STRESS(4:6)**2)
      calc_eqGStress = SQRT(1.5D0*numerator/SUM(hillParams(1:3)))
      RETURN
      END FUNCTION calc_eqGStress

      ! calculate flow stress
      DOUBLE PRECISION FUNCTION calc_FlowStress(HARDK,HARDT,HARDA,HARDH,
     & HARDSTRESS0,eqpStrain)
      IMPLICIT NONE
      DOUBLE PRECISION HARDK,HARDT,HARDA,HARDH,HARDSTRESS0,eqpStrain
      IF (eqpStrain == 0.0D0) THEN
        calc_FlowStress = HARDSTRESS0
        RETURN
      END IF
      calc_FlowStress = HARDSTRESS0 +
     & HARDK*(1.0D0-EXP(-1.0D0*HARDT*eqpStrain**HARDA))*eqpStrain**HARDH
      RETURN
      END FUNCTION calc_FlowStress

      ! calculate derivative of flow stress
      DOUBLE PRECISION FUNCTION calc_H(HARDK,HARDT,HARDA,HARDH,
     & HARDSTRESS0,eqpStrain)
      IMPLICIT NONE
      DOUBLE PRECISION HARDK,HARDT,HARDA,HARDH,HARDSTRESS0,eqpStrain
      IF (eqpStrain == 0.0D0) THEN
        calc_H = 0.0D0
        RETURN
      END IF
      calc_H = (HARDK*HARDA*HARDT*eqpStrain**(HARDA-1.0D0))*
     & EXP(-1.0D0*HARDT*eqpStrain**HARDA)
      calc_H = calc_H +
     & HARDK*(1.0D0-EXP(-1.0D0*HARDT*eqpStrain**HARDA))*
     & HARDH*eqpStrain**(HARDH-1.0D0)
      RETURN
      END FUNCTION calc_H

      ! update all state variable
      SUBROUTINE updateSTATEV(NSTATV,STATEV,eStrain,pStrain,eqpStrain)
      IMPLICIT NONE
      INTEGER NSTATV
      DOUBLE PRECISION STATEV(NSTATV),eStrain(6),pStrain(6),eqpStrain
      STATEV(1:6)=eStrain
      STATEV(7:12)=pStrain
      STATEV(13)=eqpStrain
      RETURN
      END SUBROUTINE updateSTATEV

      ! update tangent modulus
      SUBROUTINE updateDDSDDE(hillFParams,hillGParams,STRESS,DDSDDE,
     & lambda,eqStress,HARDK,HARDT,HARDA,HARDH,HARDSTRESS0,eqpStrain)
      IMPLICIT NONE
      INTEGER i,j
      DOUBLE PRECISION hillFParams(4),hillGParams(4),STRESS(6),
     & DDSDDE(6,6),lambda,eqStress,HARDK,HARDT,HARDA,HARDH,
     & HARDSTRESS0,eqpStrain,eqGStress,calc_eqGStress,dfdS(6),dGdS(6),
     & ddGddS(6,6),A(7,7),B(6,6),invB(6,6),invDDSDDE(6,6),h0,subVec(7),
     & vec1(7),vec2(7),H,calc_H,C(7,7),subDDSDDE(6,6)
      subDDSDDE(:,:) = DDSDDE(:,:)
      eqGStress = calc_eqGStress(hillGParams,STRESS)
      CALL calc_dfdS(hillFParams,STRESS,dfdS)
      CALL calc_dGdS(hillGParams,STRESS,dGdS)
      CALL calc_ddGddS(hillGParams,STRESS,dGdS,ddGddS)
      CALL calc_Inverse(6,DDSDDE,invDDSDDE)
      invB(:,:) = invDDSDDE(:,:) + lambda*ddGddS(:,:)
      CALL calc_Inverse(6,invB,B)
      A(:,:) = 0.0D0
      A(1:6,1:6) = B(:,:)
      A(7,7) = 1.0D0
      h0 = eqGStress/eqStress
      subVec(:) = 0.0D0
      subVec(1:6) = dGdS(:)
      subVec(7) = -1.0D0*h0
      vec1 = MATMUL(A,subVec)
      subVec(1:6) = dfdS(:)
      subVec(7) = 0.0D0
      vec2 = MATMUL(subVec,A)
      CALL calc_Dyad(7,vec1,vec2,C)
      H = calc_H(HARDK,HARDT,HARDA,HARDH,HARDSTRESS0,eqpStrain)
      C(:,:) = C(:,:)/
     & (DOT_PRODUCT(dfdS,MATMUL(B,dGdS)) + H*h0)
      A(:,:) = A(:,:) - C(:,:)
      DDSDDE(:,:) = A(1:6,1:6)
      DO i=1,6
        DO j=1,6
          IF (ISNAN(DDSDDE(i,j))) THEN
            DDSDDE(:,:) = subDDSDDE(:,:)
            RETURN
          END if
        END DO
      END DO
      RETURN
      END SUBROUTINE updateDDSDDE

      ! calculate differential of plastic potential
      SUBROUTINE calc_dGdS(hillParams,STRESS,dGdS)
      IMPLICIT NONE
      DOUBLE PRECISION hillParams(4),STRESS(6),dGdS(6),eqGStress,
     & calc_eqGStress,multiplier
      eqGStress = calc_eqGStress(hillParams,STRESS)
      multiplier = 0.75/(SUM(hillParams(1:3))*eqGStress)
      dGdS(1) = -1.0D0*2*hillParams(2)*(STRESS(3)-STRESS(1))+
     & 2*hillParams(3)*(STRESS(1)-STRESS(2))
      dGdS(2) = 2*hillParams(1)*(STRESS(2)-STRESS(3))-
     & 2*hillParams(3)*(STRESS(1)-STRESS(2))
      dGdS(3) = -1.0D0*2*hillParams(1)*(STRESS(2)-STRESS(3))+
     & 2*hillParams(2)*(STRESS(3)-STRESS(1))
      dGdS(4) = 4*hillParams(4)*STRESS(4)
      dGdS(5) = 4*hillParams(4)*STRESS(5)
      dGdS(6) = 4*hillParams(4)*STRESS(6)
      dGdS(:) = dGdS(:) * multiplier
      RETURN
      END SUBROUTINE calc_dGdS

      ! calculate differential of plastic potential
      SUBROUTINE calc_ddGddS(hillParams,STRESS,dGdS,ddGddS)
      IMPLICIT NONE
      INTEGER i,j
      DOUBLE PRECISION hillParams(4),STRESS(6),dGdS(6),ddGddS(6,6),
     & eqGStress,calc_eqGStress,multiplier
      eqGStress = calc_eqGStress(hillParams,STRESS)
      multiplier = 0.75/(SUM(hillParams(1:3))*eqGStress)

      ddGddS(:,:) = 0.0D0
      ddGddS(1,1) = 2*hillParams(2) + 2*hillParams(3)
      ddGddS(2,2) = 2*hillParams(1) + 2*hillParams(3)
      ddGddS(3,3) = 2*hillParams(1) + 2*hillParams(2)
      ddGddS(4,4) = 4*hillParams(4)
      ddGddS(5,5) = 4*hillParams(4)
      ddGddS(6,6) = 4*hillParams(4)
      ddGddS(1,2) = -1.0D0*2*hillParams(3)
      ddGddS(1,3) = -1.0D0*2*hillParams(2)
      ddGddS(2,1) = -1.0D0*2*hillParams(3)
      ddGddS(2,3) = -1.0D0*2*hillParams(1)
      ddGddS(3,1) = -1.0D0*2*hillParams(2)
      ddGddS(3,2) = -1.0D0*2*hillParams(1)
      DO i=1,6
        DO j=1,6
          ddGddS(i,j) = multiplier*ddGddS(i,j) -
     &     dGdS(i)*dGdS(j)/eqGStress
        END DO
      END DO
      RETURN
      END SUBROUTINE calc_ddGddS

      ! calculate differential of yield function
      SUBROUTINE calc_dfdS(hillParams,STRESS,dGdS)
      IMPLICIT NONE
      DOUBLE PRECISION hillParams(4),STRESS(6),dGdS(6),eqGStress,
     & calc_eqStress,multiplier
      eqGStress = calc_eqStress(hillParams,STRESS)
      multiplier = 0.75/(SUM(hillParams(1:3))*eqGStress)
      dGdS(1) = -1.0D0*2*hillParams(2)*(STRESS(3)-STRESS(1))+
     & 2*hillParams(3)*(STRESS(1)-STRESS(2))
      dGdS(2) = 2*hillParams(1)*(STRESS(2)-STRESS(3))-
     & 2*hillParams(3)*(STRESS(1)-STRESS(2))
      dGdS(3) = -1.0D0*2*hillParams(1)*(STRESS(2)-STRESS(3))+
     & 2*hillParams(2)*(STRESS(3)-STRESS(1))
      dGdS(4) = 4*hillParams(4)*STRESS(4)
      dGdS(5) = 4*hillParams(4)*STRESS(5)
      dGdS(6) = 4*hillParams(4)*STRESS(6)
      dGdS(:) = dGdS(:) * multiplier
      RETURN
      END SUBROUTINE calc_dfdS

      ! calculate inverse matrix
      SUBROUTINE calc_Inverse(dim,mat,invMat)
      IMPLICIT NONE
      INTEGER dim,i,j
      DOUBLE PRECISION mat(dim,dim),invMat(dim,dim),bufMat(dim,dim),buf
      bufMat(:,:) = mat(:,:)
      invMat(:,:) = 0.0D0
      DO i=1,dim
        invMat(i,i) = 1.0D0
      END DO
      DO i=1,dim
        buf = 1.0D0/mat(i,i)
        mat(i,:) = mat(i,:)*buf
        invMat(i,:) = invMat(i,:)*buf
        DO j=1,dim
          IF (i/=j) THEN
            buf = mat(j,i)
            mat(j,:) = mat(j,:) - mat(i,:)*buf
            invMat(j,:) = invMat(j,:) - invMat(i,:)*buf
          END IF
        END DO
      END DO
      mat(:,:) = bufMat(:,:)
      RETURN
      END SUBROUTINE calc_Inverse

      ! calculate dyad of vectors
      SUBROUTINE calc_Dyad(dim,vec1,vec2,mat)
      IMPLICIT NONE
      INTEGER dim,i,j
      DOUBLE PRECISION vec1(dim),vec2(dim),mat(dim,dim)
      DO i=1,dim
        DO j=1,dim
          mat(i,j) = vec1(i)*vec2(j)
        END DO
      END DO
      RETURN
      END SUBROUTINE calc_Dyad