! Program to demonstrate the use of arrays

program fib_array
    implicit none

    integer(KIND=16), ALLOCATABLE, DIMENSION(:) :: fib_vals, c_vals
    integer, ALLOCATABLE, DIMENSION(:) :: nvals
    integer :: i,n

    print*, "Enter the number till which fibonacci sequence is required : "
    read '(i3)', n

    ! allocates n integers to the array at runtime
    ALLOCATE(fib_vals(n), c_vals(n), nvals(n))

    fib_vals(1) = 1
    fib_vals(2) = 1

    do i = 3,n
        fib_vals(i) = fib_vals(i-1) + fib_vals(i-2)
    end do

    OPEN(unit=1, file="fib_val.txt")
    15 format(i3, 5x, i25)

    do i = 1,n
        print 10, i, fib_vals(i)
        10 format("The fibonacci value", i3, " is", i15)
        WRITE(unit=1, fmt=15) i, fib_vals(i)
    end do

    CLOSE(unit=1)

    OPEN(unit=2, file="fib_val.txt")

    do i = 1,n
        read(unit=2, fmt=15) nvals(i), c_vals(i)
        print*, "i = ", i, " i-n = ", i - nvals(i), " fib - fib_check = ", &
            & fib_vals(i) - c_vals(i)
    end do

    ! deallocates the array
    DEALLOCATE(fib_vals, c_vals, nvals)
    CLOSE(unit=2)

end program fib_array


program P2
  implicit none
  integer :: i
  open(unit=20,file='walk1.dat')
  open(unit=21,file='walk2.dat')
  do i=1,100
    call walk1
    call walk2
  enddo
  close(20)
  close(21)
  call system("gnuplot plot.gnu")
  print *,"The distance random walk can reach should be propotional to the sqrt(steps). Plot 2-c.jpeg agrees with my conclusion."
  ! plot.gnu will generate 2-[a,b,c].jpeg, 2-[a,b].jpeg will only use first 500 lines in data files
end program P2

subroutine walk1
  ! this version will only walk to x+ and y+ directions
  implicit none
  real*8, external :: drand48
  integer :: n, x, y
  x=0
  y=0
  do n=1,500
    ! map rand to [-1, 1], positive value for heading to y direction; negative value for heading to x direction.
     if (2*drand48()-1.le.0) then
        x=x+1
     else
        y=y+1
     endif
     write (20,*),x,y,sqrt(x*x*1.0+y*y*1.0),sqrt(n*1.0),n
     ! output x,y,sqrt(R),sqrt(N),n to plot.dat for plotting
  enddo
end subroutine walk1

subroutine walk2
  ! this version will walk to x+,x-,y+,y- directions
  implicit none
  real*8, external :: drand48
  integer :: n, x, y
  x=0
  y=0
  do n=1,500
    ! map rand to [-1, 1], positive value for heading to y direction; negative value for heading to x direction.
     if (2*drand48()-1.le.0) then
        ! map rand to [-1, 1], positive value for heading to x+ direction; negative value for heading to x- direction.
        if (2*drand48()-1.le.0) then
          x=x-1
        else
          x=x+1
        endif
     else
        ! map rand to [-1, 1], positive value for heading to y+ direction; negative value for heading to y- direction.
        if (2*drand48()-1.le.0) then
          y=y-1
        else
          y=y+1
        endif
     endif
     write (21,*),x,y,sqrt(x*x*1.0+y*y*1.0),sqrt(n*1.0),n
     ! output x,y,sqrt(R),sqrt(N),n to plot.dat for plotting
  enddo
end subroutine walk2


module comm

use,intrinsic:: iso_fortran_env, only: stdout=>output_unit, stderr=>error_unit, wp=>real32, dp=>real64
implicit none
public

real(dp),parameter :: pi = 4._dp*atan(1._dp)
real(dp),parameter :: deg2rad = pi/180._dp
real(dp),parameter :: rad2deg = 180/pi

integer, parameter :: npt=500

logical :: debug=.false.

real :: tic,toc

character(512) :: data_path
integer :: lpath

contains

end module comm


!!!!!!!!!!!!!!!!!NOTE!!!!!!!!!!!!!!!!!!!!!!!!
!!!! O2- species 1;O - species 2;!!!!!!!!!!!!
!!!!Explicit Method!!!!!!!!!!!!!!!!!!!!!!!!!!

program main
implicit none

real(8),parameter :: Runiv=8.31434d0,M1=32d0,M2=16d0,TB1=1d0,TB2=3d0,Cf=2.75e16,eta=-1d0, &
                     theta=59500d0,Ti= 4150,rhoi=3.35e-4                                                              !intial,fixed values

real(8),parameter,dimension(7) :: A1=(/3.660960830d+00,6.56365523d-04,-1.41149485d-07, &                   ! O2 aboveT=1000K
                                      2.05797658d-11,-1.29913248d-15,-1.21597725d+03,3.41536184d+00/), &
                                  A2=(/2.54363697d+00,-2.73162486d-05,-4.19029520d-09, &                   ! O  aboveT=1000K
                                      4.95481845d-12,-4.79553694d-16,2.92260120d+04,4.92229457d+00/)
real(8),parameter,dimension(7) :: B1=(/3.78245636d+00,-2.99673415d-03,9.84730200d-06,  &
                                     -9.68129508d-09,3.24372836d-12,-1.06394356d+03,3.65767573d+00/), &    ! O2 below T=1000K
                                  B2=(/3.16826710d+00,-3.27931884d-03,6.64306396d-06,  &
                                     -6.12806624d-09,2.11265971d-12,2.91222592d+04,2.05193346d+00/)        ! O below T=1000K
real(8),dimension(7):: A,B,A1h,B1h,A2h,B2h

real(8) :: T,rho1,rho2,kf,hi,ei,e1,e2,engi,eng,eng1,eng2,h1,h2,d1dt,gp,gr,dg,keq,dt,deng,dengdT,time
integer :: nitermax,nmax,n,i
rho1=0d0
rho2=0d0
T=Ti
dt= 5e-9
nitermax = 1000
nmax = 100000000
time=0
! Cp/Runiv formula for curve fitting
! Cp/Runiv = a(1)+a(2)*T+a(3)*T**2+a(4)*T**3+a(5)*T**4+a(6)+a(7)
!!!! a = [A,B,C,D,E,F,G], fpr Enthalpy/Runiv calculation, divide by molecular weight for the constants

 A1h=A1/32;
 A2h=A2/16;
 B1h=B1/32;
 B2h=B2/16;

!!!!!!! intial condition
!!!h/R(molar)=Cp/Runiv = a(1)*T+a(2)*T**2/2+a(3)*T**3/3+a(4)*T**4/4+a(5)*T**5/5+a(6)
!!!h/R(mass) we divided coefficients  above by Molecular weight
rho1=rhoi
rho2=rhoi-rho1
hi =  (A1h(1)*Ti+A1h(2)*(Ti**2)/2 + A1h(3)*(Ti**3)/3+A1h(4)*(Ti**4)/4+ &
A1h(5)*(Ti**5)/5+A1h(6))

ei = hi- Ti/M1
engi=rhoi*ei

!!!!!!!!!!!
!!!!!!!check if the temperature is above or below 1000K!!!!!!
!!!!!!!!!!!

open (unit = 2, file = "data.dat")
!!!Loop starts
!!!!!!!!!
!!!!!!!!!
do i=1,nmax
if (T<=1000) then
A=B1h
B=B2h
elseif (T>1000) then
A=A1h
B=A2h
endif

!!!!!!keq,kf computation

gr= (A(1)*(1-log(T))*T-A(7)*T+A(2)*T**2/2+A(3)*T**3/6+A(4)*T**4/12+ &
          A(5)*T**5/20+A(6))
gp = (B(1)*(1-log(T))*T-B(7)*T+B(2)*T**2/2+B(3)*T**3/6+B(4)*T**4/12+ &
          B(5)*T**5/20+B(6))*2

dg = gp-gr

keq = exp(-dg/T)
kf = (2.75d16/T)* exp(-59500d0/T)
!!!!!!!!!!!!!

d1dt= -1*M1*(kf)*((rho1/M1)- rho2*rho2/(M2*M2*keq)*(TB1*rho1/M1 + TB2*rho2/M2))

rho1 = rho1 +dt*d1dt
rho2=rhoi-rho1

!!!!!!!!!!!!!
!!Net energy change = 0
!!!!!!!!!!!!!!

do n = 1,nitermax

if (T<=1000) then
  A=B1h
  B=B2h
elseif (T>1000) then
  A=A1h
  B=A2h
endif

h1 =  (A(1)*T+A(2)*(T**2)/2 + A(3)*(T**3)/3+A(4)*(T**4)/4+ &
       A(5)*(T**5)/5+A(6))

e1 = h1- T/M1
eng1=rho1*e1

h2 =  (B(1)*T+B(2)*(T**2)/2 + B(3)*(T**3)/3+B(4)*(T**4)/4+ &
       B(5)*(T**5)/5+B(6))

e2 = h2- T/M2
eng2=rho2*e2

eng=eng1+eng2
deng=eng-engi

!!!!!!!!! Update T to make deng =0

dengdT = (rho1*( (A(1)+A(2)*(T) + A(3)*(T**2)+A(4)*(T**3)+ &
       A(5)*(T**4)) - 1/M1) + rho2*(B(1)+B(2)*(T)/2 + B(3)*(T**2)+B(4)*(T**3)+ &
       B(5)*(T**4) - 1/M2))                                          !!!!!!doubtful

T = T - deng/dengdT

print*, n,time,T
if (abs(deng/dengdt) < 10e-8) then

   exit

end if

end do

write(2,*) i,n,time,rho1/rhoi,rho2/rhoi,T

if ((dg > 0)) then
   exit
end if
time = time +dt
end do
!!!!!!!!!!!!
!!!!!!!!!!
print *, T,deng,d1dt,keq,kf,dg

close(2)

end


*DECK DGAMIC
      DOUBLE PRECISION FUNCTION DGAMIC (A, X)
C***BEGIN PROLOGUE  DGAMIC
C***PURPOSE  Calculate the complementary incomplete Gamma function.
C***LIBRARY   SLATEC (FNLIB)
C***CATEGORY  C7E
C***TYPE      DOUBLE PRECISION (GAMIC-S, DGAMIC-D)
C***KEYWORDS  COMPLEMENTARY INCOMPLETE GAMMA FUNCTION, FNLIB,
C             SPECIAL FUNCTIONS
C***AUTHOR  Fullerton, W., (LANL)
C***DESCRIPTION
C
C   Evaluate the complementary incomplete Gamma function
C
C   DGAMIC = integral from X to infinity of EXP(-T) * T**(A-1.)  .
C
C   DGAMIC is evaluated for arbitrary real values of A and for non-
C   negative values of X (even though DGAMIC is defined for X .LT.
C   0.0), except that for X = 0 and A .LE. 0.0, DGAMIC is undefined.
C
C   DGAMIC, A, and X are DOUBLE PRECISION.
C
C   A slight deterioration of 2 or 3 digits accuracy will occur when
C   DGAMIC is very large or very small in absolute value, because log-
C   arithmic variables are used.  Also, if the parameter A is very close
C   to a negative INTEGER (but not a negative integer), there is a loss
C   of accuracy, which is reported if the result is less than half
C   machine precision.
C
C***REFERENCES  W. Gautschi, A computational procedure for incomplete
C                 gamma functions, ACM Transactions on Mathematical
C                 Software 5, 4 (December 1979), pp. 466-481.
C               W. Gautschi, Incomplete gamma functions, Algorithm 542,
C                 ACM Transactions on Mathematical Software 5, 4
C                 (December 1979), pp. 482-489.
C***ROUTINES CALLED  D1MACH, D9GMIC, D9GMIT, D9LGIC, D9LGIT, DLGAMS,
C                    DLNGAM, XERCLR, XERMSG
C***REVISION HISTORY  (YYMMDD)
C   770701  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   890531  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900315  CALLs to XERROR changed to CALLs to XERMSG.  (THJ)
C   920528  DESCRIPTION and REFERENCES sections revised.  (WRB)
C***END PROLOGUE  DGAMIC
      DOUBLE PRECISION A, X, AEPS, AINTA, ALGAP1, ALNEPS, ALNGS, ALX,
     1  BOT, E, EPS, GSTAR, H, SGA, SGNG, SGNGAM, SGNGS, SQEPS, T,
     2  D1MACH, DLNGAM, D9GMIC, D9GMIT, D9LGIC, D9LGIT
      LOGICAL FIRST
      SAVE EPS, SQEPS, ALNEPS, BOT, FIRST
      DATA FIRST /.TRUE./
C***FIRST EXECUTABLE STATEMENT  DGAMIC
      IF (FIRST) THEN
         EPS = 0.5D0*D1MACH(3)
         SQEPS = SQRT(D1MACH(4))
         ALNEPS = -LOG (D1MACH(3))
         BOT = LOG (D1MACH(1))
      ENDIF
      FIRST = .FALSE.
C
      IF (X .LT. 0.D0) CALL XERMSG ('SLATEC', 'DGAMIC', 'X IS NEGATIVE'
     +   , 2, 2)
C
      IF (X.GT.0.D0) GO TO 20
      IF (A .LE. 0.D0) CALL XERMSG ('SLATEC', 'DGAMIC',
     +   'X = 0 AND A LE 0 SO DGAMIC IS UNDEFINED', 3, 2)
C
      DGAMIC = EXP (DLNGAM(A+1.D0) - LOG(A))
      RETURN
C
 20   ALX = LOG (X)
      SGA = 1.0D0
      IF (A.NE.0.D0) SGA = SIGN (1.0D0, A)
      AINTA = AINT (A + 0.5D0*SGA)
      AEPS = A - AINTA
