      SUBROUTINE eigsrt(d,v,n,np)
      INTEGER n,np
      REAL d(np),v(np,np)
      INTEGER i,j,k
      REAL p
      do 13 i=1,n-1
        k=i
        p=d(i)
        do 11 j=i+1,n
          if(d(j).ge.p)then
            k=j
            p=d(j)
          endif
11      continue
        if(k.ne.i)then
          d(k)=d(i)
          d(i)=p
          do 12 j=1,n
            p=v(j,i)
            v(j,i)=v(j,k)
            v(j,k)=p
12        continue
        endif
13    continue
      return
      END

NR-Functions/Numerical Recipes- Example & Functions/Functions/eigsrt.for


program P16478
    implicit none
    integer :: ab, bc, cd
    read *, ab, bc, cd
    write (*, '(F0.7)') real(ab * cd) / real(bc)
end program P16478


program test_loadtxt
use iso_fortran_env, only: sp=>real32, dp=>real64 ,qp=>real128
use stdlib_experimental_io, only: loadtxt
implicit none

real(sp), allocatable :: s(:, :)
real(dp), allocatable :: d(:, :)
real(qp), allocatable :: q(:, :)

call loadtxt("array1.dat", s)
call print_array(s)

call loadtxt("array1.dat", d)
call print_array(d)

call loadtxt("array2.dat", d)
call print_array(d)

call loadtxt("array3.dat", d)
call print_array(d)

call loadtxt("array4.dat", d)
call print_array(d)

call loadtxt("array4.dat", q)
call print_array(q)

contains

subroutine print_array(a)
class(*),intent(in) :: a(:, :)
integer :: i
print *, "Array, shape=(", size(a, 1), ",", size(a, 2), ")"

 select type(a)
  type is(real(sp))
   do i = 1, size(a, 1)
    print *, a(i, :)
   end do
  type is(real(dp))
   do i = 1, size(a, 1)
    print *, a(i, :)
   end do
  type is(real(qp))
   do i = 1, size(a, 1)
    print *, a(i, :)
   end do
  class default
   write(*,'(a)')'The proposed type is not supported'
   error stop
 end select

end subroutine

end program


program casteos
implicit none

integer :: i=3
real :: a = 23.9030
complex :: z=(4.5,1.6)

!Casteos Reales
!real convierte el valor entero a real
print*, "Con real ", real (i)
!dble convertir el valor entero a real con memoria de 8 bytes
print*, "Con dble", dble(i)
print*,"i", i