C
      IZERO = 0
      IF (X.GE.1.0D0) GO TO 40
C
      IF (A.GT.0.5D0 .OR. ABS(AEPS).GT.0.001D0) GO TO 30
      E = 2.0D0
      IF (-AINTA.GT.1.D0) E = 2.D0*(-AINTA+2.D0)/(AINTA*AINTA-1.0D0)
      E = E - ALX * X**(-0.001D0)
      IF (E*ABS(AEPS).GT.EPS) GO TO 30
C
      DGAMIC = D9GMIC (A, X, ALX)
      RETURN
C
 30   CALL DLGAMS (A+1.0D0, ALGAP1, SGNGAM)
      GSTAR = D9GMIT (A, X, ALGAP1, SGNGAM, ALX)
      IF (GSTAR.EQ.0.D0) IZERO = 1
      IF (GSTAR.NE.0.D0) ALNGS = LOG (ABS(GSTAR))
      IF (GSTAR.NE.0.D0) SGNGS = SIGN (1.0D0, GSTAR)
      GO TO 50
C
 40   IF (A.LT.X) DGAMIC = EXP (D9LGIC(A, X, ALX))
      IF (A.LT.X) RETURN
C
      SGNGAM = 1.0D0
      ALGAP1 = DLNGAM (A+1.0D0)
      SGNGS = 1.0D0
      ALNGS = D9LGIT (A, X, ALGAP1)
C
C EVALUATION OF DGAMIC(A,X) IN TERMS OF TRICOMI-S INCOMPLETE GAMMA FN.
C
 50   H = 1.D0
      IF (IZERO.EQ.1) GO TO 60
C
      T = A*ALX + ALNGS
      IF (T.GT.ALNEPS) GO TO 70
      IF (T.GT.(-ALNEPS)) H = 1.0D0 - SGNGS*EXP(T)
C
      IF (ABS(H).LT.SQEPS) CALL XERCLR
      IF (ABS(H) .LT. SQEPS) CALL XERMSG ('SLATEC', 'DGAMIC',
     +   'RESULT LT HALF PRECISION', 1, 1)
C
 60   SGNG = SIGN (1.0D0, H) * SGA * SGNGAM
      T = LOG(ABS(H)) + ALGAP1 - LOG(ABS(A))
      IF (T.LT.BOT) CALL XERCLR
      DGAMIC = SGNG * EXP(T)
      RETURN
C
 70   SGNG = -SGNGS * SGA * SGNGAM
      T = T + ALGAP1 - LOG(ABS(A))
      IF (T.LT.BOT) CALL XERCLR
      DGAMIC = SGNG * EXP(T)
      RETURN
C
      END


      subroutine dualwind_yesz
     1           (u,v,x,y,ht,vr1,vr2,x1,y1,x2,y2,ht1,ht2,dz,ier)
c***********************************************************************
c description      : To derive Dual-Doppler wind from radar radial
c                    velocity and reflectivity factor at constant height.
c
c I/O parameters   :
c  I/O/W   name,            type,      description
c    O     u,v              real       the horizontal wind component of x,y coordinate
c                                      in unit of m/s.
c    I     x,y              real       the (x,y) coordinate at the wind position.
c                                      in unit of km.
c    I     ht               real       the height at the wind position
c                                      in unit of km.
c    I     vr1,vr2          real       the radial velocity observed by radar1 and
c                                      radar2 in unit of m/s.
c    I     x1,y1            real       the x,y coordinate at radar 1 in unit of km.
c    I     x2,y2            real       the x,y coordinate at radar 2 in unit of km.
c    I     ht1,ht2          real       the height of radar1 and radar2 in unit of km.
c    I     dz               real       the reflectivity factor at the wind position
c                                      in unit of dBZ.
c    O     ier              integer    =0, success message.
c                                      =1, cannot derive horizontal wind.
c                                      =2, (ht1 or ht2) > ht.
c
c Date :
c   Mar. 9, 2004 (S.-M. Deng)
c***********************************************************************

      det=(x-x1)*(y-y2)-(x-x2)*(y-y1)
      if( abs(det).lt.2. )then
          ier=1
          return
      endif
      ier=0
      d1=sqrt( (x-x1)**2 + (y-y1)**2 )
      d2=sqrt( (x-x2)**2 + (y-y2)**2 )
      if( (ht1.gt.ht).or.(ht2.gt.ht) )then
          ier=2
          return
      endif
      cos1=d1/sqrt( d1*d1 + (ht-ht1)**2 )
      cos2=d2/sqrt( d2*d2 + (ht-ht2)**2 )
      tan1=(ht-ht1)/d1
      tan2=(ht-ht2)/d2
      z_scale=9.6
      factor=exp(0.4*ht/z_scale)
      vt=4.32*10.**(0.0052*dz)*factor
      vh1=vr1/cos1+vt*tan1
      vh2=vr2/cos2+vt*tan2

      u=(vh1*d1*(y-y2)-vh2*d2*(y-y1))/det
      v=(vh2*d2*(x-x1)-vh1*d1*(x-x2))/det

      return
      end


!  *********************************************************************
!  *                                                                   *
!  *                        subroutine side2d                          *
!  *                                                                   *
!  *********************************************************************
!  Mixed Precision Version 2.31
!  Written by Gordon A. Fenton, TUNS, Aug. 26, 1992
!  Latest Update: Jun 9, 1999
!
!  PURPOSE  creates the parameter matrices required for the side cell
!           subdivisions of LAS2G.
!
!  Requires:
!   1) from libGAFsim:	DSIFA, DSISL, DCHOL2, DAXPY, DSWAP, DDOT, IDAMAX
!
!    n    is the rank of [CC][CC^T]. It can be either n = 3 for the 2-D case or
!         n = 7 for the 3-D case.
!    ms   is the mapping from the global covariance matrix `R' into the local
!         `side' covariance matrix
!
!  REVISION HISTORY:
!  2.31	replaced dummy dimensions with a (*) for GNU's compiler (Jun 9/99)
!-----------------------------------------------------------------------------
      subroutine side2d(R,ir,B,ib,S,is,CS,ic,n,AS,ms,iout,tol)
      real CS(ic,*), AS(6,n,*)
      real*8 R(ir,*), B(ib,*), S(is,*)
      real*8 RS(6,6), DA(6), BB(7,7)
      integer ms(6,*), indx(6)

   1  format(a,a,a)
   2  format(a,e13.4)
!							for each side...
      do 70 ns = 1, 4
!							extract R
         do 10 j = 1, 6
            do 10 i = 1, j
               RS(i,j) = R(ms(i,ns), ms(j,ns))
  10     continue
!							factorize R
         call dsifa( RS, 6, 6, indx, ierr )
         if( ierr .ne. 0 ) then
            write(iout,1)'Error: unable to factorize side covariance matrix in SIDE2D.'
            stop
         endif
!							make a copy of S
         do 50 j = 1, n
            do 20 i = 1, 6
               DA(i) = S(ms(i,ns),j)
  20        continue
!							and solve for A
            call dsisl( RS, 6, 6, indx, DA )
!							store in real*4
            do 30 i = 1, 6
               AS(i,j,ns) = DA(i)
  30        continue
!							update B
            do 40 i = 1, j
               BB(i,j) = B(i,j) - S(ms(1,ns),i)*DA(1) - S(ms(2,ns),i)*DA(2) &
			            - S(ms(3,ns),i)*DA(3) - S(ms(4,ns),i)*DA(4)         &
						- S(ms(5,ns),i)*DA(5) - S(ms(6,ns),i)*DA(6)
  40        continue
  50     continue
!						Cholesky Decomposition
         call dchol2( BB, 7, n, rerr )
         if( rerr .gt. tol ) then
            write(iout,1)'Side2d: Cholesky decomposition of side covariance matrix BB'
            write(iout,2)'        has maximum relative error of ',rerr
         endif
!						store in real*4
         ii = 0
         do 60 j = 1, n
         do 60 i = 1, j
            ii = ii + 1
            CS(ii,ns) = BB(i,j)
  60     continue
  70  continue

      return
      end


Real Function pp1(srt)
  Save
  pmass = 0.9383
  pp1 = 0.
  plab2 = ((srt**2-2.*pmass**2)/(2.*pmass))**2 - pmass**2
  If (plab2<=0) Return
  plab = sqrt(plab2)
  pmin = 0.968
  pmax = 2080
  If ((plab<pmin) .Or. (plab>pmax)) Then
     pp1 = 0.
     Return
  End If
  a = 30.9
  b = -28.9
  c = 0.192
  d = -0.835
  an = -2.46
  pp1 = a + b*(plab**an) + c*(alog(plab))**2
  If (pp1<=0) pp1 = 0.0
  Return
End Function pp1


!-----------------------------------------------------------------------------
!
! CCA
!
! This program (Contour Curvature Analysis) evaluates the curvature of each
! cell; and  assign the dmID.
!
!-----------------------------------------------------------------------------

subroutine cca()

use mpar
use mbbio

implicit none

integer(kind=RSP) i,j,ii,jj,i_basin,ii_basin,dmID
real(kind=REP) quota_cij,zx,zy,zxx,zyy,zxy,p,q,Kc
real(kind=RSP) Kp
real(kind=REP) quota_ciijj,dx2

real(kind=REP),allocatable :: mesh(:,:)
real(kind=REP),allocatable :: curv(:,:)

! read <parfile>

call rparfile('hap.in')

allocate(mesh(3,3))
allocate(curv(N,M))

write(6,*) 'contour curvature threshold value = ',CC_threshold
! write(6,*) 'delta_x = ', delta_x

dx2=delta_x*delta_x

do j=M,1,-1
   do i=1,N
      curv(i,j)=-9999.0
      dmID=2 ! default drainage direction method (D8-LTD)
      i_basin=(i-1)*M+j
      if (dtm_index_pr(i_basin).eq.0) cycle
      quota_cij=dtm_quota(i_basin)
      do ii=i-1,i+1
         do jj=j-1,j+1
            if (ii.eq.0.or.ii.eq.N+1) go to 100
            if (jj.eq.0.or.jj.eq.M+1) go to 100
            ii_basin=(ii-1)*M+jj
            if (dtm_index_pr(ii_basin).eq.0) go to 100
            quota_ciijj = dtm_quota(ii_basin)
            if (quota_ciijj.eq.0.0_REP) quota_ciijj=-9999.0_REP
            mesh(ii-i+2,jj-j+2)=quota_ciijj
            ! WRITE(6,*) 'mesh (',ii-i+2,',',jj-j+2,') =',mesh(ii-i+2,jj-j+2)
         end do
      end do
      zx=(mesh(2,3)-mesh(2,1))/(2*delta_x)
      zy=(mesh(1,2)-mesh(3,2))/(2*delta_x)
      zxx=(mesh(2,3)-2*mesh(2,2)+mesh(2,1))/dx2
      zyy=(mesh(1,2)-2*mesh(2,2)+mesh(3,2))/dx2
      zxy=(-mesh(1,1)+mesh(1,3)+mesh(3,1)-mesh(3,3))/(4*dx2)
      if (abs(zx).gt.epsilon(zx).or.abs(zy).gt.epsilon(zy)) then
         p=zx*zx+zy*zy
         q=p+1.0
      else
         p=1.0E-09
         q=p+1.0E+00
      end if
      ! WRITE(6,*) 'p =',p
      Kc=(zxx*zy*zy-2.0*zxy*zx*zy+zyy*zx*zx)/p**1.5
      curv(i,j)=Kc
      if (abs(Kc).lt.epsilon(Kc)) Kc=0.0D+00
      Kp=(zxx*zx*zx+2.0*zxy*zx*zy+zyy*zy*zy)/(p*q**1.5)
      if (Kc.lt.CC_threshold) then ! diverging flow -> D_inf
          dmID=1
      else ! converging flow -> D8_LTD
          dmID=2
      end if
 100  continue
      call set_dmID(i_basin,dmID)
      call set_DN(i_basin,Kp)
   end do
end do

open(77,file='dtm_Kc.txt',status='unknown')
write(77,'(a,1x,i5)') 'north:',0
write(77,'(a,1x,f20.8)') 'south:',0.0
write(77,'(a,2x,i5)') 'east:',0
write(77,'(a,2x,f20.8)') 'west:',0.0
write(77,'(a,2x,i5)') 'rows:',M
write(77,'(a,2x,i5)') 'cols:',N
do j=M,1,-1
   write(77,*) (curv(i,j),i=1,N)
end do
close(77)

return
end subroutine cca


!*************************************************
! Laplace (bad) OpenACC Fortran Version
!
! Temperature is initially 0.0
! Boundaries are as follows:
!
!      0         T         0
!   0  +-------------------+  0
!      |                   |
!      |                   |
!      |                   |
!   T  |                   |  T
!      |                   |
!      |                   |
!      |                   |
!   0  +-------------------+ 100
!      0         T        100
!
!  John Urbanic, PSC 2014
!
!*************************************************
program serial
      implicit none

      !Size of plate
      integer, parameter             :: columns=1000
      integer, parameter             :: rows=1000
      double precision, parameter    :: max_temp_error=0.01

      integer                        :: i, j, max_iterations, iteration=1
      double precision               :: dt=100.0
      real                           :: start_time, stop_time

      double precision, dimension(0:rows+1,0:columns+1) :: temperature, temperature_last

      print*, 'Maximum iterations [100-4000]?'
      read*,   max_iterations

      call cpu_time(start_time)      !Fortran timer

      call initialize(temperature_last)

      !do until error is minimal or until maximum steps
      do while ( dt > max_temp_error .and. iteration <= max_iterations)

         !$acc kernels
         do j=1,columns
            do i=1,rows
               temperature(i,j)=0.25*(temperature_last(i+1,j)+temperature_last(i-1,j)+ &
                                      temperature_last(i,j+1)+temperature_last(i,j-1) )
            enddo
         enddo
         !$acc end kernels

         dt=0.0

         !copy grid to old grid for next iteration and find max change
         !$acc kernels
         do j=1,columns
            do i=1,rows
               dt = max( abs(temperature(i,j) - temperature_last(i,j)), dt )
               temperature_last(i,j) = temperature(i,j)
            enddo
         enddo
         !$acc end kernels

         !periodically print test values
         if( mod(iteration,100).eq.0 ) then
            call track_progress(temperature, iteration)
         endif

         iteration = iteration+1

      enddo

      call cpu_time(stop_time)

      print*, 'Max error at iteration ', iteration-1, ' was ',dt
      print*, 'Total time was ',stop_time-start_time, ' seconds.'

end program serial

! initialize plate and boundery conditions
! temp_last is used to to start first iteration
subroutine initialize( temperature_last )
      implicit none

      integer, parameter             :: columns=1000
      integer, parameter             :: rows=1000
      integer                        :: i,j

      double precision, dimension(0:rows+1,0:columns+1) :: temperature_last

      temperature_last = 0.0

      !these boundary conditions never change throughout run

      !set left side to 0 and right to linear increase
      do i=0,rows+1
         temperature_last(i,0) = 0.0
         temperature_last(i,columns+1) = (100.0/rows) * i
      enddo

      !set top to 0 and bottom to linear increase
      do j=0,columns+1
         temperature_last(0,j) = 0.0
         temperature_last(rows+1,j) = ((100.0)/columns) * j
      enddo

end subroutine initialize

!print diagonal in bottom corner where most action is
subroutine track_progress(temperature, iteration)
      implicit none

      integer, parameter             :: columns=1000
      integer, parameter             :: rows=1000
      integer                        :: i,iteration

      double precision, dimension(0:rows+1,0:columns+1) :: temperature

      print *, '---------- Iteration number: ', iteration, ' ---------------'
      do i=5,0,-1
         write (*,'("("i4,",",i4,"):",f6.2,"  ")',advance='no') &
                   rows-i,columns-i,temperature(rows-i,columns-i)
      enddo
      print *
end subroutine track_progress


program main
    use LinearSolverClass
    implicit none

    integer(int32) :: i
    real(real64),allocatable :: coeff(:),fit_coeff(:)
    real(real64) :: true_answer(4)
    real(real64),allocatable :: training_data(:,:)
    real(real64) :: err
    type(IO_) :: f
    type(Random_) :: random

    ! create training data
    ! trial : h = 0.70, w = 20.0, A=2.0, phi = 0.0
    true_answer = [0.70d0, 12.0d0,1.0d0,  -1.570d0]
    call f%open("step_response.txt","w")
    do i=1,10000
        write(f%fh,*) dble(i-1)/10000.0d0,&
            sample_function(t=dble(i-1)/10000.0d0,params=true_answer)&
            +random%gauss(mu=0.0d0,sigma=0.0050d0)
    enddo
    call f%close()

    ! read training data
    training_data = zeros(10000,2)
    call f%open("step_response.txt")
    do i=1,size(training_data,1)
        read(f%fh,*) training_data(i,1:2)
    enddo
    call f%close()

    ! trial : theta_h = 0.50, w = 20.0, A=2.0, phi = 0.0
    coeff = [0.50d0, 20.0d0,2.0d0,0.0d0]

    !sample_function = A*exp(-h*w*t)*cos(w_*t - phi)
    call f%open("SGD_fit_initial.txt","w")
    do i=0,1000
        call f%write(dble(i)/1000.0d0, exp_function(t=dble(i)/1000.0d0,params=coeff ) )
    enddo
    call f%close()

    ! fitting by Robbin-Monro algorithm (SGD)
    do i_i=1,2000

        fit_coeff = fit(f=exp_function, training_data=training_data, params=coeff ,&
            eta=0.001d0,max_itr=10, error=err,use_ratio=0.00050d0,logfile="SGD.log")
        coeff = fit_coeff
        print *, 1.0d0/(1.0d0 + exp(- fit_coeff(1) ) ),fit_coeff(2:)
        !call f%open("SGD_fit"+zfill(i_i,4)+".txt","w")
        call f%open("SGD_fit.txt","w")
        do i=0,1000
            call f%write(dble(i)/1000.0d0, exp_function(t=dble(i)/1000.0d0,params=fit_coeff ) )
        enddo
        call f%close()

    enddo
    ! show result
    call f%open("training_data.txt","w")
    do i=1,size(training_data,1)
        call f%write(training_data(i,1), training_data(i,2) )
    enddo
    call f%close()

    print *, "--- check ---"

    print *, 1.0d0/(1.0d0 + exp(- fit_coeff(1) ) ),fit_coeff(2:)
    print *, true_answer(:)

contains

real(real64) function exp_function(t,params)
    real(real64),intent(in) :: t
    real(real64),intent(in) :: params(:)
    real(real64) :: A, h, w, phi, w_,theta_h
    theta_h   = params(1)
    h = 1.0d0/(1.0d0 + exp(- theta_h) )
    w   = params(2)
    A   = params(3)
    phi = params(4)

    w_  = w * sqrt(1-h*h)

    exp_function = A*exp(-h*w*t)*cos(w_*t - phi)

end function

end program main