!Casteos Enteros
!int convierte a los numeros reales en enteros (numero sin
print*, "Con INT: ", int (a)
!int convierte a todos los numeros reales en enteros truncado
print*, "Con NINT:", nint(a)
print*, "a", a

!Casteos Complejos
!real te da parte real del numero complejo
print*, "Parte real", real(z)
!aimag te da la parte imaginaria del numero complejo
print*, "Parte imaginara", aimag(z)
!conjg te da el conjugado del numero complejo
print*, "Conjugado", conjg(z)
!cmplx convierte dos  numeros reales en un numero complejo
print*, "el numero complejo formado por a,a es :"
print*, cmplx(a,a)

print*, "z",z

end program casteos


!
!-----------------------------------------------------------------------
!-----------------------------------------------------------------------
!                    Mesh and Weight Generation
!-----------------------------------------------------------------------
!-----------------------------------------------------------------------
!
MODULE MESH

  IMPLICIT NONE
  PRIVATE
  PUBLIC :: MSH,GENWTS,WINT,ADPTDS,ADAPT,ADAPT2,INTWTS,SCALEB
  PUBLIC :: RINPR,RNRMSQ,RINTG,RNRM2,RMXUPS,RMNUPS,RMXUPST,RMNUPST

CONTAINS

! ---------- ---
  SUBROUTINE MSH(NTST,TM)

! Generates a uniform mesh on [0,1].

    INTEGER, INTENT(IN) :: NTST
    DOUBLE PRECISION, INTENT(OUT) :: TM(0:NTST)

    INTEGER J

    DO J=0,NTST
       TM(J)=DBLE(J)/NTST
    ENDDO

  END SUBROUTINE MSH

! ---------- ------
  SUBROUTINE GENWTS(NCOL,WT,WP)

! Generates weights of the collocation method. The user selected
! number of collocation points (ncol) must be one of { 2,...,7 }.
!
! The following weights are generated :
!
!         WT : for the function value,
!         WP : for the first derivative,

    INTEGER, INTENT(IN) :: NCOL
    DOUBLE PRECISION, INTENT(OUT) :: WT(0:NCOL,NCOL),WP(0:NCOL,NCOL)
! Local
    INTEGER IB,IC,K,L,DENOM
    DOUBLE PRECISION ZM(NCOL),P,SUM

! Generate the collocation points :
    CALL CPNTS(NCOL,ZM)

! Generate weights :

    DO IB=0,NCOL
       DENOM=1
       DO K=0,NCOL
          IF(K/=IB)DENOM=DENOM*(IB-K)
       ENDDO
       DO IC=1,NCOL
! Weights for the function values :
          P=1.d0
          DO K=0,NCOL
             IF(K/=IB)P=P*( ZM(IC)*NCOL-K )
          ENDDO
          WT(IB,IC)=P/DENOM
! Weights for derivatives :
          SUM=0.d0
          DO L=0,NCOL
             IF(L/=IB)THEN
                P=1.d0
                DO K=0,NCOL
                   IF(K/=IB.AND.K/=L)P=P*( ZM(IC)*NCOL-K )
                ENDDO
                SUM=SUM+P*NCOL
             ENDIF
          ENDDO
          WP(IB,IC)=SUM/DENOM
       ENDDO
    ENDDO
  END SUBROUTINE GENWTS

! ---------- -----
  SUBROUTINE CPNTS(NCOL,ZM)

! Generates the collocation points with respect to [0,1].

    INTEGER, INTENT(IN) :: NCOL
    DOUBLE PRECISION, INTENT(OUT) :: ZM(NCOL)

    DOUBLE PRECISION, PARAMETER :: &
         C51 = .5d0*0.90617984593866399280d0, &
         C52 = .5d0*0.53846931010568309104d0, &
         C61 = .5d0*0.93246951420315202781d0, &
         C62 = .5d0*0.66120938646626451366d0, &
         C63 = .5d0*0.23861918608319690863d0, &
         C71 = .5d0*0.949107991234275852452d0, &
         C72 = .5d0*0.74153118559939443986d0, &
         C73 = .5d0*0.40584515137739716690d0, &
         R = 6.0d0/7.0d0

    DOUBLE PRECISION C21,C31,C4,C41,C42

    SELECT CASE(NCOL)
       CASE(2)
          C21 = .5d0/SQRT(3.0d0)
          ZM(1) = .5d0-C21
          ZM(2) = .5d0+C21
       CASE(3)
          C31 = .5d0*SQRT(0.6d0)
          ZM(1) = .5d0-C31
          ZM(2) = .5d0
          ZM(3) = .5d0+C31
       CASE(4)
          C4  = .5d0*SQRT(R**2-12.0d0/35.0d0)
          C41 = .5d0*SQRT(3.0d0/7.0d0+C4)
          C42 = .5d0*SQRT(3.0d0/7.0d0-C4)
          ZM(1) = .5d0-C41
          ZM(2) = .5d0-C42
          ZM(3) = .5d0+C42
          ZM(4) = .5d0+C41
       CASE(5)
          ZM(:) = (/ .5d0-C51, .5d0-C52, .5d0, .5d0+C52, .5d0+C51 /)
       CASE(6)
          ZM(:) = (/ .5d0-C61, .5d0-C62, .5d0-C63, &
                     .5d0+C63, .5d0+C62, .5d0+C61 /)
       CASE(7)
          ZM(:) = (/ .5d0-C71, .5d0-C72, .5d0-C73, .5d0, &
                     .5d0+C73, .5d0+C72, .5d0+C71  /)
    END SELECT
  END SUBROUTINE CPNTS

! ---------- ------
  SUBROUTINE CNTDIF(N,D)

! Generates the coefficients of the central difference formula for
! Nth derivative at uniformly spaced points
!              0 = x  < x  < ... < x  = 1.
!                   0    1          N
    INTEGER, INTENT(IN) :: N
    INTEGER, INTENT(OUT) :: D(0:N)

    INTEGER I,K

    D(0)=1
    IF(N.EQ.0)RETURN

    DO I=1,N
       D(I)=0
       DO K=I,1,-1
          D(K)=D(K-1)-D(K)
       ENDDO
       D(0)=-D(0)
    ENDDO

  END SUBROUTINE CNTDIF

! ---------- ----
  SUBROUTINE WINT(NCOL,WI)

! Generates the weights for the integration formula based on polynomial
! interpolation at NCOL+1 equally spaced points in [0,1].

    INTEGER, INTENT(IN) :: NCOL
    DOUBLE PRECISION, INTENT(OUT) :: WI(0:NCOL)

    DOUBLE PRECISION C

    SELECT CASE(NCOL)
    CASE(2)
       C=1.d0/6.0d0
       WI(0)=C
       WI(1)=4.0d0*C
       WI(2)=C
    CASE(3)
       C=1.d0/8.0d0
       WI(0)=C
       WI(1)=3.0d0*C
       WI(2)=WI(1)
       WI(3)=C
    CASE(4)
       C=1.d0/90.0d0
       WI(0)=7.0d0*C
       WI(1)=32.0d0*C
       WI(2)=12.0d0*C
       WI(3)=WI(1)
       WI(4)=WI(0)
    CASE(5)
       WI(0)=19.0d0/288.0d0
       WI(1)=25.0d0/96.0d0
       WI(2)=25.0d0/144.0d0
       WI(3)=WI(2)
       WI(4)=WI(1)
       WI(5)=WI(0)
    CASE(6)
       WI(0)=41.0d0/840.0d0
       WI(1)=9.0d0/35.0d0
       WI(2)=9.0d0/280.0d0
       WI(3)=34.0d0/105.0d0
       WI(4)=WI(2)
       WI(5)=WI(1)
       WI(6)=WI(0)
    CASE(7)
       WI(0)=751.0d0/17280.0d0
       WI(1)=3577.0d0/17280.0d0
       WI(2)=49.0d0/640.0d0
       WI(3)=2989.0d0/17280.0d0
       WI(4)=WI(3)
       WI(5)=WI(2)
       WI(6)=WI(1)
       WI(7)=WI(0)
    END SELECT

  END SUBROUTINE WINT

!-----------------------------------------------------------------------
!-----------------------------------------------------------------------
!          Stepsize and Mesh Adaption
!-----------------------------------------------------------------------
!-----------------------------------------------------------------------

! ---------- ------
  SUBROUTINE ADPTDS(NIT,ITNW,IBR,NTOP,IID,DSMAX,RDS)

    INTEGER, INTENT(IN) :: NIT,ITNW,IBR,NTOP,IID
    DOUBLE PRECISION, INTENT(IN) :: DSMAX
    DOUBLE PRECISION, INTENT(INOUT) :: RDS
! Local
    DOUBLE PRECISION ARDS

! The stepsize along the branch of solutions is adapted depending on the
! number of Newton iterations in the previous step (called if IADS > 0).

    SELECT CASE(NIT)
    CASE(0:1)
       RDS= 2.d0*RDS
    CASE(2)
       RDS= 1.5*RDS
    CASE(3:)
       IF(NIT<=ITNW/2)THEN
          RDS= 1.1*RDS
       ELSE IF(NIT>=ITNW)THEN
          RDS=.5d0*RDS
       ENDIF
    END SELECT

    ARDS= ABS(RDS)
    IF(ARDS>DSMAX)RDS=RDS*DSMAX/ARDS

    IF(IID>0)THEN
       WRITE(9,"(/,I4,I6,8X,A,I3)")ABS(IBR),NTOP,' Iterations   : ',NIT
       WRITE(9,"(I4,I6,8X,A,ES13.5)")ABS(IBR),NTOP,' Next Step    : ',RDS
    ENDIF

  END SUBROUTINE ADPTDS

! ---------- -----
  SUBROUTINE ADAPT(NTST,NCOL,NDIM,TM,DTM,UPS,VPS,IPER)

! Adapts the distribution of the mesh points so that the increase of the
! monotone function EQDF becomes approximately equidistributed over the
! intervals. The functions UPS and VPS are interpolated on new mesh.

    INTEGER, INTENT(IN) :: NTST,NCOL,NDIM
! For periodic boundary conditions extrapolate by periodicity.
    LOGICAL, INTENT(IN) :: IPER
    DOUBLE PRECISION, INTENT(INOUT) :: UPS(NDIM,0:NTST*NCOL), &
         VPS(NDIM,0:NTST*NCOL),TM(0:NTST),DTM(NTST)
! Local
    DOUBLE PRECISION, ALLOCATABLE :: TINT(:),UINT(:,:)

    ALLOCATE(TINT(0:NTST),UINT(NDIM,0:NTST*NCOL))

    UINT(:,:)=0.d0

! Generate the new mesh :

    CALL NEWMSH(NDIM,NDIM,UPS,NTST,NCOL,TM,DTM,NTST,TINT,IPER)

! Replace UPS by its interpolant on the new mesh :

    CALL INTERP(NDIM,NTST,NCOL,TM,UPS,NDIM,NTST,NCOL,TINT,UINT)
    UPS(:,:)=UINT(:,:)

! Replace VPS by its interpolant on the new mesh :

    CALL INTERP(NDIM,NTST,NCOL,TM,VPS,NDIM,NTST,NCOL,TINT,UINT)
    VPS(:,:)=UINT(:,:)

! Replace old mesh :

    DTM(:)=TINT(1:NTST)-TINT(0:NTST-1)
    TM(:)=TINT(:)

    DEALLOCATE(TINT,UINT)
  END SUBROUTINE ADAPT

! ---------- ------
  SUBROUTINE ADAPT2(NOLD,NCOLD,NDOLD,NNEW,NCNEW,NDIM, &
       TMR,UPSR,VPSR,TM,UPS,VPS,IPER)

! Adapts the distribution of the mesh points so that the increase of the
! monotone function EQDF becomes approximately equidistributed over the
! intervals. The functions UPS and VPS are interpolated on new mesh.

    INTEGER, INTENT(IN) :: NOLD,NCOLD,NDOLD,NNEW,NCNEW,NDIM
    LOGICAL, INTENT(IN) :: IPER
    DOUBLE PRECISION, INTENT(IN) :: UPSR(NDOLD,0:*),VPSR(NDOLD,0:*),TMR(0:NOLD)
    DOUBLE PRECISION, INTENT(OUT) :: UPS(NDIM,0:*),VPS(NDIM,0:*),TM(0:*)
! Local
    INTEGER J,NDM
    DOUBLE PRECISION, ALLOCATABLE :: DTM(:)

    NDM=MIN(NDOLD,NDIM)
    IF(NOLD==NNEW.AND.NCOLD==NCNEW)THEN
! Just copy
       DO J=0,NCNEW*NNEW
          UPS(1:NDM,J)=UPSR(1:NDM,J)
          VPS(1:NDM,J)=VPSR(1:NDM,J)
       ENDDO
       TM(0:NNEW)=TMR(0:NNEW)
       RETURN
    ENDIF

! Generate the new mesh :

    ALLOCATE(DTM(NOLD))
    DTM(:)=TMR(1:NOLD)-TMR(0:NOLD-1)
    CALL NEWMSH(NDM,NDOLD,UPSR,NOLD,NCOLD,TMR,DTM,NNEW,TM,IPER)
    DEALLOCATE(DTM)

! Replace UPS by its interpolant on the new mesh :

    CALL INTERP(NDIM,NOLD,NCOLD,TMR,UPSR,NDOLD,NNEW,NCNEW,TM,UPS)

! Replace VPS by its interpolant on the new mesh :

    CALL INTERP(NDIM,NOLD,NCOLD,TMR,VPSR,NDOLD,NNEW,NCNEW,TM,VPS)

  END SUBROUTINE ADAPT2

! ---------- ------
  SUBROUTINE INTERP(NDIM,N,NC,TM,UPS,NDOLD,N1,NC1,TM1,UPS1)

! Finds interpolant (TM(.) , UPS(.) ) on new mesh TM1.

    INTEGER, INTENT(IN) :: NDIM,N,NC,N1,NC1,NDOLD
    DOUBLE PRECISION, INTENT(IN) :: UPS(NDOLD,0:N*NC)
    DOUBLE PRECISION, INTENT(IN) :: TM(0:N),TM1(0:N1)
    DOUBLE PRECISION, INTENT(OUT) :: UPS1(NDIM,0:N1*NC1)
! Local
    INTEGER I,J,J1,K,L,NDM
    DOUBLE PRECISION X(0:NC),W(0:NC),Z,D

    J=1
    NDM=MIN(NDIM,NDOLD)
    DO J1=0,N1-1
       DO I=0,NC1-1
          D=DBLE(I)/NC1
          Z=TM1(J1)+D*( TM1(J1+1)-TM1(J1) )
          DO
             IF(J>N)EXIT
             IF(TM(J)>Z)EXIT
             J=J+1
          ENDDO
          J=J-1
          D=( TM(J+1)-TM(J) )/NC
          DO L=0,NC
             X(L)=TM(J)+L*D
          ENDDO
          CALL INTWTS(NC,Z,X,W)
          DO K=1,NDM
             UPS1(K,J1*NC1+I)=DOT_PRODUCT(W(:),UPS(K,J*NC:J*NC+NC))
          ENDDO
       ENDDO
    ENDDO

    DO I=1,NDM
       UPS1(I,N1*NC1)=UPS(I,N*NC)
    ENDDO

  END SUBROUTINE INTERP

! ---------- ------
  SUBROUTINE NEWMSH(NDIM,NDOLD,UPS,NOLD,NCOLD,TMOLD,DTMOLD,NNEW,TMNEW,IPER)

! Redistributes the mesh according to the function EQDF.

    INTEGER, INTENT(IN) :: NDIM,NDOLD,NOLD,NCOLD,NNEW
    LOGICAL, INTENT(IN) :: IPER
    DOUBLE PRECISION, INTENT(IN) :: UPS(NDOLD,0:*),TMOLD(0:NOLD),DTMOLD(NOLD)
    DOUBLE PRECISION, INTENT(OUT) :: TMNEW(0:NNEW)
! Local
    INTEGER J,J1
    DOUBLE PRECISION X,DAL,UNEQ
    DOUBLE PRECISION, ALLOCATABLE :: EQF(:)
    ALLOCATE(EQF(0:NOLD))

! Put the values of the monotonely increasing function EQDF in EQF.

    CALL EQDF(NOLD,NDIM,NCOLD,DTMOLD,UPS,NDOLD,EQF,IPER)

! Uniformly divide the range of EQDF :

    DAL=EQF(NOLD)/NNEW

! Generate the new mesh in TMNEW :

! Assign TMNEW(0) and TMNEW(NNEW) explicitly because of loss of precision
! problems when the corresponding EQF values are very close

    TMNEW(0)=TMOLD(0)
    J=1
    DO J1=1,NNEW-1

! EQF is an ascending array with values in [0,EQF(NOLD)]. Get the
! value of the index of the TM-interval in which EQF(i) lies.
       UNEQ=J1*DAL
       DO
          IF(J>NOLD)EXIT
          IF(EQF(J)>UNEQ)EXIT
          J=J+1
       ENDDO
       J=J-1
       X=(UNEQ-EQF(J))/(EQF(J+1)-EQF(J))
       TMNEW(J1)=(1.d0-X)*TMOLD(J)+X*TMOLD(J+1)
    ENDDO

    TMNEW(NNEW)=TMOLD(NOLD)

    DEALLOCATE(EQF)
  END SUBROUTINE NEWMSH

! ---------- ------
  SUBROUTINE INTWTS(N,Z,X,WTS)

! Generates weights for Lagrange interpolation.

    INTEGER, INTENT(IN) :: N
    DOUBLE PRECISION, INTENT(IN) :: Z, X(0:N)
    DOUBLE PRECISION, INTENT(OUT) :: WTS(0:N)

    INTEGER IB,K
    DOUBLE PRECISION P

    DO IB=0,N
       P=1.d0
       DO K=0,N
          IF(K/=IB)THEN
             P=P*( Z-X(K) )/( X(IB)-X(K) )
          ENDIF
       ENDDO
       WTS(IB)=P
    ENDDO

  END SUBROUTINE INTWTS

! ---------- ----
  SUBROUTINE EQDF(NTST,NDIM,NCOL,DTM,UPS,NDOLD,EQF,IPER)

    DOUBLE PRECISION, PARAMETER :: HMACH=1.0d-7

    INTEGER, INTENT(IN) :: NTST,NDIM,NCOL,NDOLD
    LOGICAL, INTENT(IN) :: IPER
    DOUBLE PRECISION, INTENT(IN) :: UPS(NDOLD,0:NTST*NCOL),DTM(NTST)
    DOUBLE PRECISION, INTENT(OUT) :: EQF(0:NTST)

! Local
    DOUBLE PRECISION SC,E,PWR,DTAV,ND
    DOUBLE PRECISION, ALLOCATABLE :: HD(:)
    LOGICAL SMALL
    INTEGER I,J,WH(0:NCOL)

    ALLOCATE(HD(NDIM))
    CALL CNTDIF(NCOL,WH)

! Compute approximation to NCOL-th and (NCOL+1)-st derivative
! and define the equidistribution function :

    SMALL=.TRUE.
    PWR=1.d0/(NCOL+1.d0)
    EQF(0)=0.d0
    DO J=1,NTST
       E=0.d0
       SC=(NCOL/DTM(J))**NCOL
       DO I=1,NDIM
          ND=SC*DOT_PRODUCT(WH(:),UPS(I,(J-1)*NCOL:J*NCOL))
          IF(J>1)THEN
             E=E+ABS( 2*( ND-HD(I) )/(DTM(J-1)+DTM(J)) )**PWR
          ENDIF
          IF(ABS(ND)>HMACH)SMALL=.FALSE.
          HD(I)=ND
       ENDDO
       IF(J>1)EQF(J-1)=EQF(J-2)+DTM(J-1)*E
    ENDDO

    E=0.d0
    IF(IPER)THEN
!      *Extend by periodicity :
       J=1
       DTAV=(DTM(NTST)+DTM(1))/2
    ELSE
!      *Extend by extrapolation :
       J=NTST-1
       DTAV=DTM(NTST)
    ENDIF
    SC=(NCOL/DTM(J))**NCOL
    DO I=1,NDIM
       ND=SC*DOT_PRODUCT(WH(:),UPS(I,(J-1)*NCOL:J*NCOL))
       E=E+ABS( (ND-HD(I))/DTAV )**PWR
       IF(ABS(ND)>HMACH)SMALL=.FALSE.
    ENDDO
    EQF(NTST)=EQF(NTST-1)+DTM(NTST)*E

! Take care of "small derivative" case.

    IF(SMALL)THEN
       DO I=0,NTST
          EQF(I)=I
       ENDDO
    ENDIF

    DEALLOCATE(HD)
  END SUBROUTINE EQDF

! ------ --------- -------- -----
  DOUBLE PRECISION FUNCTION RINPR(NTST,NCOL,NDIM,NDIM1,UPS,VPS,DTM,THU)

! Computes the L2 inner product of UPS and VPS.
! (Using the first NDIM1 components only.)

    INTEGER, INTENT(IN) :: NTST,NCOL,NDIM,NDIM1
    DOUBLE PRECISION, INTENT(IN) :: UPS(NDIM,0:NCOL*NTST),VPS(NDIM,0:NCOL*NTST)
    DOUBLE PRECISION, INTENT(IN) :: DTM(*),THU(*)
! Local
    INTEGER I,J,K,KC
    DOUBLE PRECISION S,SJ,SK,WI(0:NCOL)

! Weights for the integration formulae :
    CALL WINT(NCOL,WI)

    S=0.d0
    K=0
    DO J=1,NTST
       SJ=0.d0
       DO KC=0,NCOL
          SK=0.d0
          DO I=1,NDIM1
             SK=SK+THU(I)*UPS(I,K+KC)*VPS(I,K+KC)
          ENDDO
          SJ=SJ+SK*WI(KC)
       ENDDO
       K=K+NCOL
       S=S+DTM(J)*SJ
    ENDDO

    RINPR=S

  END FUNCTION RINPR

! ------ --------- -------- ------
  DOUBLE PRECISION FUNCTION RNRMSQ(NTST,NCOL,NDIM,NDIM1,UPS,DTM,THU)

    INTEGER, INTENT(IN) :: NTST,NCOL,NDIM,NDIM1
    DOUBLE PRECISION, INTENT(IN) :: UPS(NDIM,*),DTM(*),THU(*)

! Finds the norm-squared of UPS (first NDIM1 components are included only).

    RNRMSQ=RINPR(NTST,NCOL,NDIM,NDIM1,UPS,UPS,DTM,THU)

  END FUNCTION RNRMSQ

! ------ --------- -------- -----
  DOUBLE PRECISION FUNCTION RINTG(NTST,NCOL,NDIM,IC,UPS,DTM)

! Computes the integral of the IC'th component of UPS.

    INTEGER, INTENT(IN) :: IC,NDIM,NCOL,NTST
    DOUBLE PRECISION, INTENT(IN) :: UPS(NDIM,0:NTST*NCOL),DTM(NTST)
! Local
    DOUBLE PRECISION WI(0:NCOL)
    INTEGER J,K
    DOUBLE PRECISION S

! Weights for the integration formulae :
    CALL WINT(NCOL,WI)

    S=0.d0
    K=0
    DO J=1,NTST
       S=S+DTM(J)*DOT_PRODUCT(WI,UPS(IC,K:K+NCOL))
       K=K+NCOL
    ENDDO

    RINTG=S

  END FUNCTION RINTG

! ------ --------- -------- -----
  DOUBLE PRECISION FUNCTION RNRM2(NTST,NCOL,NDIM,IC,UPS,DTM)

! Computes the L2-norm of the IC'th component of UPS.

    INTEGER, INTENT(IN) :: IC,NDIM,NCOL,NTST
    DOUBLE PRECISION, INTENT(IN) :: UPS(NDIM,0:NTST*NCOL),DTM(NTST)
! Local
    DOUBLE PRECISION WI(0:NCOL)
    INTEGER J,K
    DOUBLE PRECISION S

! Weights for the integration formulae :
    CALL WINT(NCOL,WI)

    S=0.d0
    K=0
    DO J=1,NTST
       S=S+DTM(J)*DOT_PRODUCT(WI,UPS(IC,K:K+NCOL)**2)
       K=K+NCOL
    ENDDO

    RNRM2=SQRT(S)

  END FUNCTION RNRM2

! ------ --------- -------- ------
  DOUBLE PRECISION FUNCTION RMXUPS(NTST,NCOL,NDIM,I,UPS)

! Computes the maximum of the I'th component of UPS.

    INTEGER, INTENT(IN) :: I,NDIM,NCOL,NTST
    DOUBLE PRECISION, INTENT(IN) :: UPS(NDIM,0:NTST*NCOL)

    RMXUPS=MAXVAL(UPS(I,:))

  END FUNCTION RMXUPS

! ------ --------- -------- -------
  DOUBLE PRECISION FUNCTION RMXUPST(NTST,NCOL,NDIM,I,UPS,DTM)

! Computes the t value for the maximum of the I'th component of UPS.

    INTEGER, INTENT(IN) :: I,NDIM,NCOL,NTST
    DOUBLE PRECISION, INTENT(IN) :: UPS(NDIM,0:NTST*NCOL),DTM(NTST)

    INTEGER LOC(1),J,L,M

    LOC=MAXLOC(UPS(I,:))
    L=LOC(1)-1
    J=L/NCOL
    RMXUPST=SUM(DTM(1:J))
    M=MOD(L,NCOL)
    IF(M>0)THEN
       RMXUPST=RMXUPST+DTM(J+1)*M/NCOL
    ENDIF

  END FUNCTION RMXUPST

! ------ --------- -------- ------
  DOUBLE PRECISION FUNCTION RMNUPS(NTST,NCOL,NDIM,I,UPS)

! Computes the minimum of the I'th component of UPS.

    INTEGER, INTENT(IN) :: I,NDIM,NCOL,NTST
    DOUBLE PRECISION, INTENT(IN) :: UPS(NDIM,0:NTST*NCOL)

    RMNUPS=MINVAL(UPS(I,:))

  END FUNCTION RMNUPS

! ------ --------- -------- -------
  DOUBLE PRECISION FUNCTION RMNUPST(NTST,NCOL,NDIM,I,UPS,DTM)

! Computes the t value for the minimum of the I'th component of UPS.

    INTEGER, INTENT(IN) :: I,NDIM,NCOL,NTST
    DOUBLE PRECISION, INTENT(IN) :: UPS(NDIM,0:NTST*NCOL),DTM(NTST)

    INTEGER LOC(1),J,L,M

    LOC=MINLOC(UPS(I,:))
    L=LOC(1)-1
    J=L/NCOL
    RMNUPST=SUM(DTM(1:J))
    M=MOD(L,NCOL)
    IF(M>0)THEN
       RMNUPST=RMNUPST+DTM(J+1)*M/NCOL
    ENDIF

  END FUNCTION RMNUPST

! ---------- ------
  SUBROUTINE SCALEB(NTST,NCOL,NDIM,NFPR,DVPS,RLD,DTM,THL,THU)

! Scales the vector (DVPS,RLD) so its norm becomes 1.

    INTEGER, INTENT(IN) :: NTST,NCOL,NDIM,NFPR
    DOUBLE PRECISION, INTENT(IN) :: DTM(*),THL(NFPR),THU(*)
    DOUBLE PRECISION, INTENT(INOUT) :: DVPS(NDIM,0:NCOL*NTST),RLD(NFPR)

    DOUBLE PRECISION SS

    SS=SQRT(RNRMSQ(NTST,NCOL,NDIM,NDIM,DVPS,DTM,THU)+ &
         DOT_PRODUCT(THL(:),RLD(:)**2))

    DVPS(:,:)=DVPS(:,:)/SS
    RLD(:)=RLD(:)/SS

  END SUBROUTINE SCALEB

END MODULE MESH


!!# FUNCTION MODULE: <InterpGrid2S_BiVar>
MODULE FUN_InterpGrid2S_BiVar

!!## PURPOSE
!! This subroutine interpolates a list of discrete function values
!! <F(1:N)> provided at points <(x,y)=r(:,1:N)>, to a grid,
!! given by <xout(1:M)> and <yout(1:M)>.

!!## EXTERNAL
USE KND_IntrinsicTypes                        !!((01-A-KND_IntrinsicTypes.f90))
USE FUN_Default                               !!((04-A-FUN_Default.f90))
USE LIB_BiVar                                 !!((04-A-LIB_BiVar.f90))

!!## DEFAULT IMPLICIT
IMPLICIT NONE

!!## DEFAULT ACCESS
PRIVATE

!!## PROCEDURE OVERLOADING
INTERFACE InterpGrid2S_BiVar
 MODULE PROCEDURE InterpGrid2S_BiVar_Rsp
 MODULE PROCEDURE InterpGrid2S_BiVar_Rdp
END INTERFACE

!!## PUBLIC ACCESS LIST
PUBLIC :: InterpGrid2S_BiVar

!!## PROCEDURES
CONTAINS

!!### FUNCTION: InterpGrid2S_Bivar_Rsp
FUNCTION InterpGrid2S_BiVar_Rsp( F , r , xout , yout , errmsg , &
  md,errint)  RESULT(Fout)
!!#### LOCAL KINDS
USE KND_IntrinsicTypes,ONLY: KIND_R=>KIND_Rsp !!((01-A-KND_IntrinsicTypes.f90))
INCLUDE "06-B-FUN_InterpGrid2S_BiVar_R.f90.hdr"
!!--begin--
INCLUDE "06-B-FUN_InterpGrid2S_BiVar_R.f90.bdy"
!!--end--
END FUNCTION

!!### FUNCTION: InterpGrid2S_Bivar_Rdp
FUNCTION InterpGrid2S_BiVar_Rdp( F , r , xout , yout , errmsg , &
  md,errint)  RESULT(Fout)
!!#### LOCAL KINDS
USE KND_IntrinsicTypes,ONLY: KIND_R=>KIND_Rdp !!((01-A-KND_IntrinsicTypes.f90))
INCLUDE "06-B-FUN_InterpGrid2S_BiVar_R.f90.hdr"
!!--begin--
INCLUDE "06-B-FUN_InterpGrid2S_BiVar_R.f90.bdy"
!!--end--
END FUNCTION

END MODULE


module interface_05_mod
implicit none

interface a
    module procedure a1
    module procedure a2
end interface

contains

    integer function a1(a)
    integer, intent(in) :: a
    a1 = a + 1
    end function

    real function a2(a)
    real, intent(in) :: a
    a2 = a + 1
    end function

end module

program interface_05
use interface_05_mod, only: a
implicit none

integer :: i
real :: r

i = 5
i = a(i)
if (i /= 6) error stop

r = 6
r = a(r)
if (r /= 7) error stop

i = 7
i = a(i)
if (i /= 8) error stop

end program


! { dg-do run }

module e_54_5_mod
contains
  subroutine init (v1, v2, N)
    integer :: i, N
    real, pointer, dimension(:) :: v1, v2
    do i = 1, N
      v1(i) = i + 2.0
      v2(i) = i - 3.0
    end do
  end subroutine

  subroutine check (p, N)
    integer :: i, N
    real, parameter :: EPS = 0.00001
    real, pointer, dimension(:) :: p
    real :: diff
    do i = 1, N
      diff = p(i) - (i + 2.0) * (i - 3.0)
      if (diff > EPS .or. -diff > EPS) call abort
    end do
  end subroutine

  subroutine vec_mult (p, v1, v2, N)
    real :: p(N), v1(N), v2(N)
    integer :: i, N
    !$omp target teams map(to: v1, v2) map(from: p)
      !$omp distribute simd
      do i = 1, N
        p(i) = v1(i) * v2(i)
      end do
    !$omp end target teams
  end subroutine
end module

program e_54_5
  use e_54_5_mod, only : init, check, vec_mult
  real, pointer, dimension(:) :: p, v1, v2
  integer :: n
  n = 1000
  allocate (p(n), v1(n), v2(n))
  call init (v1, v2, n)
  call vec_mult (p, v1, v2, n)
  call check (p, N)
  deallocate (p, v1, v2)
end program


      SUBROUTINE ODEINT1 (YSTART1,NVAR1,X11,X21,EPS1,H11,HMIN1,NOK1,
     >                    NBAD1)

      PARAMETER (MAXSTP1=100,TWO1=2.0,ZERO1=0.00,TINY1=1.0E-20)
      integer NVAR1
      COMMON /PATH1/KMAX1,KOUNT1,DXSAV1,XP1(200),YP1(10,200)
      DIMENSION YSTART1(NVAR1),YSCAL1(NVAR1),Y1(NVAR1),DYDX1(NVAR1)

      X1    = X11
      H1    = sign(H11,X21-X11)
      NOK1  = 0
      NBAD1 = 0
      KMAX1 = 0
c      write(*,*) 'in odeint1,NVAR1',NVAR1
      DO 11 I=1,NVAR1
         Y1(I) = YSTART1(I)
c		 write(*,*) YSTART1(I),Y1(I)
11    CONTINUE

C  ASSURE STORAGE OF FIRST STEP
      XSAV1 = X1 - DXSAV1*TWO1

C  TAKE AT MOST MAXSTP STEPS
      DO 16 NSTP1 = 1, MAXSTP1
c       write(*,*) 'in odeint1, calling derivs1'
         CALL derivs1(X1,Y1,DYDX1,NVAR1)										!This Line: DYDX1 = dRho_m(alpha)/dt & dRho_im(alpha)/dt
c       write(*,*) 'in odeint1, after derivs1'
         DO 12 I = 1, NVAR1
C  SCALING USED TO MONITOR ACCURACY. THIS CAN BE MODIFIED AS NEEDED
            YSCAL1(I) = abs(Y1(I)) + abs(H1*DYDX1(I))+TINY1
12       CONTINUE

         IF((X1+H1-X21)*(X1+H1-X11) .GT. ZERO1) H1=X21-X1

C IF STEP CAN OVERSHOOT END,CUT DOWN STEPSIZE
c         write(*,*) 'in odeint1, calling rkqc1,NVAR1',NVAR1
         CALL RKQC1(Y1,DYDX1,NVAR1,X1,H1,EPS1,YSCAL1,HDID1,HNEXT1,
     >              HMIN1)
c	     write(*,*) 'in odeint1, after rkqc1'

         IF ((X1-X21)*(X21-X11) .GE. ZERO1) THEN

C ARE WE DONE?
            DO 14 I = 1, NVAR1
               YSTART1(I)=Y1(I)
c			write(*,*) YSTART1(I),Y1(I),'end',NVAR1
14          CONTINUE

            RETURN
         ENDIF

16    CONTINUE

      IF(abs(HNEXT1) .LT. HMIN1) H1 = HNEXT1
      WRITE(*,31)
31    FORMAT(' STEPSIZE SMALLER THAN MINIMUM')

      RETURN
      END


C--------------------------------------------------------
C  COMPUTE PARTIAL CORRELATION COEFFICIENT AND
C       SIGNIFICANCE FOR CENSORED DATA
C
C               AUGUST 1995
C
C  THE CODE IS BASED ON THE METHODOLOGY PRESENTED IN
C     'A test for partial correlation with censored
C                astronomical data'
C                      BY
C            M.G.Akritas and J.Siebert
C  Monthly Notices of the Royal Astronomical Society
C               278, 919-924, 1996
C-------------------------------------------------------
c
c CHANGELOG:
c 	RODRIGO S. NEMMEN, http://goo.gl/8S1Oo
c	JUNE 2011
c	- accepts any filename for input data file
c	- free format input data, allows more freedom with input columns
c	- outputs the confidence level in standard deviations and the
c     probability (Pnull) with which the null hypothesis can be rejected
c     (null hypothesis: no correlation between x and y taking into
c	  account the effect of z)

      program partial_tau

      common /data/ dat(500,3),idat(500,3)
      common ntot
      common /kx/ k1,k2,k3
      character infile*50

C-------------------------------------------------------------
C  INPUT DATA FILE CALLED 'DATA'.
C  CURRENTLY THE DATA FORMAT IS FIXED TO 3(f10.4,1x,i2,1x).
C  1ST, 3RD AND 5TH COLUMN ARE INDEPENDENT, DEPENDENT AND TEST
C  VARIABLE, RESPECTIVELY. 2ND, 4TH AND 6TH COLUMN DENOTE
C  CENSORING WITH 1 = DETECTION, 0= UPPER LIMIT
C  EXAMPLE:
C  '   26.9800  1    44.4340  0    -1.0714  1 '
C-------------------------------------------------------------

c Nemmen  -->
      write(*,*) 'Name of input file [x cx? y cy? z cz?]:'
c      write(*,*) ' x, y and z are the the independent, dependent'
c      write(*,*) '     and test variable, respectively.'
c      write(*,*) '     cx, cy and cz denote censoring with'
c      write(*,*) '     1=detection, 0=upper limit.'
      read(*,*) infile
c N <--
      open(10,file=infile,status='old')

C-------------------------------------------------
C READ IN DATA:
C     DAT(I,K)  = MEASUREMENT I OF VARIABLE K
C     IDAT(I,K) = CENSORING INDICATOR FOR DATA POINT (I,K)
C                 DETECTION   --> IDAT(I,K)=1
C                 UPPER LIMIT --> IDAT(I,K)=0
C--------------------------------------------------

      i=1
c1     read(10,110,end=99) dat(i,1),idat(i,1),dat(i,2),
c     #     idat(i,2),dat(i,3),idat(i,3)
1     read(10,*,end=99) dat(i,1),idat(i,1),dat(i,2),
     #     idat(i,2),dat(i,3),idat(i,3)
c110   format(3(f10.4,1x,i2,1x))
      dat(i,1)=-dat(i,1)     ! CHANGE TO RIGHT CENSORING
      dat(i,2)=-dat(i,2)     ! CHANGE TO RIGHT CENSORING
      dat(i,3)=-dat(i,3)     ! CHANGE TO RIGHT CENSORING
      i=i+1
      goto 1
99    ntot=i-1

      k1=1       ! INDEPENDENT VARIABLE = 1.COL OF DAT
      k2=2       ! DEPENDENT VARIABLE   = 2.COL OF DAT
      k3=3       ! THIRD VARIABLE       = 3.COL OF DAT

      call tau123(res)     ! COMPUTE PARTIAL KENDALLS TAU

      write(6,*) 'Tau(1,2):',tau(k1,k2)
      write(6,*) 'Tau(1,3):',tau(k1,k3)
      write(6,*) 'Tau(2,3):',tau(k2,k3)
      write(6,*) '--> Partial Kendalls tau:', res
      write(6,*) '  '
      write(6,*) 'Calculating variance...this takes some time....'
      write(6,*) '  '

      call sigma(sig)      ! COMPUTE VARIANCE

      write(6,*) 'Square root of variance (sigma):',sig
      write(6,*) '  '

      if(abs(res/sig).gt.1.96) then
        write(6,*) 'Zero partial correlation rejected at level 0.05'
      else
       write(6,*) 'Null hypothesis cannot be rejected!'
       write(6,*) '(--> No correlation present, if influence of
     #third variable is excluded)'
      endif

c Nemmen -->
      write(*,*)
      write(*,*) 'More specifically:'
      write(*,*) 'Null hypothesis rejected at ', abs(res/sig), 'sigma'
      write(*,*) 'Probability of null hypothesis =', 1.-erf(abs(res
     # /sig)/sqrt(2.))
c N <--

      stop
      end

C------------------------------------------------------
C-------- SUBROUTINES AND FUNCTIONS -------------------
C------------------------------------------------------

C------------ TAU123 ---------------------------------
C-------- PARTIAL KENDALLS TAU -----------------------

      subroutine tau123(res)
      common /kx/ k1,k2,k3

      res= (tau(k1,k2)-tau(k1,k3)*tau(k2,k3))/
     # sqrt((1.-tau(k1,k3)**2)*(1.-tau(k2,k3)**2))
      end

C------------ SIGMA -----------------------------------
C-------- VARIANCE OF STATISTIC -----------------------

      subroutine sigma(sigres)
      common ntot
      common /kx/ k1,k2,k3

      sig2=an( )/(ntot*(1.-tau(k1,k3)**2)*(1.-tau(k2,k3)**2))
      sigres=sqrt(sig2)
      end

C------------ AN ---------------------------------------
C------- COMPUTES VALUE FOR A_N -------------------------

      function an( )
      double precision aasum(500)
      common ntot
      common /data/ dat(500,3),idat(500,3)
      common /kx/ k1,k2,k3
      c1=16./(float(ntot)-1.)
      c2=6./((float(ntot)-1.)*(float(ntot)-2.)*(float(ntot)-3.))
      asum=0.0
      ave = 0.0
      do 5 i=1,ntot
        aasum(i)=0.0
 5    continue
      do 10 i1=1,ntot     ! OUTER SUMMATION (I1)
      write(6,*) i1
        do 11 j1=1,ntot-2         ! INNER SUMMATION WITH
          if(j1.eq.i1) goto 11    ! J1<I2<J2 AND ALL .NE. I1
          do 12 j2=j1+2,ntot      !
            if(j2.eq.i1) goto 12  !
            do 13 i2=j1+1,j2-1    !
            if(i2.eq.i1) goto 13  !
            cj1=- idat(j1,k1)
            if(dat(i1,k1).lt.dat(j1,k1)) cj1=idat(i1,k1)
            cj2=- idat(j1,k2)
            if(dat(i1,k2).lt.dat(j1,k2)) cj2=idat(i1,k2)
            cj3=- idat(j1,k3)
            if(dat(i1,k3).lt.dat(j1,k3)) cj3=idat(i1,k3)
            cj4=- idat(j2,k2)
            if(dat(i2,k2).lt.dat(j2,k2)) cj4=idat(i2,k2)
            cj5=- idat(j2,k3)
            if(dat(i2,k3).lt.dat(j2,k3)) cj5=idat(i2,k3)
            cj6=- idat(i2,k2)
            if(dat(j2,k2).lt.dat(i2,k2)) cj6=idat(j2,k2)
            cj7=- idat(i2,k3)
            if(dat(j2,k3).lt.dat(i2,k3)) cj7=idat(j2,k3)
            gtsum=cj1*(2.0*cj2 - cj3*(cj4*cj5+cj6*cj7) )

            cj1=- idat(j2,k1)
            if(dat(i1,k1).lt.dat(j2,k1)) cj1=idat(i1,k1)
            cj2=- idat(j2,k2)
            if(dat(i1,k2).lt.dat(j2,k2)) cj2=idat(i1,k2)
            cj3=- idat(j2,k3)
            if(dat(i1,k3).lt.dat(j2,k3)) cj3=idat(i1,k3)
            cj4=- idat(j1,k2)
            if(dat(i2,k2).lt.dat(j1,k2)) cj4=idat(i2,k2)
            cj5=- idat(j1,k3)
            if(dat(i2,k3).lt.dat(j1,k3)) cj5=idat(i2,k3)
            cj6=- idat(i2,k2)
            if(dat(j1,k2).lt.dat(i2,k2)) cj6=idat(j1,k2)
            cj7=- idat(i2,k3)
            if(dat(j1,k3).lt.dat(i2,k3)) cj7=idat(j1,k3)
            gtsum=gtsum+cj1*(2.0*cj2 - cj3*(cj4*cj5+cj6*cj7) )

            cj1=- idat(i2,k1)
            if(dat(i1,k1).lt.dat(i2,k1)) cj1=idat(i1,k1)
            cj2=- idat(i2,k2)
            if(dat(i1,k2).lt.dat(i2,k2)) cj2=idat(i1,k2)
            cj3=- idat(i2,k3)
            if(dat(i1,k3).lt.dat(i2,k3)) cj3=idat(i1,k3)
            cj4=- idat(j1,k2)
            if(dat(j2,k2).lt.dat(j1,k2)) cj4=idat(j2,k2)
            cj5=- idat(j1,k3)
            if(dat(j2,k3).lt.dat(j1,k3)) cj5=idat(j2,k3)
            cj6=- idat(j2,k2)
            if(dat(j1,k2).lt.dat(j2,k2)) cj6=idat(j1,k2)
            cj7=- idat(j2,k3)
            if(dat(j1,k3).lt.dat(j2,k3)) cj7=idat(j1,k3)
            gtsum=gtsum+cj1*(2.0*cj2 - cj3*(cj4*cj5+cj6*cj7) )

            cj1=- idat(i1,k1)
            if(dat(j1,k1).lt.dat(i1,k1)) cj1=idat(j1,k1)
            cj2=- idat(i1,k2)
            if(dat(j1,k2).lt.dat(i1,k2)) cj2=idat(j1,k2)
            cj3=- idat(i1,k3)
            if(dat(j1,k3).lt.dat(i1,k3)) cj3=idat(j1,k3)
            cj4=- idat(j2,k2)
            if(dat(i2,k2).lt.dat(j2,k2)) cj4=idat(i2,k2)
            cj5=- idat(j2,k3)
            if(dat(i2,k3).lt.dat(j2,k3)) cj5=idat(i2,k3)
            cj6=- idat(i2,k2)
            if(dat(j2,k2).lt.dat(i2,k2)) cj6=idat(j2,k2)
            cj7=- idat(i2,k3)
            if(dat(j2,k3).lt.dat(i2,k3)) cj7=idat(j2,k3)
            gtsum=gtsum+cj1*(2.0*cj2 - cj3*(cj4*cj5+cj6*cj7) )

            cj1=- idat(i2,k1)
            if(dat(j1,k1).lt.dat(i2,k1)) cj1=idat(j1,k1)
            cj2=- idat(i2,k2)
            if(dat(j1,k2).lt.dat(i2,k2)) cj2=idat(j1,k2)
            cj3=- idat(i2,k3)
            if(dat(j1,k3).lt.dat(i2,k3)) cj3=idat(j1,k3)
            cj4=- idat(j2,k2)
            if(dat(i1,k2).lt.dat(j2,k2)) cj4=idat(i1,k2)
            cj5=- idat(j2,k3)
            if(dat(i1,k3).lt.dat(j2,k3)) cj5=idat(i1,k3)
            cj6=- idat(i1,k2)
            if(dat(j2,k2).lt.dat(i1,k2)) cj6=idat(j2,k2)
            cj7=- idat(i1,k3)
            if(dat(j2,k3).lt.dat(i1,k3)) cj7=idat(j2,k3)
            gtsum=gtsum+cj1*(2.0*cj2 - cj3*(cj4*cj5+cj6*cj7) )

            cj1=- idat(j2,k1)
            if(dat(j1,k1).lt.dat(j2,k1)) cj1=idat(j1,k1)
            cj2=- idat(j2,k2)
            if(dat(j1,k2).lt.dat(j2,k2)) cj2=idat(j1,k2)
            cj3=- idat(j2,k3)
            if(dat(j1,k3).lt.dat(j2,k3)) cj3=idat(j1,k3)
            cj4=- idat(i2,k2)
            if(dat(i1,k2).lt.dat(i2,k2)) cj4=idat(i1,k2)
            cj5=- idat(i2,k3)
            if(dat(i1,k3).lt.dat(i2,k3)) cj5=idat(i1,k3)
            cj6=- idat(i1,k2)
            if(dat(i2,k2).lt.dat(i1,k2)) cj6=idat(i2,k2)
            cj7=- idat(i1,k3)
            if(dat(i2,k3).lt.dat(i1,k3)) cj7=idat(i2,k3)
            gtsum=gtsum+cj1*(2.0*cj2 - cj3*(cj4*cj5+cj6*cj7) )

            cj1=- idat(i1,k1)
            if(dat(i2,k1).lt.dat(i1,k1)) cj1=idat(i2,k1)
            cj2=- idat(i1,k2)
            if(dat(i2,k2).lt.dat(i1,k2)) cj2=idat(i2,k2)
            cj3=- idat(i1,k3)
            if(dat(i2,k3).lt.dat(i1,k3)) cj3=idat(i2,k3)
            cj4=- idat(j2,k2)
            if(dat(j1,k2).lt.dat(j2,k2)) cj4=idat(j1,k2)
            cj5=- idat(j2,k3)
            if(dat(j1,k3).lt.dat(j2,k3)) cj5=idat(j1,k3)
            cj6=- idat(j1,k2)
            if(dat(j2,k2).lt.dat(j1,k2)) cj6=idat(j2,k2)
            cj7=- idat(j1,k3)
            if(dat(j2,k3).lt.dat(j1,k3)) cj7=idat(j2,k3)
            gtsum=gtsum+cj1*(2.0*cj2 - cj3*(cj4*cj5+cj6*cj7) )

            cj1=- idat(j1,k1)
            if(dat(i2,k1).lt.dat(j1,k1)) cj1=idat(i2,k1)
            cj2=- idat(j1,k2)
            if(dat(i2,k2).lt.dat(j1,k2)) cj2=idat(i2,k2)
            cj3=- idat(j1,k3)
            if(dat(i2,k3).lt.dat(j1,k3)) cj3=idat(i2,k3)
            cj4=- idat(j2,k2)
            if(dat(i1,k2).lt.dat(j2,k2)) cj4=idat(i1,k2)
            cj5=- idat(j2,k3)
            if(dat(i1,k3).lt.dat(j2,k3)) cj5=idat(i1,k3)
            cj6=- idat(i1,k2)
            if(dat(j2,k2).lt.dat(i1,k2)) cj6=idat(j2,k2)
            cj7=- idat(i1,k3)
            if(dat(j2,k3).lt.dat(i1,k3)) cj7=idat(j2,k3)
            gtsum=gtsum+cj1*(2.0*cj2 - cj3*(cj4*cj5+cj6*cj7) )

            cj1=- idat(j2,k1)
            if(dat(i2,k1).lt.dat(j2,k1)) cj1=idat(i2,k1)
            cj2=- idat(j2,k2)
            if(dat(i2,k2).lt.dat(j2,k2)) cj2=idat(i2,k2)
            cj3=- idat(j2,k3)
            if(dat(i2,k3).lt.dat(j2,k3)) cj3=idat(i2,k3)
            cj4=- idat(j1,k2)
            if(dat(i1,k2).lt.dat(j1,k2)) cj4=idat(i1,k2)
            cj5=- idat(j1,k3)
            if(dat(i1,k3).lt.dat(j1,k3)) cj5=idat(i1,k3)
            cj6=- idat(i1,k2)
            if(dat(j1,k2).lt.dat(i1,k2)) cj6=idat(j1,k2)
            cj7=- idat(i1,k3)
            if(dat(j1,k3).lt.dat(i1,k3)) cj7=idat(j1,k3)
            gtsum=gtsum+cj1*(2.0*cj2 - cj3*(cj4*cj5+cj6*cj7) )

            cj1=- idat(i1,k1)
            if(dat(j2,k1).lt.dat(i1,k1)) cj1=idat(j2,k1)
            cj2=- idat(i1,k2)
            if(dat(j2,k2).lt.dat(i1,k2)) cj2=idat(j2,k2)
            cj3=- idat(i1,k3)
            if(dat(j2,k3).lt.dat(i1,k3)) cj3=idat(j2,k3)
            cj4=- idat(i2,k2)
            if(dat(j1,k2).lt.dat(i2,k2)) cj4=idat(j1,k2)
            cj5=- idat(i2,k3)
            if(dat(j1,k3).lt.dat(i2,k3)) cj5=idat(j1,k3)
            cj6=- idat(j1,k2)
            if(dat(i2,k2).lt.dat(j1,k2)) cj6=idat(i2,k2)
            cj7=- idat(j1,k3)
            if(dat(i2,k3).lt.dat(j1,k3)) cj7=idat(i2,k3)
            gtsum=gtsum+cj1*(2.0*cj2 - cj3*(cj4*cj5+cj6*cj7) )

            cj1=- idat(j1,k1)
            if(dat(j2,k1).lt.dat(j1,k1)) cj1=idat(j2,k1)
            cj2=- idat(j1,k2)
            if(dat(j2,k2).lt.dat(j1,k2)) cj2=idat(j2,k2)
            cj3=- idat(j1,k3)
            if(dat(j2,k3).lt.dat(j1,k3)) cj3=idat(j2,k3)
            cj4=- idat(i1,k2)
            if(dat(i2,k2).lt.dat(i1,k2)) cj4=idat(i2,k2)
            cj5=- idat(i1,k3)
            if(dat(i2,k3).lt.dat(i1,k3)) cj5=idat(i2,k3)
            cj6=- idat(i2,k2)
            if(dat(i1,k2).lt.dat(i2,k2)) cj6=idat(i1,k2)
            cj7=- idat(i2,k3)
            if(dat(i1,k3).lt.dat(i2,k3)) cj7=idat(i1,k3)
            gtsum=gtsum+cj1*(2.0*cj2 - cj3*(cj4*cj5+cj6*cj7) )

            cj1=- idat(i2,k1)
            if(dat(j2,k1).lt.dat(i2,k1)) cj1=idat(j2,k1)
            cj2=- idat(i2,k2)
            if(dat(j2,k2).lt.dat(i2,k2)) cj2=idat(j2,k2)
            cj3=- idat(i2,k3)
            if(dat(j2,k3).lt.dat(i2,k3)) cj3=idat(j2,k3)
            cj4=- idat(j1,k2)
            if(dat(i1,k2).lt.dat(j1,k2)) cj4=idat(i1,k2)
            cj5=- idat(j1,k3)
            if(dat(i1,k3).lt.dat(j1,k3)) cj5=idat(i1,k3)
            cj6=- idat(i1,k2)
            if(dat(j1,k2).lt.dat(i1,k2)) cj6=idat(j1,k2)
            cj7=- idat(i1,k3)
            if(dat(j1,k3).lt.dat(i1,k3)) cj7=idat(j1,k3)
            gtsum=gtsum+cj1*(2.0*cj2 - cj3*(cj4*cj5+cj6*cj7) )

       aasum(i1)=aasum(i1)+1./24.*gtsum !ADD SUMMATION OVER PERMUTATIONS
13          continue              !
12        continue                !
11      continue                  !
      ave = ave + c2*aasum(i1)
10    continue
      ave=ave/float(ntot)
      do 20 i=1,ntot
      asum=asum+(c2*aasum(i)-ave)**2
 20   continue
      an=asum*c1
      return
      end

C------------- TAU -------------------------------------------
C------- COMPUTES KENDALLS TAU -------------------------------

      function tau(k,l)
      common ntot
      ac=2./(float(ntot)*(float(ntot)-1))
      sum=0.0
      do 11 j=1,ntot
        do 12 i=1,ntot
          if (i.ge.j) goto 11
          sum=sum+h(k,l,i,j)
12      continue
11    continue
      tau=sum*ac
      return
      end

C-------------- H --------------------------------------------
C------- COMPUTE VALUE FOR H (SEE FORMULA) --------------------

      function h(k,l,i,j)
      common /data/ dat(500,3),idat(500,3)
      cj1=-idat(j,k)
      if(dat(i,k).lt.dat(j,k)) cj1=idat(i,k)
      cj2=-idat(j,l)
      if(dat(i,l).lt.dat(j,l)) cj2=idat(i,l)
      h=cj1*cj2
      return
      end


program problem62
  implicit none
  integer, parameter :: n=10000,p=10000019
  integer            :: i
  integer*8          :: counts(0:p-1),temp

  do i=0,p-1
     counts(i)=0
  end do

  do i=1,n
     temp=hash(i)
     counts(temp)=counts(temp)+1
  end do

  do i=1,n
     temp=hash(i)
     if (counts(temp) == 5) then
        go to 100
     end if
  end do

100 continue
  print *, (i*1_16)**3

contains

  function hash(n)
    implicit none
    integer             :: primes(0:9)
    integer, intent(in) :: n
    integer*16          :: temp
    integer*8           :: hash

    primes=(/ 2, 3, 5, 7, 11, 13, 17, 19, 23, 29 /)
    hash=1
    temp=(n*1_16)**3

    do while (temp>0)
       hash=hash*primes(mod(temp,10))
       temp=temp/10
    end do

    hash=mod(hash,p)

  end function hash

end program problem62


!> \brief fourier contribution to total energy
!> \author M.Theiss
 module ES_Fourier_mod
  use working_prec_mod, only: rk, ik
  use basic_parameters_mod
  use sim_parameters_mod
  use globals_mod
  implicit none
  private

  public :: Fourier_Setup
  public :: Fourier_Move
  public :: Fourier_Move2

contains

!---------------------------------------------------------------------------------------------------------------------------------------
!> fourier setup
!---------------------------------------------------------------------------------------------------------------------------------------
subroutine Fourier_Setup(  )
integer(ik):: i, j, k, Ksq
real(rk):: b

b = PI * PI / ( Alpha * Alpha )

Nkvec = 0_ik

do i = 0, Kmax
    do j = -Kmax, Kmax
        do k = -Kmax, Kmax

            Ksq = i*i + j*j + k*k

                        if( ( Ksq /= 0_ik ) .AND. ( Ksq < Kmax * Kmax ) ) then
                            Nkvec = Nkvec + 1_ik
                        end if

            end do
    end do
end do

allocate( CONST(Nkvec) )
allocate( KX(Nkvec) )
allocate( KY(Nkvec) )
allocate( KZ(Nkvec) )

Nkvec = 0_ik

do i = 0, Kmax
    do j = -Kmax, Kmax
            do k = -Kmax, Kmax

                    Ksq = i*i + j*j + k*k

                    if( ( Ksq /= 0 ) .AND. ( Ksq < Kmax * Kmax ) ) then

                            Nkvec = Nkvec + 1_ik

                            CONST(Nkvec) = 1.0_rk / ( Pi * real( i*i + j*j + k*k, rk ) ) * &
                                                        exp( -b * real( i*i + j*j + k*k, rk ) )

                            if( i == 0 ) CONST(Nkvec) = 0.5_rk * CONST(Nkvec)

                            KX(Nkvec) = i
                            KY(Nkvec) = j
                            KZ(Nkvec) = k

                    end if
            end do
    end do
end do

end subroutine Fourier_Setup

!---------------------------------------------------------------------------------------------------------------------------------------
!> fourier move
!---------------------------------------------------------------------------------------------------------------------------------------
subroutine Fourier_Move  ( i, EXPX_CH, EXPY_CH, EXPZ_CH, EXPX_NEW, &
                                                    EXPY_NEW, EXPZ_NEW, &
                                                    SUMQEXPV_in, SUMQEXPV_NEW, DU_FOURIER )

integer(ik), intent(in) :: i

complex(rk), dimension(0:Kmax), intent(in)      :: EXPX_CH
complex(rk), dimension(-Kmax:Kmax), intent(in)  :: EXPY_CH, EXPZ_CH
complex(rk), dimension(0:Kmax), intent(out)     :: EXPX_NEW
complex(rk), dimension(-Kmax:Kmax), intent(out) :: EXPY_NEW, EXPZ_NEW

! SUMQEXPV contains the summation of qi*exp(i*(kx*x + ky*y + kz*z))
! for a given k-vector and hamiltonian before a move.
! SUMQEXPV_NEW contains the summation of qi*exp(i*(kx*x + ky*y + kz*z))
! for a given k-vector and hamiltonian after a move.

complex(rk), dimension(Nkvec), intent(in)   :: SUMQEXPV_in
complex(rk), dimension(Nkvec), intent(out)  :: SUMQEXPV_NEW

real(rk), intent(out)   :: DU_FOURIER

! Local variables

integer(ik) :: k
integer(ik) :: kkx, kky, kkz
real(rk)    :: xi, yi, zi
real(rk)    :: bx, by, bz
complex(rk) :: expv_diff

DU_FOURIER = 0.0_rk

EXPX_NEW = (1.0_rk,0.0_rk)
EXPY_NEW = (1.0_rk,0.0_rk)
EXPZ_NEW = (1.0_rk,0.0_rk)

! do i = 1, Ns

    xi = charge_positions(1,i)  !Xn(i)
    yi = charge_positions(2,i)  !Yn(i)
    zi = charge_positions(3,i)  !Zn(i)

    do k = 1, Kmax

            bx = real(k,rk) * 2.0_rk * PI / boxlength * xi
            by = real(k,rk) * 2.0_rk * PI / boxlength * yi
            bz = real(k,rk) * 2.0_rk * PI / boxlength * zi

            EXPX_NEW( k ) = cmplx( cos( bx ), sin( bx ),rk )
            EXPY_NEW( k ) = cmplx( cos( by ), sin( by ),rk )
            EXPZ_NEW( k ) = cmplx( cos( bz ), sin( bz ),rk )
            EXPY_NEW(-k ) = conjg( EXPY_NEW( k ) )
            EXPZ_NEW(-k ) = conjg( EXPZ_NEW( k ) )

    end do

! end do

SUMQEXPV_NEW = SUMQEXPV_in

! do i = 1, Ns

    do k = 1, Nkvec

            kkx = KX(k)
            kky = KY(k)
            kkz = KZ(k)

            expv_diff = EXPX_NEW( kkx ) * EXPY_NEW( kky ) *  &
                                    EXPZ_NEW( kkz ) - &
                                    EXPX_CH( kkx ) * EXPY_CH( kky ) * &
                                    EXPZ_CH( kkz )

            SUMQEXPV_NEW( k ) = SUMQEXPV_NEW( k ) +  expv_diff * charge_list(i)

    end do

! end do

do k = 1, Nkvec

    DU_FOURIER = DU_FOURIER + CONST(k) / boxlength *   &
                        ( conjg( SUMQEXPV_NEW( k ) ) * SUMQEXPV_NEW( k ) - &
                          conjg( SUMQEXPV_in( k ) ) * SUMQEXPV_in( k ) )

end do

end subroutine Fourier_Move

!---------------------------------------------------------------------------------------------------------------------------------------
!> fourier move #2 (faster)
!---------------------------------------------------------------------------------------------------------------------------------------
subroutine Fourier_Move2 ( Ns, Xn, Yn, Zn, CHARGEc,  &
                                    EXPX_in, EXPY_in, EXPZ_in, EXPX_NEW, EXPY_NEW, EXPZ_NEW, &
                                    SUMQEXPV_in, SUMQEXPV_NEW, DU_FOURIER )
integer(ik), intent(in):: Ns
real(rk), dimension(Ns), intent(in):: Xn, Yn, Zn
real(rk), dimension(Ns), intent(in):: CHARGEc

complex(rk), dimension(0:Kmax, Ns), intent(in) :: EXPX_in
complex(rk), dimension(-Kmax:Kmax, Ns), intent(in) :: EXPY_in, EXPZ_in
complex(rk), dimension(0:Kmax, Ns), intent(out):: EXPX_NEW
complex(rk), dimension(-Kmax:Kmax, Ns), intent(out):: EXPY_NEW, EXPZ_NEW

! SUMQEXPV contains the summation of qi*exp(i*(kx*x + ky*y + kz*z))
! for a given k-vector and hamiltonian before a move.
! SUMQEXPV_NEW contains the summation of qi*exp(i*(kx*x + ky*y + kz*z))
! for a given k-vector and hamiltonian after a move.

complex(rk), dimension(Nkvec), intent(in) :: SUMQEXPV_in
complex(rk), dimension(Nkvec), intent(out):: SUMQEXPV_NEW

! DU_FOURIER is the change in fourier energy for a given move.

real(rk), intent(out) :: DU_FOURIER

! Local variables

integer(ik) :: i, k
integer(ik) :: kkx, kky, kkz
real(rk)    :: xi, yi, zi
real(rk)    :: bx, by, bz
complex(rk) :: expv_diff

DU_FOURIER = 0.0_rk

EXPX_NEW = ( 1.0_rk, 0.0_rk )
EXPY_NEW = ( 1.0_rk, 0.0_rk )
EXPZ_NEW = ( 1.0_rk, 0.0_rk )

do i = 1, Ns

    xi = Xn(i)
    yi = Yn(i)
    zi = Zn(i)

    do k =1, Kmax

            bx = real(k,rk) * 2.0_rk * Pi / boxlength * xi
            by = real(k,rk) * 2.0_rk * Pi / boxlength * yi
            bz = real(k,rk) * 2.0_rk * Pi / boxlength * zi

            EXPX_NEW( k, i ) = cmplx( cos( bx ), sin( bx ),rk )
            EXPY_NEW( k, i ) = cmplx( cos( by ), sin( by ),rk )
            EXPZ_NEW( k, i ) = cmplx( cos( bz ), sin( bz ),rk )
            EXPY_NEW(-k, i ) = conjg( EXPY_NEW( k, i ) )
            EXPZ_NEW(-k, i ) = conjg( EXPZ_NEW( k, i ) )

    end do

end do

SUMQEXPV_NEW = SUMQEXPV_in

do i = 1, Ns

    do k = 1, Nkvec

            kkx = KX(k)
            kky = KY(k)
            kkz = KZ(k)

            expv_diff = EXPX_NEW( kkx, i ) * EXPY_NEW( kky, i ) *  &
                                    EXPZ_NEW( kkz, i ) - &
                                    EXPX_in( kkx, i ) * EXPY_in( kky, i ) * &
                                    EXPZ_in( kkz, i )

            SUMQEXPV_NEW( k ) = SUMQEXPV_NEW( k ) + expv_diff * CHARGEc( i)

    end do

end do

do k = 1, Nkvec

    DU_FOURIER = DU_FOURIER + CONST(k) / boxlength *   &
                                ( conjg( SUMQEXPV_NEW( k ) ) * SUMQEXPV_NEW( k ) - &
                                  conjg( SUMQEXPV_in( k ) ) * SUMQEXPV_in( k ) )

end do

return

end subroutine Fourier_Move2

end module ES_Fourier_mod


module radiation_eos
    ! Implements eos for radiation

contains
    subroutine get_radiation_eos(rho,T,f,u,p,s,cv,dpr,dpt)
        use constants_def, only : dp, arad, onethird
        real(dp), intent(in) :: rho     ! g cm**-3
        real(dp), intent(in) :: T   ! K
        real(dp), intent(out) :: f, u, s    ! ergs/g
        real(dp), intent(out) :: p  ! dyn cm**-2
        real(dp), intent(out) :: cv ! ergs/K/g
        real(dp), intent(out) :: dpr,dpt    ! dp/dlnrho, dp/dlnT
        real(dp), parameter :: fourthird = 4.0_dp*onethird
        real(dp) :: aT3, aT4

        aT3 = arad*T**3
        aT4 = arad*T**4
        u = aT4 / rho
        p = onethird*aT4
        f = -onethird*aT4/rho
        s = fourthird*aT3/rho
        dpr = 0.0
        dpt = fourthird*aT4
        cv = 4.0*aT3/rho
    end subroutine get_radiation_eos

end module radiation_eos


! for more info ref : http://www.icl.utk.edu/~mgates3/docs/fortran.html

program datatype
    !The implicit none statement is used to inhibit a very old feature of Fortran that by default treats all variables
    ! that start with the letters i, j, k, l, m and n as integers and all other variables as real arguments.
    !Implicit None should always be used. It prevents potential confusion in variable types, and makes detection of typographic errors easier.
   implicit none
   ! they all are static variables
   integer :: i;
   real :: r;
   character :: char;
   character(len = 20) :: str;
   logical :: bool;
   complex :: c;  ! CTM: we can perform several operation between complex numbers ex: c1 = c1 + c2;

   real, parameter :: pi = 3.1415 ! constant syntax <data_type>, parameter :: <constant name> = <exp>
   ! for constants its not like "real, parameter ::pi /3.1415/"
   str = "Hello world i am wasit shafi";
   i = 10;
   r = 55.36;
   char = 'C';
   bool = 0;
   c = (4, -8);  ! c = 4 + 8i

   print *, "i        : ", i;
   print *, "r        : ", r;
   print *, "char     : ", char;
   print *, "str      : ", str;
   print *, "str(3:8) : ", str(3 : 8);
   print *, "bool     : ", bool;
   print *, "c        : ", c;
   print *, "pi       : ", pi;

end program datatype


!##############################################################################
!# Tutorial 006d: Discretise with Q1, create a Laplace matrix
!##############################################################################

module tutorial006d

  ! Include basic Feat-2 modules
  use fsystem
  use genoutput

  use triangulation
  use meshgeneration

  use element
  use spatialdiscretisation
  use linearsystemscalar
  use bilinearformevaluation
  use derivatives
  use stdoperators

  use matrixio

  implicit none
  private

  public :: start_tutorial006d

contains

  ! ***************************************************************************

  subroutine start_tutorial006d

    ! Declare some variables.
    type(t_triangulation) :: rtriangulation
    type(t_spatialdiscretisation) :: rdiscretisation
    type(t_matrixScalar) :: rmatrix
    character(LEN=SYS_STRLEN) :: spostdir

    ! Print a message
    call output_lbrk()
    call output_separator (OU_SEP_STAR)
    call output_line ("This is FEAT-2. Tutorial 006d")
    call output_separator (OU_SEP_MINUS)

    ! =================================
    ! Create a brick mesh
    ! =================================

    ! The mesh must always be in "standard" format.
    ! First create a 5x5-mesh on [0,1]x[0,1], then convert to standard.
    call meshgen_rectangular2DQuadMesh (rtriangulation, 0.0_DP, 1.0_DP, 0.0_DP, 1.0_DP, 4, 4)
    call tria_initStandardMeshFromRaw (rtriangulation)

    ! =================================
    ! Discretise with Q1.
    !
    ! Create a structure rdiscretisation
    ! which describes the discretisation.
    ! =================================

    call spdiscr_initDiscr_simple (rdiscretisation,EL_Q1_2D,rtriangulation)

    ! =================================
    ! Create a CSR-matrix for the above
    ! discretisation.
    ! =================================

    ! Create the matrix structure
    call bilf_createMatrixStructure (rdiscretisation,LSYSSC_MATRIX9,rmatrix)

    ! Allocate memory for the content
    call lsyssc_allocEmptyMatrix (rmatrix)

    ! =================================
    ! Discretise Laplace and Mass matrix,
    ! output to text files.
    ! =================================
    call output_line ("Writing matrix to a text file...")

    ! -------------------------------------------
    ! Discretise the Laplace matrix.
    call lsyssc_clearMatrix (rmatrix)

    call stdop_assembleLaplaceMatrix (rmatrix)

    ! Write the matrix to a text file, omit nonexisting entries in the matrix.
    if (sys_getenv_string("POSTDIR",spostdir)) then
      call matio_writeMatrixHR (rmatrix, "matrix", .true., 0, &
          trim(spostdir)//"/tutorial006d_laplace.txt", "(E15.5)")
    else
      call matio_writeMatrixHR (rmatrix, "matrix", .true., 0, &
          "./post/tutorial006d_laplace.txt", "(E15.5)")
    end if

    ! -------------------------------------------
    ! Discretise the Mass matrix.

    ! NOTE: A mass matrix is defined by the entries  m_ij = ( phi_j, psi_i ), i.e.,
    ! in the corresponding bilinear form, we have to use function values of the
    ! test and trial functions phi/psi. The constant DER_FUNC2D below tells the
    ! code to use function values; see "derivatives.f90" for a list of possible
    ! derivative quantifiers.

    ! Clear the matrix and discretise using a "bilinear form" approach.
    call lsyssc_clearMatrix (rmatrix)

    call stdop_assembleSimpleMatrix (rmatrix,DER_FUNC2D,DER_FUNC2D)

    ! Write the matrix to a text file, omit nonexisting entries in the matrix.
    if (sys_getenv_string("POSTDIR",spostdir)) then
      call matio_writeMatrixHR (rmatrix, "matrix", .true., 0, &
          trim(spostdir)//"/tutorial006d_mass.txt", "(E15.5)")
    else
      call matio_writeMatrixHR (rmatrix, "matrix", .true., 0, &
          "./post/tutorial006d_mass.txt", "(E15.5)")
    end if

    ! =================================
    ! Cleanup
    ! =================================

    ! Release the matrix
    call lsyssc_releaseMatrix (rmatrix)

    ! Release the Q1-discretisation
    call spdiscr_releaseDiscr (rdiscretisation)

    ! Release the triangulation
    call tria_done (rtriangulation)

  end subroutine

end module


! Custom, (log)normal priors
subroutine prior(x, pmu, psd, lognorm, d)
    use mod_types
    use mod_statistics
    implicit none

    real(kind=r2), intent(in) :: x, pmu, psd
    logical, intent(in) :: lognorm
    real(kind=r2), intent(out) :: d

    real(kind=r2) :: xx

    if(lognorm) then
        xx = log(x)
    else
        xx = x
    end if

    d = ldnorm(xx, pmu, psd)
    return
end subroutine

subroutine prior_re(x, tausd, d)
    use mod_types
    use mod_statistics
    implicit none

    real(kind=r2), intent(in) :: x, tausd
    real(kind=r2), intent(out) :: d

    d = ldnorm(x, 0.0d0, tausd)
    return
end subroutine


      recursive function evapol(tu,nu,tv,nv,c,rad,x,y) result(e_res)
      implicit none
      real*8 :: e_res
c  function program evacir evaluates the function f(x,y) = s(u,v),
c  defined through the transformation
c      x = u*rad(v)*cos(v)    y = u*rad(v)*sin(v)
c  and where s(u,v) is a bicubic spline ( 0<=u<=1 , -pi<=v<=pi ), given
c  in its standard b-spline representation.
c
c  calling sequence:
c     f = evapol(tu,nu,tv,nv,c,rad,x,y)
c
c  input parameters:
c   tu    : real array, length nu, which contains the position of the
c           knots in the u-direction.
c   nu    : integer, giving the total number of knots in the u-direction
c   tv    : real array, length nv, which contains the position of the
c           knots in the v-direction.
c   nv    : integer, giving the total number of knots in the v-direction
c   c     : real array, length (nu-4)*(nv-4), which contains the
c           b-spline coefficients.
c   rad   : real function subprogram, defining the boundary of the
c           approximation domain. must be declared external in the
c           calling (sub)-program
c   x,y   : real values.
c           before entry x and y must be set to the co-ordinates of
c           the point where f(x,y) must be evaluated.
c
c  output parameter:
c   f     : real
c           on exit f contains the value of f(x,y)
c
c  other subroutines required:
c    bispev,fpbisp,fpbspl
c
c  references :
c    de boor c : on calculating with b-splines, j. approximation theory
c                6 (1972) 50-62.
c    cox m.g.  : the numerical evaluation of b-splines, j. inst. maths
c                applics 10 (1972) 134-149.
c    dierckx p. : curve and surface fitting with splines, monographs on
c                 numerical analysis, oxford university press, 1993.
c
c  author :
c    p.dierckx
c    dept. computer science, k.u.leuven
c    celestijnenlaan 200a, b-3001 heverlee, belgium.
c    e-mail : Paul.Dierckx@cs.kuleuven.ac.be
c
c  latest update : march 1989
c
c  ..scalar arguments..
      integer nu,nv
      real*8 x,y
c  ..array arguments..
      real*8 tu(nu),tv(nv),c((nu-4)*(nv-4))
c  ..user specified function
      real*8 rad
c  ..local scalars..
      integer ier
      real*8 u,v,r,f,one,dist
c  ..local arrays
      real*8 wrk(8)
      integer iwrk(2)
c  ..function references
      real*8 atan2,sqrt
c  ..
c  calculate the (u,v)-coordinates of the given point.
      one = 1
      u = 0.
      v = 0.
      dist = x**2+y**2
      if(dist.le.0.) go to 10
      v = atan2(y,x)
      r = rad(v)
      if(r.le.0.) go to 10
      u = sqrt(dist)/r
      if(u.gt.one) u = one
c  evaluate s(u,v)
  10  call bispev(tu,nu,tv,nv,c,3,3,u,1,v,1,f,wrk,8,iwrk,2,ier)
      e_res = f
      return
      end


module ofdft

! Routines for orbital free density functional theory. These routines are
! independent of any particular discretization.

use types, only: dp, sp
use constants, only: pi
implicit none
private
public f, read_pseudo

contains

real(dp) elemental function f(y, deriv)
! Function f(y) from Appendix A in [1].
!
! [1] Perrot, F. (1979). Gradient correction to the statistical electronic free
! energy at nonzero temperatures: Application to equation-of-state
! calculations. Physical Review A, 20(2), 586–594.
real(dp), intent(in) :: y ! must be positive
! if deriv == .true. compute df/dy instead. Default .false.
logical, intent(in), optional :: deriv
real(dp), parameter :: y0 = 3*pi/(4*sqrt(2._dp))
real(dp), parameter :: c(8) = [-0.8791880215_dp, 0.1989718742_dp, &
    0.1068697043e-2_dp, -0.8812685726e-2_dp, 0.1272183027e-1_dp, &
    -0.9772758583e-2_dp, 0.3820630477e-2_dp, -0.5971217041e-3_dp]
real(dp), parameter :: d(9) = [0.7862224183_dp, -0.1882979454e1_dp, &
    0.5321952681_dp, 0.2304457955e1_dp, -0.1614280772e2_dp, &
    0.5228431386e2_dp, -0.9592645619e2_dp, 0.9462230172e2_dp, &
    -0.3893753937e2_dp]
real(dp) :: u
integer :: i
logical :: deriv_
deriv_ = .false.
if (present(deriv)) deriv_ = deriv

if (.not. deriv_) then
    if (y <= y0) then
        f = log(y)
        do i = 0, 7
            f = f + c(i+1) * y**i
        end do
    else
        u = y**(2._dp / 3)
        f = 0
        do i = 0, 8
            f = f + d(i+1) / u**(2*i-1)
        end do
        ! Note: Few terms in [1] have "y" instead of "u" in them for y > y0, but
        ! that is obviously a typo.
    end if
else
    if (y <= y0) then
        f = 1 / y
        do i = 0, 6
            f = f + (i+1) * c(i+2) * y**i
        end do
    else
        u = y**(2._dp / 3)
        f = 0
        do i = 0, 8
            f = f - (2*i-1) * d(i+1) / u**(2*i)
        end do
        f = f * 2._dp/3 / y**(1._dp/3)
    end if
end if
end function

real(dp) elemental function f_sp(yd, deriv) result(rd)
! The same as f(), but uses single precision internally, which is faster.
real(dp), intent(in) :: yd ! must be positive
! if deriv == .true. compute df/dy instead. Default .false.
logical, intent(in), optional :: deriv
real(sp), parameter :: y0 = 3*real(pi, sp)/(4*sqrt(2._sp))
real(sp), parameter :: c(8) = [-0.8791880215_sp, 0.1989718742_sp, &
    0.1068697043e-2_sp, -0.8812685726e-2_sp, 0.1272183027e-1_sp, &
    -0.9772758583e-2_sp, 0.3820630477e-2_sp, -0.5971217041e-3_sp]
real(sp), parameter :: d(9) = [0.7862224183_sp, -0.1882979454e1_sp, &
    0.5321952681_sp, 0.2304457955e1_sp, -0.1614280772e2_sp, &
    0.5228431386e2_sp, -0.9592645619e2_sp, 0.9462230172e2_sp, &
    -0.3893753937e2_sp]
real(sp) :: u, r, y
integer :: i
logical :: deriv_
deriv_ = .false.
if (present(deriv)) deriv_ = deriv

y = real(yd, sp)
if (.not. deriv_) then
    if (y <= y0) then
        r = log(y)
        do i = 0, 7
            r = r + c(i+1) * y**i
        end do
    else
        u = y**(2._sp / 3)
        r = 0
        do i = 0, 8
            r = r + d(i+1) / u**(2*i-1)
        end do
        ! Note: Few terms in [1] have "y" instead of "u" in them for y > y0, but
        ! that is obviously a typo.
    end if
else
    if (y <= y0) then
        r = 1 / y
        do i = 0, 6
            r = r + (i+1) * c(i+2) * y**i
        end do
    else
        u = y**(2._sp / 3)
        r = 0
        do i = 0, 8
            r = r - (2*i-1) * d(i+1) / u**(2*i)
        end do
        r = r * 2._sp/3 / y**(1._sp/3)
    end if
end if
rd = r
end function

subroutine read_pseudo(filename, R, V, Z, Ediff)
! Reads the pseudopotential from the file 'filename'.
character(len=*), intent(in) :: filename   ! File to read from, e.g. "H.pseudo"
real(dp), allocatable, intent(out) :: R(:) ! radial grid [0, Rcut]
! potential on the radial grid. The potential smoothly changes into -1/R for
! r > Rcut, where Rcut = R(size(R)) is the cut-off radius
real(dp), allocatable, intent(out) :: V(:)
real(dp), intent(out) :: Z     ! Nuclear charge
real(dp), intent(out) :: Ediff ! The energy correction
real(dp) :: Rcut
integer :: N, i, u
open(newunit=u, file=filename, status="old")
read(u, *) Z, N, Rcut, Ediff
allocate(R(N), V(N))
do i = 1, N
    read(u, *) R(i), V(i)
end do
close(u)
R = R * Rcut
end subroutine

end module


!
module constants
  double precision, parameter :: amp=1.6726d-24, ame=9.1094d-28, clight=2.9979d10,  &
       ev2erg=1.6022d-12,  erg2ev=1.d0/ev2erg, echarge=4.8032d-10,              &
       pi=3.141592653589793238462643383d0, Cs0=9.79d5*9.12870929d-1
  double precision, parameter :: one3rd=1.d0/3.d0, sq2=1.414213562373095049d0,     &
                                 sq2m1=1.d0/sq2, sq3=1.73205080756887729353d0, sq3m1=1.d0/sq3
  double precision, parameter :: eps = 1.d-10
end module constants
!
!ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
!


*DECK CORTH
      SUBROUTINE CORTH (NM, N, LOW, IGH, AR, AI, ORTR, ORTI)
C***BEGIN PROLOGUE  CORTH
C***PURPOSE  Reduce a complex general matrix to complex upper Hessenberg
C            form using unitary similarity transformations.
C***LIBRARY   SLATEC (EISPACK)
C***CATEGORY  D4C1B2
C***TYPE      COMPLEX (ORTHES-S, CORTH-C)
C***KEYWORDS  EIGENVALUES, EIGENVECTORS, EISPACK
C***AUTHOR  Smith, B. T., et al.
C***DESCRIPTION
C
C     This subroutine is a translation of a complex analogue of
C     the ALGOL procedure ORTHES, NUM. MATH. 12, 349-368(1968)
C     by Martin and Wilkinson.
C     HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 339-358(1971).
C
C     Given a COMPLEX GENERAL matrix, this subroutine
C     reduces a submatrix situated in rows and columns
C     LOW through IGH to upper Hessenberg form by
C     unitary similarity transformations.
C
C     On INPUT
C
C        NM must be set to the row dimension of the two-dimensional
C          array parameters, AR and AI, as declared in the calling
C          program dimension statement.  NM is an INTEGER variable.
C
C        N is the order of the matrix A=(AR,AI).  N is an INTEGER
C          variable.  N must be less than or equal to NM.
C
C        LOW and IGH are two INTEGER variables determined by the
C          balancing subroutine  CBAL.  If  CBAL  has not been used,
C          set LOW=1 and IGH equal to the order of the matrix, N.
C
C        AR and AI contain the real and imaginary parts, respectively,
C          of the complex input matrix.  AR and AI are two-dimensional
C          REAL arrays, dimensioned AR(NM,N) and AI(NM,N).
C
C     On OUTPUT
C
C        AR and AI contain the real and imaginary parts, respectively,
C          of the Hessenberg matrix.  Information about the unitary
C          transformations used in the reduction is stored in the
C          remaining triangles under the Hessenberg matrix.
C
C        ORTR and ORTI contain further information about the unitary
C          transformations.  Only elements LOW through IGH are used.
C          ORTR and ORTI are one-dimensional REAL arrays, dimensioned
C          ORTR(IGH) and ORTI(IGH).
C
C     Calls PYTHAG(A,B) for sqrt(A**2 + B**2).
C
C     Questions and comments should be directed to B. S. Garbow,
C     APPLIED MATHEMATICS DIVISION, ARGONNE NATIONAL LABORATORY
C     ------------------------------------------------------------------
C
C***REFERENCES  B. T. Smith, J. M. Boyle, J. J. Dongarra, B. S. Garbow,
C                 Y. Ikebe, V. C. Klema and C. B. Moler, Matrix Eigen-
C                 system Routines - EISPACK Guide, Springer-Verlag,
C                 1976.
C***ROUTINES CALLED  PYTHAG
C***REVISION HISTORY  (YYMMDD)
C   760101  DATE WRITTEN
C   890831  Modified array declarations.  (WRB)
C   890831  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   920501  Reformatted the REFERENCES section.  (WRB)
C***END PROLOGUE  CORTH
C
      INTEGER I,J,M,N,II,JJ,LA,MP,NM,IGH,KP1,LOW
      REAL AR(NM,*),AI(NM,*),ORTR(*),ORTI(*)
      REAL F,G,H,FI,FR,SCALE
      REAL PYTHAG
C
C***FIRST EXECUTABLE STATEMENT  CORTH
      LA = IGH - 1
      KP1 = LOW + 1
      IF (LA .LT. KP1) GO TO 200
C
      DO 180 M = KP1, LA
         H = 0.0E0
         ORTR(M) = 0.0E0
         ORTI(M) = 0.0E0
         SCALE = 0.0E0
C     .......... SCALE COLUMN (ALGOL TOL THEN NOT NEEDED) ..........
         DO 90 I = M, IGH
   90    SCALE = SCALE + ABS(AR(I,M-1)) + ABS(AI(I,M-1))
C
         IF (SCALE .EQ. 0.0E0) GO TO 180
         MP = M + IGH
C     .......... FOR I=IGH STEP -1 UNTIL M DO -- ..........
         DO 100 II = M, IGH
            I = MP - II
            ORTR(I) = AR(I,M-1) / SCALE
            ORTI(I) = AI(I,M-1) / SCALE
            H = H + ORTR(I) * ORTR(I) + ORTI(I) * ORTI(I)
  100    CONTINUE
C
         G = SQRT(H)
         F = PYTHAG(ORTR(M),ORTI(M))
         IF (F .EQ. 0.0E0) GO TO 103
         H = H + F * G
         G = G / F
         ORTR(M) = (1.0E0 + G) * ORTR(M)
         ORTI(M) = (1.0E0 + G) * ORTI(M)
         GO TO 105
C
  103    ORTR(M) = G
         AR(M,M-1) = SCALE
C     .......... FORM (I-(U*UT)/H) * A ..........
  105    DO 130 J = M, N
            FR = 0.0E0
            FI = 0.0E0
C     .......... FOR I=IGH STEP -1 UNTIL M DO -- ..........
            DO 110 II = M, IGH
               I = MP - II
               FR = FR + ORTR(I) * AR(I,J) + ORTI(I) * AI(I,J)
               FI = FI + ORTR(I) * AI(I,J) - ORTI(I) * AR(I,J)
  110       CONTINUE
C
            FR = FR / H
            FI = FI / H
C
            DO 120 I = M, IGH
               AR(I,J) = AR(I,J) - FR * ORTR(I) + FI * ORTI(I)
               AI(I,J) = AI(I,J) - FR * ORTI(I) - FI * ORTR(I)
  120       CONTINUE
C
  130    CONTINUE
C     .......... FORM (I-(U*UT)/H)*A*(I-(U*UT)/H) ..........
         DO 160 I = 1, IGH
            FR = 0.0E0
            FI = 0.0E0
C     .......... FOR J=IGH STEP -1 UNTIL M DO -- ..........
            DO 140 JJ = M, IGH
               J = MP - JJ
               FR = FR + ORTR(J) * AR(I,J) - ORTI(J) * AI(I,J)
               FI = FI + ORTR(J) * AI(I,J) + ORTI(J) * AR(I,J)
  140       CONTINUE
C
            FR = FR / H
            FI = FI / H
C
            DO 150 J = M, IGH
               AR(I,J) = AR(I,J) - FR * ORTR(J) - FI * ORTI(J)
               AI(I,J) = AI(I,J) + FR * ORTI(J) - FI * ORTR(J)
  150       CONTINUE
C
  160    CONTINUE
C
         ORTR(M) = SCALE * ORTR(M)
         ORTI(M) = SCALE * ORTI(M)
         AR(M,M-1) = -G * AR(M,M-1)
         AI(M,M-1) = -G * AI(M,M-1)
  180 CONTINUE
C
  200 RETURN
      END


!=============================================================================!
      program mkamp
!
!  Determine the amplitude of a forced acoustic wave on the top boundary
!  accounting for viscous decay of the plane acoustic wave using the
!  formulae from Pierce.
!
!  Author:   S. Scott Collis
!
!  Written:  8-22-96
!=============================================================================!
      use const
      implicit none

      real, allocatable :: vm(:,:,:)

      real :: Ma, Re, Pr, gamma, cv, Rgas, time
      integer :: lstep, nx, ny, nz, ndof
      integer :: nxm, nym, nzm, ndofm
      integer :: i, j, k, idof, ix

      character*80 file, temp
      integer :: iloc, iend

      integer, external :: iargc

      real, allocatable :: rhom(:,:), um(:,:), tm(:,:), cm(:,:)
      real, allocatable :: x(:,:), y(:,:)

      real, allocatable :: wamp(:)
      logical :: lamp

      real :: tmp
      integer :: itmp

      real :: kk, alpha, delta, x0, r, rho0, c0, omega, th
!=============================================================================!

!.... read in the mean flow file

      open(unit=10, file='mean.dat', form='unformatted', &
           status='old', err=1000)
      read(10,err=1000) itmp, tmp, nx, ny, nz, ndof, &
                        Re, Ma, Pr, gamma, cv
      allocate( vm(ny,nx,ndof) )
      read(10,err=1000) vm
      close(10)

!.... read in the grid file

      open (unit=10, file='grid.dat', form='unformatted', status='unknown')
      read(10) nx, ny, nz
      allocate (x(ny,nx), y(ny,nx))
      read(10) (((x(j,i), i = 1, nx), j = 1, ny), k = 1, nz), &
               (((y(j,i), i = 1, nx), j = 1, ny), k = 1, nz), &
               (((   tmp, i = 1, nx), j = 1, ny), k = 1, nz)
      close(10)

!.... compute the acoustic wave

      allocate( rhom(ny,nx), um(ny,nx), tm(ny,nx), cm(ny,nx), wamp(nx) )

      rhom = vm(:,:,1)
      um   = vm(:,:,2)
      tm   = vm(:,:,5)
      cm   = sqrt( tm ) / Ma

      write(*,"('Correcting for Re = ',1pe13.6,', Pr ',1pe13.6)") Re, Pr
      rho0  = one

      if (Re .eq. zero) then
        delta = zero
      else
        delta = (one/Re) * pt5 / rho0 * ( onept33 + (gamma - one) / Pr )
      end if

      x0 = x(ny,1)
      write(*,"('Origin, X0 = ',1pe13.6)") x0

      write(*,"('Enter the angular frequency ==> ',$)")
      read(*,*) omega

      open(10,file='amp.dat')
      j = ny
      do i = 1, nx
        kk     = omega / ( cm(j,i) + um(j,i) )
        alpha  = omega**2 * delta / ( cm(j,i) + um(j,i) )**3
        wamp(i) = exp( -alpha * (x(j,i) - x0) )
        write(10,"(2(1pe20.13,1x))") x(j,i), wamp(i)
      end do
      close(10)

      call exit(0)

1000  write(*,"('>> Error reading mean field:  mean.dat')")
      call exit(1)

      end


module k_space
	use constants, 			only:		dp, pi_dp
	use mpi_community,		only:		mpi_id
	use matrix_math,		only:		crossP

	implicit none

	public						::		set_mp_grid,		get_mp_grid,		&
										set_recip_latt, 	get_recip_latt,		&
										get_kpt_idx,							&
										check_kpt_idx,							&
										get_rel_kpt,							&
										get_cart_kpt,							&
										get_bz_vol,								&
										kspace_allocator,						&
										normalize_k_int,						&
										print_kSpace_info
	private

	save

	interface normalize_k_int
		module procedure d0_tens_normalize_k_int
		module procedure d2_tens_normalize_k_int
		module procedure d3_tens_normalize_k_int
		module procedure d4_tens_normalize_k_int
		module procedure d5_tens_normalize_k_int
		!
		module procedure z0_tens_normalize_k_int
		module procedure z2_tens_normalize_k_int
		module procedure z3_tens_normalize_k_int
		module procedure z4_tens_normalize_k_int
		module procedure z5_tens_normalize_k_int
	end interface normalize_k_int

	integer			::		mp_grid(3)
	real(dp)		::		recip_latt(3,3), bz_vol, unit_vol
	logical			::		recip_latt_set = .false.

contains

	subroutine print_kSpace_info()
		real(dp)		:: dV

		if( recip_latt_set) then
			! debug BZ volume
			dV		=	bz_vol - 8.0_dp * pi_dp**3 / unit_vol
			if(	abs(dV)	> 1e-1_dp) then
				write(*,*)	"[set_recip_latt]: 	WARNING	KSPACE CORRUPTED!! bz_vol /= (8 pi**3/ unit_vol)"
			else
				write(*,'(a,i7.7,a,i4,a,i4,a,i4,a,a,f8.4,a,f8.4,a)')	&
									"[#",mpi_id,";k_space]: k-space setup done (mp_grid=",&
									mp_grid(1),"x",mp_grid(2),"x",mp_grid(3),"). ",&
									"unit_vol=,",unit_vol,",(a0**3) -> bz_vol=",bz_vol," (1/a0**3)"
			end if
		else
			write(*,'(a,i7.7,a)')	&
				"[#",mpi_id,";k_space]: ERROR reciprocal lattice was not initalized. Pls contact dev.."
		end if
		!
		!
		return
	end subroutine

!-----------------------------------------------------------------------------------
!-----------------------------------------------------------------------------------
!-----------------------------------------------------------------------------------
!
!			INTERFACE:		normalize_k_int
!
!			Vbz	=	(2pi)^3/ Vcell
!
!
!			int 	Vcell / (2pi)^3		d^3k  		---->		1 /( N_k)	sum_k
!
!-----------------------------------------------------------------------------------
	subroutine d0_tens_normalize_k_int(scalar)
		real(dp),	intent(inout)	::	scalar
		integer						::	n_k
		!
		n_k		=	mp_grid(1) * mp_grid(2) * mp_grid(3)
		!
		!
		if(n_k > 0	)		scalar	= 	scalar	 /	abs(	unit_vol	* real(n_k,dp)	)

		!
		return
	end subroutine
!------
	subroutine d2_tens_normalize_k_int(tens)
		real(dp),	allocatable,	intent(inout)	::	tens(:,:)
		integer						:: 	n_k
		!
		if(allocated(tens)) then
			n_k		=	mp_grid(1) * mp_grid(2) * mp_grid(3)
			if(n_k > 0	)		tens		=	tens		 /	abs(	unit_vol	* real(n_k,dp)	)
		end if
		!
		return
	end subroutine
!------
	subroutine d3_tens_normalize_k_int(tens)
		real(dp),	allocatable,	intent(inout)	::	tens(:,:,:)
		integer						:: 	n_k
		!
		if(allocated(tens)) then
			n_k	=	mp_grid(1) * mp_grid(2) * mp_grid(3)
			if(n_k > 0	)		tens	=	tens	 /	abs(	unit_vol	* real(n_k,dp)	)
		end if
		!
		return
	end subroutine
!------
	subroutine d4_tens_normalize_k_int(tens)
		real(dp),	allocatable,	intent(inout)	::	tens(:,:,:,:)
		integer						:: 	n_k
		!
		if(allocated(tens)) then
			n_k	=	mp_grid(1) * mp_grid(2) * mp_grid(3)
			if(n_k > 0	)		tens	=	tens	 /	abs(	unit_vol	* real(n_k,dp)	)
		end if
		!
		return
	end subroutine
!------
	subroutine d5_tens_normalize_k_int(tens)
		real(dp),	allocatable,	intent(inout)	::	tens(:,:,:,:,:)
		integer						:: 	n_k
		!
		if(allocated(tens)) then
			n_k	=	mp_grid(1) * mp_grid(2) * mp_grid(3)
			if(n_k > 0	)		tens	=	tens	 /	abs(	unit_vol	* real(n_k,dp)	)
		end if
		!
		return
	end subroutine
!~~~~~~~~~~~~~~~~~~~~~~~~~~
!------
!^^^^^^^^^^^^^^^^^^^^^^^^^
	subroutine z0_tens_normalize_k_int(scalar)
		complex(dp),	intent(inout)	::	scalar
		integer							::	n_k
		!
		n_k		=	mp_grid(1) * mp_grid(2) * mp_grid(3)
		!
		!
		if(n_k > 0	)		scalar	= 	scalar	 /	abs(	unit_vol	* real(n_k,dp)	)
		!
		return
	end subroutine
!------
	subroutine z2_tens_normalize_k_int(tens)
		complex(dp),	allocatable,	intent(inout)	::	tens(:,:)
		integer							:: 	n_k
		!
		if(allocated(tens))	then
			n_k		=	mp_grid(1) * mp_grid(2) * mp_grid(3)
			if(n_k > 0	)		tens		=	tens		 /	abs(	unit_vol	* real(n_k,dp)	)
		end if
		!
		return
	end subroutine
!------
	subroutine z3_tens_normalize_k_int(tens)
		complex(dp),	allocatable,	intent(inout)	::	tens(:,:,:)
		integer							:: 	n_k
		!
		if(allocated(tens))	then
			n_k		=	mp_grid(1) * mp_grid(2) * mp_grid(3)
			if(n_k > 0	)		tens		=	tens		 /	abs(	unit_vol	* real(n_k,dp)	)
		end if
		!
		return
	end subroutine
!------
	subroutine z4_tens_normalize_k_int(tens)
		complex(dp),	allocatable,	intent(inout)	::	tens(:,:,:,:)
		integer							:: 	n_k
		!
		if(allocated(tens))	then
			n_k		=	mp_grid(1) * mp_grid(2) * mp_grid(3)
			if(n_k > 0	)		tens		=	tens		 /	abs(	unit_vol	* real(n_k,dp)	)
		end if
		!
		return
	end subroutine
!------
subroutine z5_tens_normalize_k_int(tens)
	complex(dp),	allocatable,	intent(inout)	::	tens(:,:,:,:,:)
	integer							:: 	n_k
	!
	if(allocated(tens))	then
		n_k		=	mp_grid(1) * mp_grid(2) * mp_grid(3)
		if(n_k > 0	)		tens		=	tens		 /	abs(	unit_vol	* real(n_k,dp)	)
	end if
	!
	return
end subroutine

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

	subroutine kspace_allocator(H_tb, r_tb, en_k, V_ka, A_ka, Om_kab)
		!	allocate the k-space arrays, depending on what is allocated in real space
		complex(dp),	allocatable, intent(inout)	::		H_tb(:,:,:), r_tb(:,:,:,:),					&
															V_ka(:,:,:), A_ka(:,:,:), Om_kab(:,:,:,:)
		real(dp),		allocatable, intent(inout)	::		en_k(:)
		!
		!allocate k-space
		allocate(	en_k(						size(H_tb,2)	)	)
		allocate(	V_ka(	3,	size(H_tb,1),	size(H_tb,2)	)	)
		!
		if(	allocated(r_tb)	)	then
			allocate(	A_ka(	  3,		size(r_tb,2),	size(r_tb,3)	)	)
			allocate(	Om_kab(	3,	3,		size(r_tb,2),	size(r_tb,3)	)	)
			write(*,'(a,i7.7,a)')		"[#",mpi_id,"; kspace_allocator]: allocated position operator (will use Berry connenction & curv)"
		end if
		!
		return
	end subroutine

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

	subroutine set_mp_grid(input_grid)
		!	set the monkhorst pack grid
		integer,		intent(in)		::	input_grid(3)
		mp_grid	=	input_grid
		return
	end subroutine

	function get_mp_grid() result(this_mp_grid)
		integer			::	this_mp_grid(3)
		this_mp_grid	=	mp_grid
		return
	end function

	subroutine set_recip_latt(a_latt)
		integer			::	i, j
		!
		!	see eq.(2)		PRB, 13, 5188 (1976)
		!
		real(dp), intent(in)	::	a_latt(3,3)
		real(dp)				::	a1(3), a2(3), a3(3),	&
									b1(3), b2(3), b3(3)
		!
		recip_latt_set	=	.false.
		!
		a1(:)			=	a_latt(:,1)
		a2(:)			=	a_latt(:,2)
		a3(:)			=	a_latt(:,3)
		!get Unit cell volume
		unit_vol		=	dot_product(	crossP( a1(:) , a2(:)	)		,	a3(:)	)
		!
		!setup reciprocal lattice vectors
		b1(:)	= 2.0_dp * pi_dp * crossP( a2(:) , a3(:) ) / unit_vol
		b2(:)	= 2.0_dp * pi_dp * crossP( a3(:) , a1(:) ) / unit_vol
		b3(:)	= 2.0_dp * pi_dp * crossP( a1(:) , a2(:) ) / unit_vol
		!
		! BZ volume
		bz_vol	=	dot_product(		crossP( b1(:), b2(:))	, b3(:)		)
		!
		!	CPY TO TARGET
		recip_latt(:,1)	=	b1(:)
		recip_latt(:,2)	=	b2(:)
		recip_latt(:,3)	=	b3(:)
		recip_latt_set	=	.true.
		! -----
		!
		!	DEBUG
		do i = 1, 3
			if( 	abs(dot_product(recip_latt(i,:),a_latt(i,:))-2.0_dp * pi_dp)		> 1e-3_dp	) &
				write(*,'(a,i7.7,a,i1,a,i1,a,f8.4,a)')	"[#",mpi_id,&
							"set_recip_latt]:	WARNING b",i,".a",i," =",dot_product(recip_latt(i,:),a_latt(i,:)),'/= 2pi'
			!
			!
			do j = 1, 3
				if(i==j) cycle
				if( 	abs(dot_product(recip_latt(i,:),a_latt(j,:)))		> 1e-3_dp	) &
					write(*,'(a,i7.7,a,i1,a,i1,a,f8.4,a)')	"[",mpi_id,&
							"set_recip_latt]:	WARNING b",i,".a",j," =",dot_product(recip_latt(i,:),a_latt(j,:)),'/= 0'
			end do
			!
			!
		end do
		!
		if(mpi_id	==	0	)	&
			call print_recip_latt()
		!
		return
	end subroutine

	subroutine print_recip_latt()
		if(mpi_id	==	0	)	&
			write(*,*)	"reciprocal lattice:"
			write(*,*)	recip_latt

		return
	end subroutine

	function get_recip_latt() result( this_recip_latt )
		real(dp)		::	this_recip_latt(3,3)
		this_recip_latt	= recip_latt
		return
	end function

	function get_bz_vol() result(this_bz_vol)
		real(dp)		::	this_bz_vol
		this_bz_vol=bz_vol
		return
	end function

	integer pure function get_kpt_idx(qix, qiy, qiz)
		integer,	intent(in)	::	qix, qiy, qiz
		!
		!	use start at 0 convention and ad 1 to switch to array starts at 1 convention
		get_kpt_idx	=	1	+	(qix-1) + mp_grid(2)	* ( (qiy-1) + mp_grid(3) * (qiz-1)	)
		!
		return
	end function

	function get_rel_kpt(qi_idx, qix,qiy,qiz) result(kpt)
		integer,	intent(in)	::	qi_idx, qix, qiy, qiz
		real(dp),	allocatable	::	kpt(:)
		!
		if(check_kpt_idx(qi_idx, qix,qiy,qiz))	then
			allocate(kpt(3))
			!
			if( mp_grid(1) > 0 .and. mp_grid(2) > 0 .and. mp_grid(3) > 0 ) then
				!	mp mesh
				kpt(1)	=	(	 2.0_dp*real(qix,dp)	- real(mp_grid(1),dp) - 1.0_dp		) 	/ 	( 2.0_dp*real(mp_grid(1),dp) )
				kpt(2)	=	(	 2.0_dp*real(qiy,dp)	- real(mp_grid(2),dp) - 1.0_dp		) 	/ 	( 2.0_dp*real(mp_grid(2),dp) )
				kpt(3)	=	(	 2.0_dp*real(qiz,dp)	- real(mp_grid(3),dp) - 1.0_dp		) 	/ 	( 2.0_dp*real(mp_grid(3),dp) )
				!
				!	Wx mesh:
				!kpt(1)	=	real(qix-1,dp) / real(mp_grid(1))
				!kpt(2)	=	real(qiy-1,dp) / real(mp_grid(2))
				!kpt(3)	=	real(qiz-1,dp) / real(mp_grid(3))
			end if
		else
			stop "[get_rel_kpt]: ERROR got illegal kpt idx"
		end if
		!
		!
		return
	end function

	function get_cart_kpt(a_latt, kpt) result(kpt_cart)
		integer			::	j
		!
		!	use the a_latt instead of recip_latt
		!
		real(dp),		intent(in)	::	a_latt(3,3), kpt(3)
		real(dp)					::	kpt_cart(3)
		!
		if(	recip_latt_set) then
			kpt_cart	=	matmul(	recip_latt, 	kpt	)
			!
		else
			write(*,*)	"[kspace/get_cart_kpt]:	ERROR get_cart_kpt was called without lattice beeing set"
			STOP
		end if
		!
		!
		return
	end function

	logical function check_kpt_idx(	qi_idx	,qix,qiy,qiz)
		integer,	intent(in)	::	qi_idx, qix, qiy, qiz
		!
		!	debug check
		if	(					qi_idx 		< 				0 						&
					.or.		qi_idx		> 	mp_grid(1)*mp_grid(2)*mp_grid(3)	) 	then
			!
			stop "[check_kpt_idx]: ERROR - idx out of bounds"
		end if
		!
		check_kpt_idx	=	(	qi_idx	-	get_kpt_idx(qix,qiy,qiz) )	==	0
		!
		return
	end function

end module k_space