! peano.f90
!
! Demo application that plots a Peano curve with ProCALL.
!
! Author:  Philipp Engel
! Licence: ISC
program main
    use, intrinsic :: iso_c_binding, only: c_null_char
    use :: procall
    implicit none
    integer :: key
    integer :: win

    call gopen(800, 800, win)
    call winname(win, 'Peano Curve' // c_null_char)

    call gsetbgcolor(win, 'black' // c_null_char)
    call newpencolor(win, 3)
    call gclr(win)

    call moveto(win, 0.0, 0.0)
    call peano(win, 0, 0, 1000, 0, 0)

    call ggetch(key)
    call gcloseall()
contains
    recursive subroutine peano(win, x, y, lg, i1, i2)
        integer, intent(in) :: win
        integer, intent(in) :: x
        integer, intent(in) :: y
        integer, intent(in) :: lg
        integer, intent(in) :: i1
        integer, intent(in) :: i2
        integer             :: l

        if (lg == 1) then
            call lineto(win, real(3 * x), real(3 * y))
            return
        end if

        l = lg / 3

        call peano(win,        (2 * i1 * l) + x,        (2 * i1 * l) + y, l,     i1,     i2)
        call peano(win, ((i1 - i2 + 1) * l) + x,     ((i1 + i2) * l) + y, l,     i1, 1 - i2)
        call peano(win,                   l + x,                   l + y, l,     i1, 1 - i2)
        call peano(win,     ((i1 + i2) * l) + x, ((i1 - i2 + 1) * l) + y, l, 1 - i1, 1 - i2)
        call peano(win,        (2 * i2 * l) + x,  (2 * (1 - i2) * l) + y, l,     i1,     i2)
        call peano(win, ((1 + i2 - i1) * l) + x, ((2 - i1 - i2) * l) + y, l,     i1,     i2)
        call peano(win,  (2 * (1 - i1) * l) + x,  (2 * (1 - i1) * l) + y, l,     i1,     i2)
        call peano(win, ((2 - i1 - i2) * l) + x, ((1 + i2 - i1) * l) + y, l, 1 - i1,     i2)
        call peano(win,  (2 * (1 - i2) * l) + x,        (2 * i2 * l) + y, l, 1 - i1,     i2)
    end subroutine peano
end program main


! use OpenMP to parallelise matmul
module m_matmul_omp

   use iso_c_binding
   use omp_lib

   implicit none

   private
   public :: matmul_omp

   interface matmul_omp
      module procedure double_matmul_omp
      module procedure float_matmul_omp
      module procedure double_matvecmul_omp
      module procedure float_matvecmul_omp
      module procedure double_vecmatmul_omp
      module procedure float_vecmatmul_omp
   end interface

   contains

   ! matrix-matrix multiplication: C=AB
   function double_matmul_omp(a,b) result (c)

      ! argument declarations
      real(kind=c_double),intent(in) :: a(:,:)        ! matrix A
      real(kind=c_double),intent(in) :: b(:,:)        ! matrix B

      ! result declaration
      real(kind=c_double) :: c(size(a,1),size(b,2))   ! matrix C=AB

      ! variable declarations
      integer(kind=c_int) :: i_min                    ! lower bound
      integer(kind=c_int) :: i_max                    ! upper bound
      integer(kind=c_int) :: n_thread                 ! number of omp threads available
      integer(kind=c_int) :: thread_id                ! thread id
      integer(kind=c_int) :: i_chunk                  ! number of elements per chunk

      n_thread=min(omp_get_num_procs(),size(c,2))

      ! set chunk size
      i_chunk=ceiling(real(size(c,2))/real(n_thread))

      ! open a group of threads
      !$omp parallel num_threads(n_thread)&
      !$omp& default(private) shared(a,b,c,i_chunk)

         ! get thread ID
         thread_id=omp_get_thread_num()

         ! set array indicies
         i_min=thread_id*i_chunk+1
         i_max=min((thread_id+1)*i_chunk,size(c,2))

         ! perform matrix multiplication
         c(:,i_min:i_max)=&
            &matmul(a,b(:,i_min:i_max))

      !$omp end parallel

      return

   end function

   ! matrix-matrix multiplication: C=AB
   function float_matmul_omp(a,b) result (c)

      ! argument declarations
      real(kind=c_float),intent(in) :: a(:,:)         ! matrix A
      real(kind=c_float),intent(in) :: b(:,:)         ! matrix B

      ! result declaration
      real(kind=c_float) :: c(size(a,1),size(b,2))    ! matrix C=AB

      ! variable declarations
      integer(kind=c_int) :: i_min                    ! lower bound
      integer(kind=c_int) :: i_max                    ! upper bound
      integer(kind=c_int) :: n_thread                 ! number of omp threads available
      integer(kind=c_int) :: thread_id                ! thread id
      integer(kind=c_int) :: i_chunk                  ! number of elements per chunk

      n_thread=min(omp_get_num_procs(),size(c,2))

      ! set chunk size
      i_chunk=ceiling(real(size(c,2))/real(n_thread))

      ! open a group of threads
      !$omp parallel num_threads(n_thread)&
      !$omp& default(private) shared(a,b,c,i_chunk)

         ! get thread ID
         thread_id=omp_get_thread_num()

         ! set array indicies
         i_min=thread_id*i_chunk+1
         i_max=min((thread_id+1)*i_chunk,size(c,2))

         ! perform matrix multiplication
         c(:,i_min:i_max)=&
            &matmul(a,b(:,i_min:i_max))

      !$omp end parallel

      return

   end function

   ! matrix-vector multiplication: y=Ax
   function double_matvecmul_omp(a,x) result (y)

      ! argument declarations
      real(kind=c_double),intent(in) :: a(:,:)        ! matrix A
      real(kind=c_double),intent(in) :: x(:)          ! column vector x

      ! result declaration
      real(kind=c_double) :: y(size(a,1))             ! column vector y=Ax

      ! variable declarations
      integer(kind=c_int) :: i_min                    ! lower bound
      integer(kind=c_int) :: i_max                    ! upper bound
      integer(kind=c_int) :: n_thread                 ! number of omp threads available
      integer(kind=c_int) :: thread_id                ! thread id
      integer(kind=c_int) :: i_chunk                  ! number of elements per chunk

      n_thread=min(omp_get_num_procs(),size(y))

      ! set chunk size
      i_chunk=ceiling(real(size(y))/real(n_thread))

      ! open a group of threads
      !$omp parallel num_threads(n_thread)&
      !$omp& default(private) shared(a,x,y,i_chunk)

         ! get thread ID
         thread_id=omp_get_thread_num()

         i_min=thread_id*i_chunk+1
         i_max=min((thread_id+1)*i_chunk,size(y))

         ! perform matrix multiplication
         y(i_min:i_max)=matmul(a(i_min:i_max,:),x)

      !$omp end parallel

      return

   end function

   ! matrix-vector multiplication: y=Ax
   function float_matvecmul_omp(a,x) result (y)

      ! argument declarations
      real(kind=c_float),intent(in) :: a(:,:)         ! matrix A
      real(kind=c_float),intent(in) :: x(:)           ! column vector x

      ! result declaration
      real(kind=c_float) :: y(size(a,1))              ! column vector y=Ax

      ! variable declarations
      integer(kind=c_int) :: i_min                    ! lower bound
      integer(kind=c_int) :: i_max                    ! upper bound
      integer(kind=c_int) :: n_thread                 ! number of omp threads available
      integer(kind=c_int) :: thread_id                ! thread id
      integer(kind=c_int) :: i_chunk                  ! number of elements per chunk

      n_thread=min(omp_get_num_procs(),size(y))

      ! set chunk size
      i_chunk=ceiling(real(size(y))/real(n_thread))

      ! open a group of threads
      !$omp parallel num_threads(n_thread)&
      !$omp& default(private) shared(a,x,y,i_chunk)

         ! get thread ID
         thread_id=omp_get_thread_num()

         i_min=thread_id*i_chunk+1
         i_max=min((thread_id+1)*i_chunk,size(y))

         ! perform matrix multiplication
         y(i_min:i_max)=matmul(a(i_min:i_max,:),x)

      !$omp end parallel

      return

   end function

   ! vector-matrix multiplication: y=xB
   function double_vecmatmul_omp(x,b) result (y)

      ! argument declarations
      real(kind=c_double),intent(in) :: x(:)          ! row vector x
      real(kind=c_double),intent(in) :: b(:,:)        ! matrix B

      ! result declaration
      real(kind=c_double) :: y(size(b,2))             ! row vector y=xB

      ! variable declarations
      integer(kind=c_int) :: i_min                    ! lower bound
      integer(kind=c_int) :: i_max                    ! upper bound
      integer(kind=c_int) :: n_thread                 ! number of omp threads available
      integer(kind=c_int) :: thread_id                ! thread id
      integer(kind=c_int) :: i_chunk                  ! number of elements per chunk

      n_thread=min(omp_get_num_procs(),size(y))

      ! set chunk size
      i_chunk=ceiling(real(size(y))/real(n_thread))

      ! open a group of threads
      !$omp parallel num_threads(n_thread)&
      !$omp& default(private) shared(b,x,y,i_chunk)

         ! get thread ID
         thread_id=omp_get_thread_num()

         i_min=thread_id*i_chunk+1
         i_max=min((thread_id+1)*i_chunk,size(y))

         ! perform matrix multiplication
         y(i_min:i_max)=matmul(x,b(:,i_min:i_max))

      !$omp end parallel

      return

   end function

   ! vector-matrix multiplication: y=xB
   function float_vecmatmul_omp(x,b) result (y)

      ! argument declarations
      real(kind=c_float),intent(in) :: x(:)           ! row vector x
      real(kind=c_float),intent(in) :: b(:,:)         ! matrix B

      ! result declaration
      real(kind=c_float) :: y(size(b,2))              ! row vector y=xB

      ! variable declarations
      integer(kind=c_int) :: i_min                    ! lower bound
      integer(kind=c_int) :: i_max                    ! upper bound
      integer(kind=c_int) :: n_thread                 ! number of omp threads available
      integer(kind=c_int) :: thread_id                ! thread id
      integer(kind=c_int) :: i_chunk                  ! number of elements per chunk

      n_thread=min(omp_get_num_procs(),size(y))

      ! set chunk size
      i_chunk=ceiling(real(size(y))/real(n_thread))

      ! open a group of threads
      !$omp parallel num_threads(n_thread)&
      !$omp& default(private) shared(b,x,y,i_chunk)

         ! get thread ID
         thread_id=omp_get_thread_num()

         i_min=thread_id*i_chunk+1
         i_max=min((thread_id+1)*i_chunk,size(y))

         ! perform matrix multiplication
         y(i_min:i_max)=matmul(x,b(:,i_min:i_max))

      !$omp end parallel

      return

   end function

end module


      module MATOPER

c     the module contains matrix operations necessary for broyden algebra

      contains

      SUBROUTINE VMF(V2, V1, A, N)

!     MULTIPLICATION VECTOR = VECTOR * MATRIX (FULL) - V2 = V1 * A

      implicit real*8(a - h, o - z)

      DIMENSION V1(N), V2(N), A(N, N)

      DO 1 J = 1, N

         SUM = 0.0d0

         DO 2 I = 1, N

    2    SUM = SUM + V1(I) * A(I, J)

    1 V2(J) = SUM

      return

      end subroutine

      SUBROUTINE VSUB(A, B, N)

      implicit real*8(a - h, o - z)

      DIMENSION A(N), B(N)

      do I = 1, N; A(I) = A(I) - B(I); enddo

      RETURN

      END subroutine

      SUBROUTINE VMV(VSUM, V1, V2, N)
!     MULTIPLICATION RESULT = VECTOR * VEKTOR  --  SUM = V1 * V2^T

      implicit real*8(a - h, o - z)

      DIMENSION V1(N), V2(N)

      VSUM = 0.0d0

      do i = 1, n; VSUM = VSUM + V1(I) * V2(I); enddo

      return

      end subroutine

      SUBROUTINE VMT(V2, A, V1, N)
!     MULTIPLICATION VECTOR = MATRIX (FULL) * VEKTOR TRANSFORMIERT --  V2 = A * V1^T

      implicit real*8(a - h, o - z)

      DIMENSION V1(N), V2(N), A(N, N)

      DO 1 J = 1, N

         VSUM = .0

         DO 2 I = 1, N

            VSUM = VSUM + V1(I) * A(J, I)

    2    CONTINUE

         V2(J) = VSUM

    1 CONTINUE

      RETURN

      END subroutine

      SUBROUTINE VMD(A, V1, V2, N)
!     MULTIPLICATION MATRIX = VECTOR * VEKTOR, DYADIC PRODUCT -- A = V1^T * V2

      implicit real*8(a - h, o - z)

      DIMENSION V1(N), V2(N), A(N, N)

      DO 1 J = 1 ,N

         DO 2 I = 1, N

            A(J, I) = V1(J) * V2(I)

    2    CONTINUE

    1 CONTINUE

      RETURN

      END subroutine

      SUBROUTINE VDIFF(A1, VDI, N)
!     DIVISION MATRIX = MATRIX / FLOAT  --  A1 = A2 / VDIFF

      implicit real*8(a - h, o - z)

      DIMENSION A1(N, N)

      IF (VDI .EQ. .0) GOTO 3

      DO 2 J = 1, N

         DO 1 I = 1, N

         A1(J, I) = A1(J, I) / VDI

    1    CONTINUE

    2 CONTINUE

    3 CONTINUE

      RETURN

      END subroutine

      SUBROUTINE VADD (A, B, N)
!     VECTOR ADDITION  A = A + B

      implicit real*8(a - h, o - z)

      DIMENSION A(N), B(N)

      do 1 I = 1, N

    1 A(I) = A(I) + B(I)

      return

      end subroutine

      SUBROUTINE VADDM (A1, A2, N)
!     ADDITION OF MATRIX A1 = A1 + A2

      implicit real*8(a - h, o - z)

      DIMENSION A1(N, N), A2(N, N)

      DO 1 J = 1, N

         DO 2 I = 1, N

            A1(J, I) = A1(J, I) + A2(J, I)

    2    CONTINUE

    1 CONTINUE

      return

      end subroutine

      SUBROUTINE ACOPY (A1, A2, N)

      implicit real*8(a - h, o - z)

      dimension A1(N, N), A2(N, N)

      do J = 1, N

         do I = 1, N

            A1(J, I) = A2(J, I)

         enddo

      enddo

      return

      end subroutine

      subroutine inv_lapack(n, a)

      integer, intent(in) :: n

      real*8, intent(inout), dimension(n, n) :: a

      real*8,  dimension(n) :: work ! work array for LAPACK
      integer, dimension(n) :: ipiv ! pivot indices
      integer               :: info

!     External procedures defined in LAPACK
      external DGETRF
      external DGETRI

!     Store A in Ainv to prevent it from being overwritten by LAPACK
!      Ainv = A

!     DGETRF computes an LU factorization of a general M-by-N matrix A
!     using partial pivoting with row interchanges.
      call DGETRF(n, n, a, n, ipiv, info)

      if (info .ne. 0) stop 'Matrix is numerically singular!'

!     DGETRI computes the inverse of a matrix using the LU factorization
!     computed by DGETRF.
      call DGETRI(n, a, n, ipiv, work, n, info)

      if (info .ne. 0) stop 'Matrix inversion failed!'

      return

      end subroutine inv_lapack

      SUBROUTINE INV(N, A)

C******************************************************************************
C***  MATRIX INVERSION (CRAY FORTRAN)
C***  MATRIX A
C***  N = RANK OF SUBMATRIX (LEFT UPPER BLOCK) TO BE INVERTED
C******************************************************************************

      USE MOD_ERROR

      implicit real*8(a - h, o - z)

      integer, intent(in) :: N

      real*8, intent(inout) :: A(N, N)

      integer :: IK(N), JK(N)

      DO 100 K = 1, N

C        SUCHE MAXIMALES MATRIXELEMENT
         AMAX = 0.
         ABSAMAX = 0.

         do 30 J = K, N

            L = N + 1 - K

            ISAMAX = 1

            do LL = 1, L

               IF (abs(A(K+LL-1,j)).gt.abs(A(K+isamax-1,j))) isamax = LL

            enddo

            imax = isamax + K - 1

            if (ABSAMAX .gt. abs(A(IMAX, J))) goto 30

            AMAX =    A(IMAX, J)
            ABSAMAX = ABS(AMAX)

            IK(K) = IMAX
            JK(K) = J

   30    continue
C
C***  STOP IN CASE OF SINGULARITY (PIVOT ELEMENT = 0 )
      IF (AMAX .EQ. .0) THEN
        print *,'INV: SINGULARITY DISCOVERED'
        print *,'INV: ',N, AMAX
        CALL ERROR('inv.for: ERROR SINGULARITY DISCOVERED')
      ENDIF
C
C     VERTAUSCHEN DER ZEILEN I UND K
      I=IK(K)
      IF(I.NE.K) THEN
        DO J=1,N
          SAVE =A(K,J)
          A(K,J)=A(I,J)
          A(I,J)=-SAVE
        ENDDO
      ENDIF
C
C     VERTAUSCHEN DER SPALTEN J UND K
      J=JK(K)
      IF(J.NE.K) THEN
        DO I=1,N
          SAVE = A(I,K)
          A(I,K)=A(I,J)
          A(I,J)=-SAVE
        ENDDO
      ENDIF
C
C     DIVISION DER SPALTE K DURCH AMAX
      A(1:N,K)=-A(1:N,K)/AMAX
      A(K,K)=0.
C
C     UMFORMEN DER ZEILEN UND SPALTEN
C***  ELEMENTARE UMFORMUNG:  ZEILE I = ZEILE I + A(I,K) * ZEILE K
      DO 81 I=1,N
      IF (I .EQ. K) GOTO 81
      AIK=A(I,K)
      A(I,1:N)=A(I,1:N)+AIK*A(K,1:N)
   81 CONTINUE
C
C***  SPALTE K: DIVISION DUCH AMAX
      DO 90 J=1,N
      A(K,J)=A(K,J)/AMAX
  90  CONTINUE
C
C***  DIAGONALELEMENT
      A(K,K)=1./AMAX
  100 CONTINUE
C
C
C     ZEILEN UND SPALTEN RUECKTAUSCHOPERATIONEN
      DO 130 L=1,N
      K=N-L+1
      J=IK(K)
      IF(J.LE.K) GOTO 111
C***  VERTAUSCHEN DER SPALTEN J UND K
      DO 110 I=1,N
       SAVE=A(I,K)
      A(I,K)=-A(I,J)
  110 A(I,J)=SAVE
  111 I=JK(K)
      IF(I .LE. K) GOTO 130
C***  VERTAUSCHEN DER ZEILEN I UND K
      DO 120 J=1,N
      SAVE=A(K,J)
      A(K,J)=-A(I,J)
  120 A(I,J)=SAVE
  130 CONTINUE

      RETURN

      END SUBROUTINE inv

      SUBROUTINE MVMD(BX, B, C, JMAX, JMM)
C***  MATRIX (VOLL)  B  *  MATRIX (DIAGONAL)  C
C***  ERGEBNIS-MATRIX  BX(VOLL)
C***  AKTUELLES FORMAT BX(JMAX,JMM)=B(JMAX,JMAX)*C(JMAX,JMM)
C***  WOBEI DIE UEBERZAEHLIGEN ZEILEN DER DIAGONALMATRIX C VERSCHWINDEN
      implicit real*8(a - h, o - z)

      DIMENSION BX(JMAX, JMAX), B(JMAX, JMAX), C(JMAX)
      DO 1 K = 1, JMM
      CK = C(K)
      DO 1 I = 1, JMAX
    1 BX(I, K) = B(I, K) * CK

      RETURN

      end subroutine

      SUBROUTINE MVV(WX, B, W, JMAX, JMM)
!     MATRIX (VOLL)  B  *  VEKTOR W
!     ERGEBNIS-VEKTOR  WX
!     AKTUELLES FORMAT  WX(JMAX) = B(JMAX,JMM) * W(JMM)
      implicit real*8(a - h, o - z)

      DIMENSION WX(JMAX), B(JMAX, JMAX), W(JMAX)
      DO 1 I=1,JMAX
      WXI = .0
      DO 2 K=1,JMM
    2 WXI=WXI+B(I,K)*W(K)
    1 WX(I)=WXI

      RETURN

      end subroutine

      SUBROUTINE MDV(A, W, N)
!     MATRIX A (DIAGONAL)  *  VEKTOR W
!     ERGEBNIS-VEKTOR UEBERSCHREIBT  W

      implicit real*8(a - h, o - z)

      DIMENSION A(N), W(N)
      DO 1 I = 1, N
    1 W(I) = A(I) * W(I)

      RETURN

      end subroutine

      SUBROUTINE MSUB(A, B, N)
!     A = A - B
      implicit real*8(a - h, o - z)

      DIMENSION A(N, N), B(N, N)

      DO 1 I = 1, N
      DO 1 K = 1, N
    1 A(I, K) = A(I, K) - B(I, K)

      RETURN

      end subroutine

      SUBROUTINE MDMV(A, B, N)
!     MATRIX (DIAGONAL)  A  *  MATRIX (VOLL)  B
!     ERGEBNIS-MATRIX UEBERSCHREIBT B
      implicit real*8(a - h, o - z)

      DIMENSION A(N), B(N, N)
      DO 1 I = 1, N
      AI = A(I)
      DO 1 K = 1, N
    1 B(I, K) = B(I, K) * AI

      RETURN

      end subroutine

      SUBROUTINE VMALV(VA, VB, V, Q, LMAX)
C***  ALGEBRAIC ROUTINE CALLED FROM CMFRAY
      implicit real*8(a - h, o - z)

      DIMENSION VA(LMAX), VB(LMAX), V(LMAX), Q(LMAX)
      LZ=LMAX-1
      Q(1)=VB(1)*V(1)

      DO 1 L=2,LZ
      Q(L)=VA(L)*V(L-1)+VB(L)*V(L)
    1 CONTINUE

      Q(LMAX)=VA(LMAX)*V(LZ)

      RETURN

      END subroutine

      end module


PROGRAM test_entropy
!
      USE def_constants
      USE def_variables
      USE Grid
!      USE Interp_table
!      USE non_linear_solvers
      USE properties
      IMPLICIT NONE
!
!      INTEGER :: flag!, Niter, exitflag,i,j
!      REAL(pr):: T, v, p, e, cv, cp, s, c, v_l, v_v, v_l_Span,v_v_Span,&
!&           resnorm, guess_1, guess_2, T_span, v_span, e_span,helmho1
!      REAL(pr):: p2, e2, cv2, cp2, s2, c2, helmho2,Helmholtz
      REAL(pr):: v_in1,v_in2,T_in1,T_in2,v_in3,v_in4,T_in3,T_in4
      REAL(pr):: s_out1,s_out2,s_out3,s_out4,p_out2,p_out4
      REAL(pr):: p_in1, T1, vv1, vl1, uv1, ul1
      REAL(pr):: p_in2, T2, vv2, vl2, uv2, ul2

!
!
!
!
        CALL MAKE_GRID()

        p_in1 = 4.3339e6
        p_in2 = 5.785e6

        CALL satprop(3, p_in1, T1, vv1, vl1, uv1, ul1)
        CALL satprop(3, p_in2, T2, vv2, vl2, uv2, ul2)

        print*, 'p1= ',p_in1, 'T1= ',T1, 'rho1= ',1.0/vv1, 'rhol1= ',1.0/vl1
        print*, 'p2= ',p_in2, 'T2= ',T2, 'rho2= ',1.0/vv2, 'rhol2= ',1.0/vl2
!STOP
        v_in1=1.0/128.42686
        T_in1=281.62

        v_in2= 1.0/872.23144
        T_in2= 281.62

        v_in3= 1.0/197.49158
        T_in3= 293.56

        v_in4= 1.0/768.93522
        T_in4= 293.56

        CALL entropy(T_in1,v_in1,s_out1)
        CALL entropy(T_in2,v_in2,s_out2)
        CALL entropy(T_in3,v_in3,s_out3)
        CALL entropy(T_in4,v_in4,s_out4)

        CALL pressure(T_in2,v_in2,p_out2)
        CALL pressure(T_in4,v_in4,p_out4)

        print*, 'v1', v_in1, 'T1=',T_in1, 's1=',s_out1
        print*, 'v2', v_in2, 'T2=',T_in2, 's2=',s_out2,p_out2
        print*, 'v3', v_in3, 'T3=',T_in3, 's3=',s_out3
        print*, 'v4', v_in4, 'T4=',T_in4, 's4=',s_out4,p_out4

END PROGRAM test_entropy


Subroutine interp1(x,y,x0,y0,M,N,order)
implicit none
integer i,k,M,N
integer::In=1
real(8) x(N),y(N),x0(M),y0(M),b(M),c(M),d(M)
real(8),external::seval
character(*) order
if(order=='linear') then
 DO i=1,N
  if(x(i)>=x0(1).and.x(i)<=x0(M)) then
   DO k=1,M-1
    if(x(i)>=x0(k).and.x(i)<=x0(k+1)) then
     In=k
     exit
    end if
   end DO
  else if(x(i)<x0(1)) then
   In=1
  else if(x(i)>x0(M)) then
   In=M-1
  end if
  y(i)=(y0(In)*(x0(In+1)-x(i))+y0(In+1)*(x(i)-x0(In)))/(x0(In+1)-x0(In))
 end DO
else if(order=='spline') then
 Call spline(M,x0,y0,b,c,d)
 DO i=1,N
  y(i)=seval(M,x(i),x0,y0,b,c,d)
 end DO
end if
end Subroutine interp1

real(8) function interpl(phi0,phi1,d0,d1)
implicit none
real(8) phi0,phi1,d0,d1

interpl=(d1*phi0+d0*phi1)/(d0+d1)

end function interpl


! Evalute density as functino of temperature based on correlation
!
! Correlation is of the form density(T) = a + b*T where a, b are constants
! From MSFR paper 'Modelling and analysis of the MSFR transient behaviour'
! Input:
!       T - temperature to evaluate density at
! Output:
!       density - evaluated conductivity at T [ g/cm^3]
!
subroutine density_corr_msfr(T, density)

    USE global_parameters_M

implicit none

!---Dummy
    real(dp), intent(in)  :: T
    real(dp), intent(out) :: density
!---Local
    real(dp) :: a
    real(dp) :: b

    a = 4094_dp
    b = -8.82E-1_dp

    density = a + b*(T-1008_dp)*1E-3_dp

end subroutine density_corr_msfr


*DECK ALI
      FUNCTION ALI (X)
C***BEGIN PROLOGUE  ALI
C***PURPOSE  Compute the logarithmic integral.
C***LIBRARY   SLATEC (FNLIB)
C***CATEGORY  C5
C***TYPE      SINGLE PRECISION (ALI-S, DLI-D)
C***KEYWORDS  FNLIB, LOGARITHMIC INTEGRAL, SPECIAL FUNCTIONS
C***AUTHOR  Fullerton, W., (LANL)
C***DESCRIPTION
C
C ALI(X) computes the logarithmic integral; i.e., the
C integral from 0.0 to X of (1.0/ln(t))dt.
C
C***REFERENCES  (NONE)
C***ROUTINES CALLED  EI, XERMSG
C***REVISION HISTORY  (YYMMDD)
C   770601  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   890531  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900315  CALLs to XERROR changed to CALLs to XERMSG.  (THJ)
C   900326  Removed duplicate information from DESCRIPTION section.
C           (WRB)
C***END PROLOGUE  ALI
C***FIRST EXECUTABLE STATEMENT  ALI
      IF (X .LE. 0.0) CALL XERMSG ('SLATEC', 'ALI',
     +   'LOG INTEGRAL UNDEFINED FOR X LE 0', 1, 2)
      IF (X .EQ. 1.0) CALL XERMSG ('SLATEC', 'ALI',
     +   'LOG INTEGRAL UNDEFINED FOR X = 1', 2, 2)
C
      ALI = EI (LOG(X) )
C
      RETURN
      END


      subroutine setprob()
      implicit none

      double precision kappa,tfinal
      double precision rot_angle(2), scale

      double precision pi
      common /compi/ pi

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

      call set_maptype_disk()

      call setup_map()

c     # -------------------------------------------------
c     # Mapping routines
c     # -------------------------------------------------

c     # Set mapping scaling
      scale = 1
      rot_angle(1) = 0
      rot_angle(2) = 0
      call setup_mappedgrid(rot_angle,scale)
      end


MODULE FUN_xyzPLANE
!!#### PURPOSE
!! Create a plane with three different interfaces.
!
!!  1.  Pn = xyzPLANE( C )
!!            where C = (/a,b,c,d/) of plane equation a*x+b*y+c*z+d=0.
!
!!  2.  Pn = xyzPLANE( P3 )
!!            where P3 = (/1:3,i/) is the ith point which defines the plane,
!!            where the number of points, i=1:3.
!!
!!  3.  Pn = xyzPLANE( P , V )
!!            where P is a point and V is a vector.

!!#### METHOD
!! Use the Hessian normal form for a plane.

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

!!#### EXTERNAL PARAMETERS
USE PAR_Constants_Rsp,ONLY: c_0_Rsp => c_0     !!((02-A-PAR_Constants_Rsp.f90))
USE PAR_Constants_Rdp,ONLY: c_0_Rdp => c_0     !!((02-A-PAR_Constants_Rdp.f90))

!!#### EXTERNAL PROCEDURES
USE FUN_xyzCROSS ,ONLY: xyzCROSS_VV            !!((05-B-FUN_xyzCROSS.f90))
USE FUN_xyzNORM  ,ONLY: xyzNORM_V              !!((03-A-FUN_xyzNORM.f90))
USE FUN_xyzDOT   ,ONLY: xyzDOT_VV              !!((05-B-FUN_xyzDOT.f90))
USE FUN_xyzVECTOR,ONLY: xyzVECTOR_PP           !!((03-A-FUN_xyzVECTOR.f90))

!!#### DEFAULT IMPLICIT
IMPLICIT NONE

!!#### DEFAULT ACCESS
PRIVATE

!!#### PROCEDURE OVERLOADING
INTERFACE xyzPLANE_P3
 MODULE PROCEDURE xyzPLANE_P3_Rsp
 MODULE PROCEDURE xyzPLANE_P3_Rdp
END INTERFACE

INTERFACE xyzPLANE_PV
 MODULE PROCEDURE xyzPLANE_PV_Rsp
 MODULE PROCEDURE xyzPLANE_PV_Rdp
END INTERFACE

INTERFACE xyzPLANE_C
 MODULE PROCEDURE xyzPLANE_PAR_Rsp
 MODULE PROCEDURE xyzPLANE_PAR_Rdp
END INTERFACE

!!#### PUBLIC ACCESS LIST
PUBLIC :: xyzPLANE_P3
PUBLIC :: xyzPLANE_PV
PUBLIC :: xyzPLANE_C

CONTAINS

PURE FUNCTION xyzPLANE_PV_Rsp( P , V ) RESULT( xyzPn )
!!#### LOCAL KINDS
USE KND_IntrinsicTypes,ONLY: KIND_R=>KIND_Rsp  !!((01-A-KND_IntrinsicTypes.f90))
!!#### LOCAL PARAMETERS
REAL(KIND_R),PARAMETER :: c_0 = c_0_Rsp
INCLUDE "06-B-FUN_xyzPLANE_PV.f90.hdr"
!!--begin--
INCLUDE "06-B-FUN_xyzPLANE_PV.f90.bdy"
!!--end--
END FUNCTION

PURE FUNCTION xyzPLANE_PV_Rdp( P , V ) RESULT( xyzPn )
!!#### LOCAL KINDS
USE KND_IntrinsicTypes,ONLY: KIND_R=>KIND_Rdp  !!((01-A-KND_IntrinsicTypes.f90))
!!#### LOCAL PARAMETERS
REAL(KIND_R),PARAMETER :: c_0 = c_0_Rdp
INCLUDE "06-B-FUN_xyzPLANE_PV.f90.hdr"
!!--begin--
INCLUDE "06-B-FUN_xyzPLANE_PV.f90.bdy"
!!--end--
END FUNCTION

PURE FUNCTION xyzPLANE_PAR_Rsp( C ) RESULT( xyzPn )
!!#### LOCAL KINDS
USE KND_IntrinsicTypes,ONLY: KIND_R=>KIND_Rsp  !!((01-A-KND_IntrinsicTypes.f90))
!!#### LOCAL PARAMETERS
REAL(KIND_R),PARAMETER :: c_0 = c_0_Rsp
INCLUDE "06-B-FUN_xyzPLANE_C.f90.hdr"
!!--begin--
INCLUDE "06-B-FUN_xyzPLANE_C.f90.bdy"
!!--end--
END FUNCTION

PURE FUNCTION xyzPLANE_PAR_Rdp( C ) RESULT( xyzPn )
!!#### LOCAL KINDS
USE KND_IntrinsicTypes,ONLY: KIND_R=>KIND_Rdp  !!((01-A-KND_IntrinsicTypes.f90))
!!#### LOCAL PARAMETERS
REAL(KIND_R),PARAMETER :: c_0 = c_0_Rdp
INCLUDE "06-B-FUN_xyzPLANE_C.f90.hdr"
!!--begin--
INCLUDE "06-B-FUN_xyzPLANE_C.f90.bdy"
!!--end--
END FUNCTION

PURE FUNCTION xyzPLANE_P3_Rsp( P3 ) RESULT( xyzPn )
!!#### LOCAL KINDS
USE KND_IntrinsicTypes,ONLY: KIND_R=>KIND_Rsp  !!((01-A-KND_IntrinsicTypes.f90))
!!#### LOCAL PARAMETERS
REAL(KIND_R),PARAMETER :: c_0 = c_0_Rsp
INCLUDE "06-B-FUN_xyzPLANE_P3.f90.hdr"
!!--begin--
INCLUDE "06-B-FUN_xyzPLANE_P3.f90.bdy"
!!--end--
END FUNCTION

PURE FUNCTION xyzPLANE_P3_Rdp( P3 ) RESULT( xyzPn )
!!#### LOCAL KINDS
USE KND_IntrinsicTypes,ONLY: KIND_R=>KIND_Rdp  !!((01-A-KND_IntrinsicTypes.f90))
!!#### LOCAL PARAMETERS
REAL(KIND_R),PARAMETER :: c_0 = c_0_Rdp
INCLUDE "06-B-FUN_xyzPLANE_P3.f90.hdr"
!!--begin--
INCLUDE "06-B-FUN_xyzPLANE_P3.f90.bdy"
!!--end--
END FUNCTION

END MODULE


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

 subroutine interpolate_coarse2fine( &
      nsmax,        ns_elas,       ngeomax,          &
      nwave_coarse, wavenr_coarse, R_final_coarse,   &
      nwave_fine,   wavenr_fine,   R_final_fine)

!-----------------------------------------------------------
! Subroutine:
!   interpolate_course2fine
!
! Purpose:
!   Interpolate to get reflectivity on fine wavner grid
!   Take natural logarithm first to make R_final more linear
!   with wavener.
!
! Input
!   R_sys_coarse
!
! Output:
!   R_sys_fine
!-------------------------------------------------------------------

  implicit none

  integer,parameter::dp=selected_real_kind(8)!double precision

  integer,intent(in):: &
     nsmax,        &
     ns_elas,      &
     ngeomax,      &
     nwave_coarse, &
     nwave_fine

  real(kind=dp),intent(in):: &
     wavenr_fine(nwave_fine),     &
     wavenr_coarse(nwave_coarse), &
     R_final_coarse(0:nsmax,nwave_coarse,ngeomax)

! ridiciously large nr needed for natural spline
  real(kind=dp),parameter:: &
     rlnr = 1.d32

  real(kind=dp):: &
     y_coarse(nwave_coarse), &
     d_coarse(nwave_coarse), & !derivatives, spline
     y_fine(nwave_fine)

  integer::ns,n,nn,iv

  real(kind=dp),intent(out):: &
     R_final_fine(0:nsmax,nwave_fine,ngeomax)

  logical,parameter::take_log=.false.

  do iv=1,ngeomax

     do ns=0,nsmax

        do n=1,nwave_coarse
           if(take_log)then
              y_coarse(n) = log(R_final_coarse(ns,n,iv))
           else
              y_coarse(n) = R_final_coarse(ns,n,iv)
           endif
        enddo

        call spline( &
             wavenr_coarse,  y_coarse,  nwave_coarse, &
             rlnr,           rlnr,      d_coarse)

        do nn=1,nwave_fine

           call splint( &
                wavenr_coarse,  y_coarse,         d_coarse,   &
                nwave_coarse,   wavenr_fine(nn),  y_fine(nn))

           if(take_log)then
              R_final_fine(ns,nn,iv) = exp(y_fine(nn))
           else
              R_final_fine(ns,nn,iv) = y_fine(nn)
           endif

        enddo

     enddo

  enddo

  return
  end subroutine interpolate_coarse2fine


c=======================================================================
      subroutine ptdensityup(ngrid,nrec,y,
     &                       ab,murand,sigmarand,jfr,m0,s0,tau,
     &                       nlevel,ninter,
     &                       mcmcvec,nsave,tune1,tune2,tune3,
     &                       acrate,f,thetasave,cpo,
     &                       cpar,mu,sigma,
     &                       grid,intpn,intpo,
     &                       accums,assign,counter,endp,
     &                       prob,rvecs,
     &                       seed)
c=======================================================================
c
c     Subroutine `fptdensityu' to run a Markov chain for univariate
c     density estimation using a Mixture of Finite Polya Tree prior. The
c     Polya Tree is centered in a N(mu,sigma2) distribution.
c
c     This subroutine is based on the mpt FORTRAN program of
c     Tim Hanson.
c
c     Copyright: Alejandro Jara and Tim Hanson, 2006-2010.
c
c     Version 3.0:
c
c     Last modification: 6-1-2010.
c
c     Changes and Bug fixes:
c
c     Version 2.0 to Version 3.0:
c          - Centering parameters can be fixed.
c          - Proper prior can be used on the centering parameters.
c
c     Version 1.0 to Version 2.0:
c          - Fixed bug in computation of MH ratio for precision parameter.
c
c     This program is free software; you can redistribute it and/or modify
c     it under the terms of the GNU General Public License as published by
c     the Free Software Foundation; either version 2 of the License, or (at
c     your option) any later version.
c
c     This program is distributed in the hope that it will be useful, but
c     WITHOUT ANY WARRANTY; without even the implied warranty of
c     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
c     General Public License for more details.
c
c     You should have received a copy of the GNU General Public License
c     along with this program; if not, write to the Free Software
c     Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
c
c     The authors's contact information:
c
c      Alejandro Jara
c      Department of Statistics
c      Facultad de Matematicas
c      Pontificia Universidad Catolica de Chile
c      Casilla 306, Correo 22
c      Santiago
c      Chile
c      Voice: +56-2-3544506  URL  : http://www.mat.puc.cl/~ajara
c      Fax  : +56-2-3547729  Email: atjara@uc.cl
c
c      Tim Hanson
c      Division of Biostatistics
c      University of Minnesota
c      School of Public Health
c      A460 Mayo Building,
c      MMC 303
c      420 Delaware St SE
c      Minneapolis, MN 55455
c      Voice: 612-626-7075  URL  : http://www.biostat.umn.edu/~hanson/
c      Fax  : 612-626-0660  Email: hanson@biostat.umn.edu
c
c---- Data -------------------------------------------------------------
c
c        ngrid       :  integer giving the size of the grid where
c                       the density estimate is evaluated.
c        nrec        :  integer giving the number of observations.
c        y           :  real vector giving the response variables,
c                       y(nrec).
c
c-----------------------------------------------------------------------
c
c---- Prior information ------------------------------------------------
c
c        ca, cb      :  real giving the hyperparameters of the prior
c                       distribution for the precision parameter,
c                       c ~ Gamma(ca,cb). If ca<0 the precision
c                       parameter is considered as a constant.
c        ninter      :  integer giving the number of final intervals
c                       in the Finite Polya tree prior.
c        nlevel      :  integer giving the number of binary partitions
c                       in the Finite Polya tree prior.
c        jfr         :  integer vector indicating whether Jeffery's
c                       prior is used for the centering parameters.
c        m0          :  real giving the mean of the normal prior
c                       for the centering mean.
c        s0          :  real giving the variance of the normal prior
c                       for the centering mean.
c        tau         :  real vector giving the hyperparameters of
c                       inverse gamma prior for the centering variance.
c
c-----------------------------------------------------------------------
c
c---- MCMC parameters --------------------------------------------------
c
c        nburn       :  integer giving the number of burn-in scans.
c        ndisplay    :  integer giving the number of saved scans to be
c                       displayed on screen.
c        nskip       :  integer giving the thinning interval.
c        nsave       :  integer giving the number of scans to be saved.
c        tune1       :  real giving the tuning parameter for MH of
c                       mean baseline.
c        tune2       :  real giving the tuning parameter for MH of
c                       variance baseline.
c        tune3       :  real giving the tuning parameter for MH of
c                       precision parameter.
c
c-----------------------------------------------------------------------
c
c---- Output -----------------------------------------------------------
c
c        acrate      :  real vector giving the MH acceptance rate,
c                       acrate(3).
c        f           :  real vector giving the density estimate at the
c                       grid, f(ngrid).
c        thetasave   :  real vector containing the mcmc sample for the
c                       parameters, betsave(nsave,3).
c        cpo         :  real giving the cpo, cpo(nrec).
c
c-----------------------------------------------------------------------
c
c---- Current value of the parameters ----------------------------------
c
c        cpar        :  real giving the current value of the precision
c                       parameter of the Polya Tree.
c        mu          :  real vector giving the current value of the
c                       baseline mean.
c        sigma       :  real giving the he current value of the
c                       baseline standard deviation.
c
c-----------------------------------------------------------------------
c
c---- Working space ----------------------------------------------------
c
c        accums      :  real matrix giving the accumulated log
c                       probabilities used in the computation of
c                       final interval probabilities,
c                       accums(nlevel,ninter).
c        assign      :  integer matrix giving the possition of each
c                       observation in each partition,
c                       assign(nrec,nlevel).
c        cdfnorm     :  cdf of a normal distribution.
c        counter     :  integer matrix giving the number of subjects
c                       in each binary partition, counter(nlevel,ninter).
c        cparc       :  real giving the value of the candidate
c                       for the precision parameter.
c        dbet        :  density of a beta distribution.
c        dispcount   :  index.
c        dlnrm       :  density of a log-normal distribution.
c        dnrm        :  density of a normal distribution.
c        endp        :  real vector giving the end of the intervals,
c                       endp(ninter-1).
c        grid        :  real vector giving the grid where the density
c                       estimate is evaluated, grid(ngrid) .
c        i           :  index.
c        intlp       :  index.
c        intpn       :  integer vector giving the interval possition
c                       for the current value of parameters for
c                       the observations, intpn(nrec).
c        intpo       :  integer vector giving the interval possition
c                       for the candidate value of parameters for
c                       the observations, intpo(nrec).
c        invcdfnorm  :  quantile function for a normal distribution.
c        isave       :  index.
c        iscan       :  index.
c        j           :  index.
c        je2         :  index.
c        k           :  index.
c        k1          :  index.
c        k2          :  index.
c        logcgkn     :  real working variable.
c        logcgko     :  real working variable.
c        loglikn     :  real working variable.
c        logliko     :  real working variable.
c        logpriorn   :  real working variable.
c        logprioro   :  real working variable.
c        muc         :  real giving the value of the candidate
c                       for the baseline mean.
c        nint        :  index
c        npoints     :  index.
c        nscan       :  index.
c        pprn        :  index.
c        prob        :  real vector giving the probability of
c                       the intervals, prob(ninter).
c        quan        :  real working variable.
c        ratio       :  real working variable.
c        rbeta       :  real beta random number generator.
c        rtlnorm     :  real truncated log normal random number generator.
c        rnorm       :  real normal random number generator.
c        runif       :  real uniform random number generator.
c        rvecs       :  real matrix giving the random vectors for the
c                       Polya tree,  rvecs(nlevel,ninter).
c        s           :  real giving the sample variance.
c        sec         :  cpu time working variable.
c        sec0        :  cpu time working variable.
c        sec00       :  cpu time working variable.
c        sec1        :  cpu time working variable.
c        seed1       :  seed for random number generation.
c        seed2       :  seed for random number generation.
c        sigmac      :  real giving the value of the candidate
c                       for the baseline standard deviation.
c        sigma2      :  real giving the current value of
c                       the baseline variance.
c        sigma2c     :  real giving the value of the candidate
c                       for the baseline variance.
c        skipcount   :  index.
c        sprint      :  integer function to print on screen.
c        tmp1        :  real used to accumulate quantities.
c        tmp2        :  real used to accumulate quantities.
c        tmp3        :  real used to accumulate quantities.
c        uni         :  real working variable.
c        ybar        :  real giving the sample mean.
c
c=======================================================================

      implicit none

c+++++Data
      integer ngrid,nrec
      real*8 y(nrec)

c+++++Prior information
      integer nlevel,ninter
      real*8 ab(2),ca,cb
      integer murand,sigmarand,jfr(2)
      real*8 m0,s0
      real*8 tau(2)

c+++++MCMC parameters
      integer mcmcvec(3),nburn,nskip,nsave,ndisplay
      real*8 tune1,tune2,tune3

c+++++Stored output
      real*8 acrate(3),f(ngrid)
      real*8 thetasave(nsave,3)
      real*8 cpo(nrec)

c+++++Current values of the parameters
      real*8 cpar,mu,sigma

c+++++Working space - CPU time
      real*8 sec00,sec0,sec1,sec

c+++++Working space - Density
      real*8 grid(ngrid)

c+++++Working space - Distributions
      real*8 dbet,dnrm,dlnrm
      real*8 invcdfnorm

c+++++Working space - General
      integer i,j,je2,k,k1,k2
      integer nint,npoints,pprn,sprint
      real*8 quan
      real*8 s,tmp1,tmp2,tmp3,ybar

c+++++Working space - MCMC scans
      integer dispcount,isave,iscan,nscan,skipcount

c+++++Working space - MH steps
      integer intlp
      integer intpn(nrec),intpo(nrec)
      real*8 cparc
      real*8 logcgkn,logcgko
      real*8 loglikn,logliko
      real*8 logpriorn,logprioro
      real*8 muc,sigma2,sigmac,sigma2c
      real*8 ratio

c+++++Working space - Polya tree parameters
      integer assign(nrec,nlevel)
      integer counter(nlevel,ninter)
      real*8 accums(nlevel,ninter)
      real*8 endp(ninter-1)
      real*8 prob(ninter)
      real*8 rvecs(nlevel,ninter)

c+++++Working space - Random number generator
      integer seed(2),seed1,seed2
      real*8 rbeta,rnorm,rtlnorm
      real runif

c++++ initialize variables
      nburn=mcmcvec(1)
      nskip=mcmcvec(2)
      ndisplay=mcmcvec(3)

      ca=ab(1)
      cb=ab(2)

      sigma2=sigma**2

c++++ set random number generator

      seed1=seed(1)
      seed2=seed(2)

      call setall(seed1,seed2)

c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
c++++ start the MCMC algorithm
c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
      isave=0
      skipcount=0
      dispcount=0
      nscan=nburn+(nskip+1)*(nsave)

      npoints=ninter-1

      call cpu_time(sec0)
      sec00=0.d0

      ybar=0.d0
      s=0.d0
      do i=1,nrec
         ybar=ybar+y(i)
      end do
      ybar=ybar/dble(nrec)

      do i=1,nrec
         s=s+(y(i)-ybar)**2
      end do
      s=s/dble(nrec)

      do iscan=1,nscan

c+++++++ check if the user has requested an interrupt
         call rchkusr()

c++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
c+++++++ Generating from the full conditionals for Polya Tree        ++
c+++++++ parmeters                                                   ++
c++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++

         do i=1,nlevel
            nint=2**i
            do j=1,nint
               counter(i,j)=0
               accums(i,j)=0.d0
               rvecs(i,j)=0.d0
            end do
         end do

         do i=1,nrec
            nint=2
            tmp1=1.d0/dble(nint)
            quan=invcdfnorm(tmp1,mu,sigma,1,0)
            if(y(i).le.quan)then
                assign(i,1)=1
                counter(1,1)=counter(1,1)+1
              else
                assign(i,1)=2
                counter(1,2)=counter(1,2)+1
            end if

            do j=2,nlevel
               nint=2**j
               tmp1=1.d0/dble(nint)
               k=assign(i,j-1)
               k1=2*(k-1)+1
               k2=2*(k-1)+2

               quan=invcdfnorm(dble(k1)*tmp1,mu,sigma,1,0)

               if(y(i).le.quan)then
                  assign(i,j)=k1
                  counter(j,k1)=counter(j,k1)+1
                 else
                  assign(i,j)=k2
                  counter(j,k2)=counter(j,k2)+1
               end if
            end do

            intpo(i)=assign(i,nlevel)
         end do

c+++++++ generating (X0,X1),(X00,X01,X10,X11),....

         tmp1=cpar+dble(counter(1,1))
         tmp2=cpar+dble(counter(1,2))
         tmp3=rbeta(tmp1,tmp2)
         rvecs(1,1)=tmp3
         rvecs(1,2)=1.d0-tmp3
         accums(1,1)=log(tmp3)
         accums(1,2)=log(1.d0-tmp3)

         do i=1,nlevel-1
            nint=2**i
            je2=(i+1)**2
            do j=1,nint
               k1=2*(j-1)+1
               k2=2*(j-1)+2
               tmp1=cpar*dble(je2)+dble(counter(i+1,k1))
               tmp2=cpar*dble(je2)+dble(counter(i+1,k2))
               tmp3=rbeta(tmp1,tmp2)
               rvecs(i+1,k1)=tmp3
               rvecs(i+1,k2)=1.d0-tmp3
               accums(i+1,k1)=log(tmp3)+accums(i,j)
               accums(i+1,k2)=log(1.d0-tmp3)+accums(i,j)
             end do
          end do

          do i=1,ninter
             prob(i)=exp(accums(nlevel,i))
          end do

c++++++++ end points

          tmp1=1.d0/dble(ninter)
          do i=1,npoints
             endp(i)=invcdfnorm(dble(i)*tmp1,mu,sigma,1,0)
          end do

c++++++++++++++++++++++++++++++++++++++++++++++++++++++++
c+++++++ Updating mu using a MH step                  +++
c++++++++++++++++++++++++++++++++++++++++++++++++++++++++

         if(murand.eq.1)then

            muc=rnorm(mu,tune1*sigma/sqrt(dble(nrec)))

            logliko=0.d0
            loglikn=0.d0

            do i=1,nrec

c+++++++++++++ possition according to the candidate

               nint=2
               tmp1=1.d0/dble(nint)
               quan=invcdfnorm(tmp1,muc,sigma,1,0)
               if(y(i).le.quan)then
                  intlp=1
                 else
                  intlp=2
               end if

               do j=2,nlevel
                  nint=2**j
                  tmp1=1.d0/dble(nint)
                  k=intlp
                  k1=2*(k-1)+1
                  k2=2*(k-1)+2

                  quan=invcdfnorm(dble(k1)*tmp1,muc,sigma,1,0)

                  if(y(i).le.quan)then
                     intlp=k1
                    else
                     intlp=k2
                  end if
               end do

               intpn(i)=intlp

c+++++++++++++ likelihood current

               tmp1=prob(intpo(i))*dble(ninter)*dnrm(y(i),mu,sigma,0)

               logliko=logliko+log(tmp1)

c+++++++++++++ likelihood candidate

               tmp2=prob(intpn(i))*dble(ninter)*dnrm(y(i),muc,sigma,0)

               loglikn=loglikn+log(tmp2)

            end do

c++++++++++ acceptance step

            logpriorn=0.d0
            logprioro=0.d0

            if(jfr(1).eq.0)then
               logprioro=dnrm(mu, m0,sqrt(s0),1)
               logpriorn=dnrm(muc,m0,sqrt(s0),1)
            end if

            ratio=loglikn-logliko+logpriorn-logprioro

            if(log(dble(runif())).lt.ratio)then
               mu=muc
               do i=1,nrec
                  intpo(i)=intpn(i)
               end do
               acrate(1)=acrate(1)+1.d0
            end if

         end if

c++++++++++++++++++++++++++++++++++++++++++++++++++++++++
c+++++++ Updating sigma using a MH step               +++
c++++++++++++++++++++++++++++++++++++++++++++++++++++++++

         if(sigmarand.eq.1)then

            logliko=0.d0
            loglikn=0.d0

            sigma2c=rtlnorm(log(sigma2),tune2*0.1d0,0,0,.true.,.true.)
            sigmac=sqrt(sigma2c)

            logcgkn=dlnrm(sigma2 ,log(sigma2c),tune2*0.1d0,1)
            logcgko=dlnrm(sigma2c,log(sigma2 ),tune2*0.1d0,1)

            do i=1,nrec
c+++++++++++++ possition according to the candidate

               nint=2
               tmp1=1.d0/dble(nint)
               quan=invcdfnorm(tmp1,mu,sigmac,1,0)
               if(y(i).le.quan)then
                  intlp=1
                 else
                  intlp=2
               end if

               do j=2,nlevel
                  nint=2**j
                  tmp1=1.d0/dble(nint)
                  k=intlp
                  k1=2*(k-1)+1
                  k2=2*(k-1)+2

                  quan=invcdfnorm(dble(k1)*tmp1,mu,sigmac,1,0)

                  if(y(i).le.quan)then
                     intlp=k1
                    else
                     intlp=k2
                  end if
               end do

               intpn(i)=intlp

c+++++++++++++ likelihood current

               tmp1=prob(intpo(i))*dble(ninter)*dnrm(y(i),mu,sigma,0)

               logliko=logliko+log(tmp1)

c+++++++++++++ likelihood candidate

               tmp2=prob(intpn(i))*dble(ninter)*dnrm(y(i),mu,sigmac,0)

               loglikn=loglikn+log(tmp2)

            end do

c++++++++++ acceptance step
            logpriorn=-log(sigma2c)
            logprioro=-log(sigma2)

            if(jfr(2).eq.0)then
               logpriorn=-(0.5d0*tau(1)+1.d0)*log(sigma2c)-
     &                     0.5d0*tau(2)/sigma2c

               logprioro=-(0.5d0*tau(1)+1.d0)*log(sigma2)-
     &                     0.5d0*tau(2)/sigma2
            end if

            ratio=loglikn-logliko+logcgkn-logcgko+
     &            logpriorn-logprioro

            if(log(dble(runif())).lt.ratio)then
               sigma=sigmac
               sigma2=sigma2c
               do i=1,nrec
                  intpo(i)=intpn(i)
               end do
               acrate(2)=acrate(2)+1.d0
            end if

         end if

c++++++++++++++++++++++++++++++++++++++++++++++++++++++++
c+++++++ MH to update the c parameter                 +++
c++++++++++++++++++++++++++++++++++++++++++++++++++++++++
         if(ca.gt.0.d0)then

c++++++++++ sample candidates

            cparc=rtlnorm(log(cpar),tune3*0.2,0,0,.true.,.true.)
            logcgkn=dlnrm(cpar ,log(cparc),tune3*0.2,1)
            logcgko=dlnrm(cparc,log(cpar ),tune3*0.2,1)

c++++++++++ evaluate log-prior for candidate value of the parameters

            call dgamma2(cparc,ca,cb,logpriorn)

c++++++++++ evaluate log-prior for current value of parameters

            call dgamma2(cpar ,ca,cb,logprioro)

c+++++++++++ evaluate log-likelihood

            logliko=0.d0
            loglikn=0.d0

            tmp1=cpar
            tmp2=cpar
            logliko=logliko+dbet(rvecs(1,1),tmp1,tmp2,1)

            tmp1=cparc
            tmp2=cparc
            loglikn=loglikn+dbet(rvecs(1,1),tmp1,tmp2,1)

            do i=1,nlevel-1
               nint=2**i
               je2=(i+1)**2
               do j=1,nint
                  k1=2*(j-1)+1
                  k2=2*(j-1)+2
                  tmp1=cpar*dble(je2)
                  tmp2=cpar*dble(je2)
                  logliko=logliko+dbet(rvecs(i+1,k1),tmp1,tmp2,1)

                  tmp1=cparc*dble(je2)
                  tmp2=cparc*dble(je2)
                  loglikn=loglikn+dbet(rvecs(i+1,k1),tmp1,tmp2,1)
                end do
             end do

c++++++++++ acceptance step
            ratio=loglikn+logpriorn-logliko-logprioro+
     &            logcgkn-logcgko

            if(log(dble(runif())).lt.ratio)then
               cpar=cparc
               acrate(3)=acrate(3)+1.d0
            end if

         end if

c++++++++++++++++++++++++++++++++++++++++++++++++++++++++
c+++++++ Save samples                                 +++
c++++++++++++++++++++++++++++++++++++++++++++++++++++++++

         if(iscan.gt.nburn)then
            skipcount=skipcount+1
            if(skipcount.gt.nskip)then
               isave=isave+1
               dispcount=dispcount+1

c+++++++++++++ mu
               thetasave(isave,1)=mu

c+++++++++++++ sigma
               thetasave(isave,2)=sigma

c+++++++++++++ c parameter
               thetasave(isave,3)=cpar

c+++++++++++++ cpo
               do i=1,nrec
                  tmp1=prob(intpo(i))*dble(ninter)*
     &                 dnrm(y(i),mu,sigma,0)
                  cpo(i)=cpo(i)+1.0d0/tmp1
               end do

c+++++++++++++ density

               do i=1,ngrid
                  nint=2
                  tmp1=1.d0/dble(nint)
                  quan=invcdfnorm(tmp1,mu,sigma,1,0)
                  if(grid(i).le.quan)then
                     intlp=1
                    else
                     intlp=2
                  end if

                  do j=2,nlevel
                     nint=2**j
                     tmp1=1.d0/dble(nint)
                     k=intlp
                     k1=2*(k-1)+1
                     k2=2*(k-1)+2
                     quan=invcdfnorm(dble(k1)*tmp1,mu,sigma,1,0)
                     if(grid(i).le.quan)then
                        intlp=k1
                      else
                        intlp=k2
                     end if
                  end do
                  f(i)=f(i)+prob(intlp)*dble(ninter)*
     &                 dnrm(grid(i),mu,sigma,0)
               end do

c+++++++++++++ print
               skipcount = 0
               if(dispcount.ge.ndisplay)then
                  call cpu_time(sec1)
                  sec00=sec00+(sec1-sec0)
                  sec=sec00
                  sec0=sec1
                  pprn=sprint(isave,nsave,sec)
                  dispcount=0
               end if
            end if
         end if
      end do

      do i=1,3
         acrate(i)=acrate(i)/dble(nscan)
      end do

      do i=1,nrec
         cpo(i)=dble(nsave)/cpo(i)
      end do

      do i=1,ngrid
         f(i)=f(i)/dble(nsave)
      end do

      return
      end


program problem42
  implicit none
  integer, parameter         :: n=1786,m=20
  character(m), dimension(n) :: words
  integer                    :: i,answer=0

  open(33,file='./data/problem42.dat')
  read(33,*) words

  do i=1,n
     if (is_triangle(number(words(i)))) answer=answer+1
  end do

  print *, answer

contains

  pure function number(word)
    character(*), intent(in) :: word
    integer                  :: number,i

    number=0
    do i=1,len_trim(word)
       number=number+(ichar(word(i:i+1))-ichar('A')+1)
    end do

  end function number

  pure function is_triangle(n)
    integer, intent(in) :: n
    double precision    :: x1,x2
    logical             :: is_triangle

    ! quadratic formula
    x1 = (-1 - sqrt(dble(1+8*n))) / 2
    x2 = (-1 + sqrt(dble(1+8*n))) / 2

    is_triangle=.false.
    if (x1 > 0 .and. (mod(x1,1.0)==0.0)) is_triangle=.true.
    if (x2 > 0 .and. (mod(x2,1.0)==0.0)) is_triangle=.true.

  end function is_triangle

end program problem42


!   Expand covariance matrix of matrix from compact format.
function expandcovmat(n,covmat)
implicit none
integer,intent(in)::n
real(kind=8),intent(in)::covmat(:,:)
real(kind=8)::expandcovmat(n,n,n,n)
!   h, i, j, k, l, m, and n are indices

integer::h,i,j,k,l,m
l=1
do h=1,n
    do i=1,h
        m=1
        do j=1,h
            do k=1,j

                if(k<j.and.h==i)then
					expandcovmat(h,i,j,k)=2.0_8*covmat(l,m)
					expandcovmat(h,i,k,j)=expandcovmat(h,i,j,k)
				endif
				if(i<h.and.k==j)then
					expandcovmat(h,i,j,k)=2.0_8*covmat(l,m)
					expandcovmat(i,h,j,k)=expandcovmat(h,i,j,k)
				end if
                if(i<h.and.k<j)then
					expandcovmat(h,i,j,k)=4.0_8*covmat(l,m)
					expandcovmat(h,i,k,j)=expandcovmat(h,i,j,k)
					expandcovmat(i,h,j,k)=expandcovmat(h,i,j,k)
					expandcovmat(i,h,k,j)=expandcovmat(h,i,j,k)
				end if
				if(i==h.and.j==k)expandcovmat(h,i,j,k)=covmat(l,m)
                m=m+1
            end do

        end do
        l=l+1
    end do
end do

return
end function expandcovmat


!! THis module makes a bimodal distribution using two maxwellians
!! one maxwellian on the left and another on the right and some sort of linear? switching in between...
!! IN 3D in velocity space and 1D in physical space...

!DIMENSIONLESS SEE NOTES FOR THE REDUCTION FORMULAS
module sf02
use nrtype ! contains kind parameters (DP), (DP), (I4B) etc.
use commvar, only: R => gasR,gasTref,gamma=>gasalpha,gasmuref! these parameters are set in parameters.dat

   implicit none
   intrinsic Exp,Min

   interface fade
     module procedure fade, fade_x_vector
   end interface

   interface f_1D3D
     module procedure f_1D3D, f_1D3D_x_vector, f_1D3D_u_vectors, f_1D3D_x_vector_u_vectors
   end interface

   interface maxwelveldist
     module procedure maxwelveldist, maxwelveldist_T_vector, maxwelveldist_u_vectors, &
                                     maxwelveldist_T_vector_u_vectors
   end interface

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!  This function mimics the shock wave stationary solution. We use it here to test accuracy of
!  integration in the initial data.
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! These are the paramters of the gas for the shock wave Mach 10!
! Gas constants for Ar:
! R = gasR ! the ordinary gas constant
! gamma = gasalpha !    ! interior degree of freedom?
! mass = mol_mass! molecular mass
real (DP), parameter, private :: mass=6.63d-26
! conditions before the shock wave,
real (DP), parameter, private :: T1=0.2_DP  ! dimensionless temperature  -- ratio to T_{\infyt},
real (DP), parameter, private :: d1=2.00014_DP  ! dimensionless density == ration to initial number density
real (DP), parameter, private :: u1=1.2247472_DP ! dimensionless bulk velocity  -- ratio to C_{\infty}
real (DP), parameter, private :: v1=0.0_DP ! v1=?
real (DP), parameter, private :: w1=0.0_DP ! w1=?

! condtions after the shock wave
real (DP), parameter, private :: T2=0.7333333_DP   !  dimensionless temperature  -- ratio to T_{\infyt},
real (DP), parameter, private :: d2=5.9984_DP   !  dimensionless density == ration to initial number density
real (DP), parameter, private :: u2=0.4082448_DP ! dimensionless bulk velocity  -- ratio to C_{\infty}
real (DP), parameter, private :: v2=0.0_DP ! v2=?
real (DP), parameter, private :: w2=0.0_DP ! w2=?
!
real (DP), parameter, private :: lambda = 1_DP ! charachteristic length
!
real (DP), parameter, private :: pi25DT = 3.141592653589793238462643d0
!! Constants for switching ::
real (DP), parameter, private :: x1=-0.1_DP   ! first function "begin fade" (before fade coefficient of first maxwellian is 1)
real (DP), parameter, private :: x2=0.1_DP   ! first function "end fade"   (after fade coefficient of first maxwellian is 0)
!!!
contains

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! f_1D3D            !!! to use with the main variable f
!
! This function evaluates a bimodal maxwellian distribution
!
! This function evaluates the 1D3D source function on vector value for x and vector values for u,v,w
!
!
! It expects 1+3 vectors: one in x, and three the same size for u,v,w. And a scalar time t
!
! EXPECTS:
!  x -- point(s) in the first variable where the function needs to be evaluated
!  u,v,w -- point(s) in the second variable where the function needs to be evaluated
!  t -- time is the third variable of the function
! RETURNS:
! y -- value(s), usually a matrix y(size(x), size(u))
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! This is a reloadble function: see the interface statement above>>
!!   interface f_1D3D
!!    module procedure f_1D3D, f_1D3D_x_vector, f_1D3D_u_vectors, f_1D3D_x_vector_u_vectors
!!  end interface
!!

! This is a copy of the function for the vector first variable and vector second
function f_1D3D_x_vector_u_vectors (x, u, v, w, t)  result (y)
   real (DP), dimension (:), intent (in)  :: x     ! vector of values of variable (x) where the function needs to be evaluated
   real (DP), dimension (:), intent (in)  :: u,v,w     ! vectors of values of variable (u,v,w) where the function needs to be evaluated
   real (DP), intent (in)  :: t        ! the value of time parameter,
   real (DP), dimension (size(x),size(u)) :: y ! values of the function
   integer (I4B) :: i ! local counter
   real (DP), dimension (size(x)) :: N1 ! the weight function
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
N1 = fade(x)
do i = 1, size(u)
y(:,i) = maxwelveldist (T1,u1,v1,w1,d1,u(i),v(i),w(i))*N1 + maxwelveldist (T2,u2,v2,w2,d2,u(i),v(i),w(i))*(1-N1)
end do
end function f_1D3D_x_vector_u_vectors

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! f_1D3D            !!! to use with the main variable f
!
! This function evaluates a bimodal maxwellian distribution
!
! This function evaluates the 1D3D source function on vector value for x and vector values for u,v,w
!
!
! It expects 1 scalar x and 3 vectors of same size for u,v,w. And a scalar time t
!
! EXPECTS:
!  x -- point(s) in the first variable where the function needs to be evaluated
!  u,v,w -- point(s) in the second variable where the function needs to be evaluated
!  t -- time is the third variable of the function
! RETURNS:
! y -- value(s), usually a matrix y(size(x), size(u))
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! This is a reloadble function: see the interface statement above>>
!!   interface f_1D3D
!!    module procedure f_1D3D, f_1D3D_x_vector, f_1D3D_u_vectors, f_1D3D_x_vector_u_vectors
!!  end interface
!!

! This is a copy of the function for the scalar first variable and vector second
function f_1D3D_u_vectors (x, u, v, w, t)  result (y)
   real (DP), intent (in)  :: x     ! value of variable (x) where the function needs to be evaluated
   real (DP), dimension (:), intent (in)  :: u,v,w     ! vectors of values of variable (u,v,w) where the function needs to be evaluated
   real (DP), intent (in)  :: t        ! the value of time parameter,
   real (DP), dimension (size(u)) :: y ! values of the function
   real (DP) :: N1 ! the weight function
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
N1 = fade(x)
y = maxwelveldist (T1,u1,v1,w1,d1,u,v,w)*N1 + maxwelveldist (T2,u2,v2,w2,d2,u,v,w)*(1-N1)
end function f_1D3D_u_vectors

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! f_1D3D            !!! to use with the main variable f
!
! This function evaluates a bimodal maxwellian distribution
!
! This function evaluates the 1D3D source function on vector value for x and vector values for u,v,w
!
!
! It expects 1 vector for x and three scalars for u,v,w. And a scalar time t
!
! EXPECTS:
!  x -- point(s) in the first variable where the function needs to be evaluated
!  u,v,w -- point(s) in the second variable where the function needs to be evaluated
!  t -- time is the third variable of the function
! RETURNS:
! y -- value(s), usually a matrix y(size(x), size(u))
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! This is a reloadble function: see the interface statement above>>
!!   interface f_1D3D
!!    module procedure f_1D3D, f_1D3D_x_vector, f_1D3D_u_vectors, f_1D3D_x_vector_u_vectors
!!  end interface
!!

! This is a copy of the function for the vector first variable and scalar second
function f_1D3D_x_vector (x, u, v, w, t)  result (y)
   real (DP), dimension (:), intent (in)  :: x     ! vector of values of variable (x) where the function needs to be evaluated
   real (DP), intent (in)  :: u,v,w     ! vectors of values of variable (u,v,w) where the function needs to be evaluated
   real (DP), intent (in)  :: t        ! the value of time parameter,
   real (DP), dimension (size(x)) :: y ! values of the function
   real (DP), dimension (size(x)) :: N1 ! the weight function
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
N1 = fade(x)
y = maxwelveldist (T1,u1,v1,w1,d1,u,v,w)*N1 + maxwelveldist (T2,u2,v2,w2,d2,u,v,w)*(1-N1)
end function f_1D3D_x_vector

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! f_1D3D            !!! to use with the main variable f
!
! This function evaluates a bimodal maxwellian distribution
!
! This function evaluates the 1D3D source function on vector value for x and vector values for u,v,w
!
!
! It expects 1 vector for x and three scalars for u,v,w. And a scalar time t
!
! EXPECTS:
!  x -- point(s) in the first variable where the function needs to be evaluated
!  u,v,w -- point(s) in the second variable where the function needs to be evaluated
!  t -- time is the third variable of the function
! RETURNS:
! y -- value(s), usually a matrix y(size(x), size(u))
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! This is a reloadble function: see the interface statement above>>
!!   interface f_1D3D
!!    module procedure f_1D3D, f_1D3D_x_vector, f_1D3D_u_vectors, f_1D3D_x_vector_u_vectors
!!  end interface
!!

! This is a copy of the function for the scalar first variable and scalar second
function f_1D3D (x, u, v, w, t)  result (y)
   real (DP), intent (in)  :: x     ! vector of values of variable (x) where the function needs to be evaluated
   real (DP), intent (in)  :: u,v,w     ! vectors of values of variable (u,v,w) where the function needs to be evaluated
   real (DP), intent (in)  :: t        ! the value of time parameter,
   real (DP)  :: y ! values of the function
   real (DP) :: N1 ! the weight function
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
N1 = fade(x)
y = maxwelveldist (T1,u1,v1,w1,d1,u,v,w)*N1 + maxwelveldist (T2,u2,v2,w2,d2,u,v,w)*(1-N1)
end function f_1D3D

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! maxwelveldist (T,u_0,n,u) result (y)
!
! This function evauates the 1D maxwellian equilibrium distribution with given temperature and average velocity
! Temperature and average velocity can be arrays (corresponding to different points in x variable
!
! This function evaluates
! f2_{M}(t,x,u)=(2\pi RT(t,x))^{-1/2} \exp(-\frac{(u-\bar{u})^2}{2RT})
!
! This is a reloadable function
!!!!!!!!!!!!!!!!!!!!!!!
!
! this is the copy when T is vector and u is scalar
function maxwelveldist_T_vector_u_vectors (T,u_0,v_0,w_0,n,u,v,w) result (y)
   real (DP), dimension (:), intent (in) :: T    ! temperature parameter (may depend on x)
   real (DP), dimension (:), intent (in) :: n    ! density parameter (may depend on x)
   real (DP), dimension (:), intent (in) :: u_0,v_0,w_0  ! average velocity (may depend on x)
   !!! T,n,u_0 must be the same size !!!
   real (DP), dimension (:), intent (in) :: u,v,w    ! value of the velocity variable
   real (DP), dimension (size(T),size(u))  :: y ! value of the dencity for this values of u and T
!!!
   real (DP), dimension (size(T))  :: beta ! local variable  to keep temporary results
   integer (I4B) :: i ! local counter
!!!
beta=sqrt(pi25DT*T)*(pi25DT*T)
do i=1,size(u)
y(:,i) = n*exp(-((u(i)-u_0)*(u(i)-u_0)+(v(i)-v_0)*(v(i)-v_0)+&
                  (w(i)-w_0)*(w(i)-w_0))/max(T,0.0000001_DP))/beta
end do
end function maxwelveldist_T_vector_u_vectors

! this is the copy when T is vector and u is scalar
function maxwelveldist_T_vector (T,u_0,v_0,w_0,n,u,v,w) result (y)
   real (DP), dimension (:), intent (in) :: T    ! temperature parameter (may depend on x)
   real (DP), dimension (:), intent (in) :: n    ! density parameter (may depend on x)
   real (DP), dimension (:), intent (in) :: u_0, v_0,w_0  ! average velocity (may depend on x)
   !!! T,n,u_0 must be the same size !!!
   real (DP), intent (in) :: u,v,w    ! value of the velocity variable
   real (DP), dimension (size(T))  :: y ! value of the dencity for this values of u and T
!!!
   real (DP), dimension (size(T))  :: beta ! local variable  to keep temporary results
beta=sqrt(pi25DT*T)*(pi25DT*T)
y = n*exp(-((u-u_0)*(u-u_0)+(v-v_0)*(v-v_0)+&
                  (w-w_0)*(w-w_0))/max(T,0.0000001_DP))/beta
end function maxwelveldist_T_vector

! this is the copy when T is scalar and u is vector
function maxwelveldist_u_vectors (T,u_0,v_0,w_0,n,u,v,w) result (y)
   real (DP), intent (in) :: T    ! temperature parameter (scalar)
   real (DP), intent (in) :: u_0,v_0,w_0  ! average velocity (scalar)
   real (DP), intent (in) :: n    ! density parameter (scalar)
   real (DP), dimension (:), intent (in) :: u,v,w    ! values of the velocity variable
   real (DP), dimension (size(u))  :: y ! value of the dencity for this values of u and T
!!!
   real (DP)  :: beta ! local variable  to keep temporary results
beta=sqrt(pi25DT*T)*(pi25DT*T)
y = n*exp(-((u-u_0)*(u-u_0)+(v-v_0)*(v-v_0)+&
                  (w-w_0)*(w-w_0))/max(T,0.0000001_DP))/beta
end function maxwelveldist_u_vectors

! this is the copy when both T and u are scalars
function maxwelveldist (T,u_0,v_0,w_0,n,u,v,w) result (y)
   real (DP), intent (in) :: T    ! temperature parameter (may depend on x)
   real (DP), intent (in) :: u_0,v_0,w_0  ! average velocity (scalar)
   real (DP), intent (in) :: n    ! density parameter (scalar)
   real (DP), intent (in) :: u,v,w    ! value of the velocity variable
   real (DP)  :: y ! value of the dencity for this values of u and T
!!!
   real (DP)  :: beta ! local variable  to keep temporary results
beta=sqrt(pi25DT*T)*(pi25DT*T)
y = n*exp(-((u-u_0)*(u-u_0)+(v-v_0)*(v-v_0)+&
                  (w-w_0)*(w-w_0))/max(T,0.0000001_DP))/beta
end function maxwelveldist

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! fade(x)
!
! this functions make the fading coefficient.
! if x <  x1 it returns 1
! if x >  x2 it returns 0
! otherwise, it returns
!
! x1 and x2 are constants of the module....
!!!!!!!!!!!!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

function fade (x) result (y)
real (DP), intent (in) :: x  ! the value of the variable
real (DP) :: y
!!!!!!!!!!!!!!!!!!
y = 1
if (x .ge. x1) then
 if (x .ge. x2) then
 y=0
 else
 y=(x2-x)/(x2-x1)
 end if
end if
!!!!!!!!!!!!!!!!!!
end function fade

function fade_x_vector (x) result (y)
real (DP), dimension (:), intent (in) :: x  ! the value of the variable
real (DP), dimension (size(x)) :: y
!
integer (I4B) :: i
!!!!!!!!!!!!!!!!!!
y = 1
do i=1,size(x)
if (x(i) .ge. x1) then
 if (x(i) .ge. x2) then
 y(i)=0
 else
 y(i)=(x2-x(i))/(x2-x1)
 end if
end if
end do
!!!!!!!!!!!!!!!!!!
end function fade_x_vector

end module sf02