	FUNCTION BH_IX_SED(J,X,F,N)

c	Computes value of Brodie and Hanes (1986) index J directly from sed
c	Follows procedure outlined by Brodie and Hanes (1986, ApJ 300, 258)
c	See their eqs. 1-2, and Table 2 in pag. 260.

c	J = Index identification
c	X = wavelength scale
c	F = flux scale (sed)
c	N = dimension of X, F
c	BH_IX_SED = index measured directly from sed.

c	Array declaration
	character*40 idxlbl
	real x(n),f(n),w(4)
	parameter (jid=35)
	integer iim(jid)
	real ffb(jid),ffr(jid),ffc(jid),ffl(jid)
	common /fluxes/ iim,ffb,ffr,ffc,ffl

c	Define wavelength range for selected index
	if (j.eq.1) then
		idxlbl = 'Delta (UV Blanketing)'
		w(1) = 3800.
		w(2) = 4000.
		w(3) = 4000.
		w(4) = 4200.
c		Mean flux through red window
       		fr=trapz3(x,f,n,w(3),w(4),ierr)
c		Mean flux through blue window
       		fb=trapz3(x,f,n,w(1),w(2),ierr)
c		Compute index 1
		bh_ix_sed = 2.5 * alog10(fr/fb)
		return
	elseif (j.eq.2) then
		idxlbl = 'H10 (Balmer line)'
		w(1) = 3785.
		w(2) = 3795.
		w(3) = 3810.
		w(4) = 3825.
	elseif (j.eq.3) then
		idxlbl = 'H9 (Balmer line)'
		w(1) = 3810.
		w(2) = 3825.
		w(3) = 3850.
		w(4) = 3865.
	elseif (j.eq.4) then
		idxlbl = 'Hpsi (Balmer line)'
		w(1) = 3865.
		w(2) = 3885.
		w(3) = 3910.
		w(4) = 3925.
	elseif (j.eq.5) then
		idxlbl = 'CN (UV cyanogen)'
		w(1) = 3785.
		w(2) = 3810.
		w(3) = 3910.
		w(4) = 3925.
	elseif (j.eq.6) then
		idxlbl = 'HK index (Ca II H and K lines)'
		w(1) = 3910.
		w(2) = 3925.
		w(3) = 3995.
		w(4) = 4015.
	elseif (j.eq.7) then
		idxlbl = 'Hdelta (Balmer line)'
		w(1) = 4075.
		w(2) = 4090.
		w(3) = 4125.
		w(4) = 4140.
	elseif (j.eq.8) then
		idxlbl = 'Ca (Ca I line)'
		w(1) = 4200.
		w(2) = 4215.
		w(3) = 4245.
		w(4) = 4260.
	elseif (j.eq.9) then
		idxlbl = 'G (CH G band)'
		w(1) = 4275.
		w(2) = 4285.
		w(3) = 4315.
		w(4) = 4325.
	elseif (j.eq.10) then
		idxlbl = 'Hgamma (Balmer line)'
		w(1) = 4315.
		w(2) = 4325.
		w(3) = 4360.
		w(4) = 4375.
	elseif (j.eq.11) then
		idxlbl = 'Hbeta (Balmer line)'
		w(1) = 4800.
		w(2) = 4830.
		w(3) = 4890.
		w(4) = 4920.
	elseif (j.eq.12) then
		idxlbl = 'Mg (Mg b triplet)'
		w(1) = 5125.
		w(2) = 5150.
		w(3) = 5195.
		w(4) = 5220.
	elseif (j.eq.13) then
		idxlbl = 'MH (Mg b + MgH)'
		w(1) = 4740.
		w(2) = 4940.
		w(3) = 5350.
		w(4) = 5550.
	elseif (j.eq.14) then
		idxlbl = 'FC (Fe I + Ca I)'
		w(1) = 5225.
		w(2) = 5250.
		w(3) = 5280.
		w(4) = 5305.
	elseif (j.eq.15) then
		idxlbl = 'Na (Na D lines)'
		w(1) = 5385.
		w(2) = 5865.
		w(3) = 5920.
		w(4) = 5950.
	elseif (j.eq.16) then
		idxlbl = 'FTC (Fe I + TiO + Ca I)'
		w(1) = 5950.
		w(2) = 6100.
		w(3) = 6330.
		w(4) = 6480.
	elseif (j.eq.17) then
		idxlbl = 'Halpha (Balmer line)'
		w(1) = 6480.
		w(2) = 6615.
		w(3) = 6575.
		w(4) = 6610.
	else
		write (6,*) 'Undefined BH index'
		bh_ix_sed = 999.99
	endif

c	Compute index according to BH definition
c	Mean flux through blue window
       	fb=trapz3(x,f,n,w(1),w(2),ierr)/(w(2)-w(1))
c	Mean flux through red window
       	fr=trapz3(x,f,n,w(3),w(4),ierr)/(w(4)-w(3))
c	Mean flux through central window
       	fc=trapz3(x,f,n,w(2),w(3),ierr)/(w(3)-w(2))
c	Compute index
	bh_ix_sed = 1.0 - 2.0*fc/(fb+fr)

c	Store values for HK index (Ca II H and K lines)
	if (j.eq.6) then
		iim(35)=1
		ffb(35)=fb
		ffr(35)=fr
		ffc(35)=fc
c		fl is not defined for this index
c		ffl(35)=fl
		ffl(35)=0.
	endif
	return
	end


      implicit none
      integer ns,nt,nd
      double precision, allocatable :: source(:,:),targ(:,:)
      double complex, allocatable :: charge(:,:),dipstr(:,:)
      real *8, allocatable :: dipvec(:,:,:)
      double complex, allocatable :: pot(:,:)
      double complex, allocatable :: pottarg(:,:)

      double precision eps
      double complex eye,zk
      integer i,j,k,idim,ier
      double precision hkrand,pi,thet,phi,t1,t2,omp_get_wtime

      data eye/(0.0d0,1.0d0)/

      pi = 4.0d0*atan(1.0d0)

c
cc      initialize printing routine
c
      call prini(6,13)
      write(*,*)
      write(*,*)
      write(*,*) "================================="
      call prin2("This code is an example fortran driver*",i,0)
      call prin2("On output, the code prints sample pot,pottarg*",i,0)
      write(*,*)
      write(*,*)

      zk = 2.2d0

      ns = 1600
      nt = 62500

      nd = 1

      allocate(source(2,ns))
      allocate(targ(2,nt))
      allocate(charge(nd,ns))
      allocate(dipstr(nd,ns))
      allocate(dipvec(nd,2,ns))
      allocate(pot(nd,ns))
      allocate(pottarg(nd,nt))

      eps = 0.51d-6

      write(*,*) "=========================================="

c
c
c       example demonstrating use of
c        source to source+targ, charges+dipoles, pot
c

c
cc      generate sources uniformly on the sphere
c
c
      do i=1,ns
        thet = hkrand(0)*pi
        phi = hkrand(0)*2*pi
        source(1,i) = sin(thet)*cos(phi)
        source(2,i) = sin(thet)*sin(phi)

        do idim=1,nd
          charge(idim,i) = hkrand(0) + eye*hkrand(0)
          dipstr(idim,i) = hkrand(0) + eye*hkrand(0)
          dipvec(idim,1,i) = hkrand(0)
          dipvec(idim,2,i) = hkrand(0)
          pot(idim,i) = 0
        enddo
      enddo

      do i=1,nt
        targ(1,i) = -3.0d0 + hkrand(0)*6.0d0
        targ(2,i) = -3.0d0 + hkrand(0)*6.0d0

        do idim=1,nd
          pottarg(idim,i) = 0
        enddo
      enddo

       call cpu_time(t1)
C$       t1 = omp_get_wtime()

       call hfmm2d_t_cd_p(eps,zk,ns,source,charge,
     1      dipstr,dipvec,nt,targ,pottarg,ier)

       call cpu_time(t2)
C$       t2 = omp_get_wtime()

       call prin2('time taken=*',t2-t1,1)
       call prin2("potential at targets=*",pottarg,12)

      stop
      end
c----------------------------------------------------------
c
cc
c
c


!     CalculiX - A 3-dimensional finite element program
!     Copyright (C) 1998-2021 Guido Dhondt
!
!     This program is free software; you can redistribute it and/or
!     modify it under the terms of the GNU General Public License as
!     published by the Free Software Foundation(version 2);
!
!
!     This program is distributed in the hope that it will be useful,
!     but WITHOUT ANY WARRANTY; without even the implied warranty of
!     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
!     GNU General Public License for more details.
!
!     You should have received a copy of the GNU General Public License
!     along with this program; if not, write to the Free Software
!     Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
!
      subroutine characteristiclength(co,istartcrackfro,iendcrackfro,
     &     ncrack,ifront,charlen,datarget)
!
!     determine the mesh characteristic length for each front
!
      implicit none
!
      integer i,k,m,n1,n2,istartcrackfro(*),iendcrackfro(*),
     &     ncrack,ifront(*)
!
      real*8 co(3,*),dist,sum,charlen(*),datarget
!
!     first increment: determine for each front a characteristic length
!
      do i=1,ncrack
!
!     loop over all nodes belonging to the crack front(s)
!
        k=0
        sum=0
        do m=istartcrackfro(i),iendcrackfro(i)-1
!
!     distance between two adjacent front nodes
!
          n1=ifront(m)
          n2=ifront(m+1)
          dist=dsqrt((co(1,n2)-co(1,n1))**2+
     &         (co(2,n2)-co(2,n1))**2+
     &         (co(3,n2)-co(3,n2))**2)
          k=k+1
          sum=(sum*(k-1)+dist)/k
        enddo
!
!     charlen is the mean distance between front nodes for each front
!     however, charlen should not be smaller than the target crack
!     propagation increment (favorizes smooth surfaces)
!
        charlen(i)=max(datarget,sum)
      enddo
!
      return
      end


program catalog_no21

  integer,parameter :: n=139, KB=8, IB=8

  real*8 a(n, n), b(n, n), c(n, n)

  do kk=1,n,KB
  do ii=1,n,IB
  do j=1,n,4
     do k=kk,min(n,kk+KB-1),4
        do i=ii,min(n,ii+IB-1)
           a(i,j) = a(i,j) + b(i,k)*c(k,j) &
                          + b(i,k+1)*c(k+1,j) &
                          + b(i,k+2)*c(k+2,j) &
                          + b(i,k+3)*c(k+3,j)
           a(i,j+1) = a(i,j+1) + b(i,k)*c(k,j+1) &
                          + b(i,k+1)*c(k+1,j+1) &
                          + b(i,k+2)*c(k+2,j+1) &
                          + b(i,k+3)*c(k+3,j+1)
           a(i,j+2) = a(i,j+2) + b(i,k)*c(k,j+2) &
                          + b(i,k+1)*c(k+1,j+2) &
                          + b(i,k+2)*c(k+2,j+2) &
                          + b(i,k+3)*c(k+3,j+2)
           a(i,j+3) = a(i,j+3) + b(i,k)*c(k,j+3) &
                          + b(i,k+1)*c(k+1,j+3) &
                          + b(i,k+2)*c(k+2,j+3) &
                          + b(i,k+3)*c(k+3,j+3)
         end do
      end do
   end do
   end do
   end do

end program catalog_no21


subroutine plcd_LineSearch(a,OptimalStepSize)
   use typre
   use Mod_PLCD
   implicit none
   class(PLCDProblem), target :: a
   real(rp):: OptimalStepSize

   real(rp) :: Residual(2)
   integer(ip) :: LineSearchiterations = 1
   real(rp) :: Chi(2)
   real(rp) :: Alpha_parameter = 0.0_rp
   interface
      subroutine plcd_ComputeResidual(a,Chi,Residual)
         import
         implicit none
         class(PLCDProblem), target :: a
         real(rp) :: Chi,Residual
      end subroutine
   end interface

   a%kfl_InternalLineSearchLoop = 1
   a%Displacement(:,:,2) = a%Displacement(:,:,1)

   Chi(1) = 0.0_rp
   Chi(2) = 100.0_rp

   call plcd_ComputeResidual(a,Chi(1),Residual(1))

   if (Residual(1) .GT. 0.0_rp) then
      Residual(1) = - Residual(1)
      a%unkno = - a%unkno
   endif

   call plcd_ComputeResidual(a,Chi(2),Residual(2))

   LineSearchiterations = 1

   do while (abs(Residual(2)) > a%LineSearchRadiusOfConvergence*abs(Residual(1)) .AND. LineSearchiterations .LE. a%LineSearchMaxIterations)

      Alpha_parameter = Residual(1) / Residual(2)

      if (Alpha_parameter .LT. 0.0_rp) then
         Chi(2) = Alpha_parameter/2.0_rp + sqrt((Alpha_parameter/2.0_rp)*(Alpha_parameter/2.0_rp)-Alpha_parameter)
      else
         Chi(2) = Alpha_parameter/2.0_rp
      endif

      call plcd_ComputeResidual(a,Chi(2),Residual(2))

      LineSearchiterations = LineSearchiterations + 1

   enddo

   if (LineSearchiterations .GE. a%LineSearchMaxIterations) then
      OptimalStepSize = 1.0_rp
   else
      OptimalStepSize = Chi(2)
   endif
   a%kfl_InternalLineSearchLoop = 0
   a%Displacement(:,:,1) = a%Displacement(:,:,2)
   a%Displacement(:,:,2) = 0.0_rp

 end subroutine

subroutine plcd_ComputeResidual(a,Chi,Residual)
   use typre
   use Mod_PLCD
   implicit none
   class(PLCDProblem), target :: a
   real(rp) :: Chi, Residual
   integer(ip) :: ndime, idime, npoin

   interface
      subroutine plcd_ComputeForcesVectors(a)
         use typre
         use Mod_PLCD
         implicit none
         class(PLCDProblem) :: a
      end subroutine
   end interface

   call a%Mesh%GetNdime(ndime)
   call a%Mesh%GetNpoin(npoin)

   a%Displacement(:,:,1) = a%Displacement(:,:,1) + Chi*a%unkno(1:ndime,:)
   call plcd_ComputeForcesVectors(a)
   Residual = 0.0_rp
   do idime = 1,ndime
      Residual = Residual + dot_product(a%unkno(idime,1:npoin),-a%ResidualForcesVector(idime,1:npoin))
   enddo
   a%Displacement(:,:,1) = a%Displacement(:,:,2)

end subroutine


#include "AMYCAI.h"

SUBROUTINE DALPAOS_SETTINGS
    USE FloatPrecision
    USE Grids
    USE Topography
    USE Parameters
    USE ArraySize
    IMPLICIT NONE

! volumetric
    SSC_CONST = SSC_CONST / RHOS
    QE0 = QE0 / RHOS

! LBFC  Lateral Bedload flux coefficient
#ifndef ARTIFICIAL_LBFC

    IF(D50<Dsand) THEN
        LBFC = 1.D0/18.D0*Dsand*D50**(-0.1D0)*(REDY*GRA)**(0.4D0)*Ki_Visc**(0.2D0) * Pbl
    ELSE
        LBFC = 1.D0/18.D0*D50  *D50**(-0.1D0)*(REDY*GRA)**(0.4D0)*Ki_Visc**(0.2D0) * Pbl
    ENDIF

#endif
! CTAUB
    Dasterisk = (REDY*GRA/Ki_Visc**2)**(1.D0/3.D0)*D50
    IF(D50 < Dsand) THEN
        ! van Rijn 2007
        IF(Dasterisk < 4.D0) THEN
            CTAUB = 0.115D0*Dasterisk**(-0.5D0)*(RHOS-RHOW)*GRA*D50*(Dsand/D50)
        ELSE
            CTAUB = 0.14D0*Dasterisk**(-0.64D0)*(RHOS-RHOW)*GRA*D50*(Dsand/D50)
        ENDIF
    ELSE
        IF(Dasterisk < 4.D0) THEN
            CTAUB = 0.115D0*Dasterisk**(-0.5D0)*(RHOS-RHOW)*GRA*D50*(1.D0+Pcs)**3
        ELSE
            CTAUB = 0.14D0*Dasterisk**(-0.64D0)*(RHOS-RHOW)*GRA*D50*(1.D0+Pcs)**3
        ENDIF
    ENDIF
    ! soulsby 1997
    !CTAUB = GRA*(RHOS-RHOW)*D50*(0.3D0/(1.D0+1.2D0*Dasterisk)+0.055D0*(1.D0-dexp(-0.02D0*Dasterisk)))

    CTAUB = CTAUE

! ctaub

! radian
    AVARA = AVARA * PI / 180.D0

END SUBROUTINE DALPAOS_SETTINGS

SUBROUTINE IKEDA_SETTINGS
    USE FloatPrecision
    USE Grids
    USE Topography
    USE Parameters
    USE ArraySize
    IMPLICIT NONE

! volumetric
    SSC_CONST = SSC_CONST / RHOS

! LBFC  Lateral Bedload flux coefficient
    LBFC = 1.D0/18.D0*Dsand*D50**(-0.1D0)*(REDY*GRA)**(0.4D0)*Ki_Visc**(0.2D0)

! radian
    AVARA = AVARA * PI / 180.D0

! rhoRsgd
    rhoRsgd = RHOW*REDY*GRA*D50

! QE0
    QE0 = 0.001D0 / D50 / GRA / WS / RHOW**2 / REDY*0.001D0

! LBFC  Lateral Bedload flux coefficient
    LBFC = 1.85D0 / D50**(1.5D0) / GRA**(1.5D0) / RHOW**2 / REDY**(1.5D0)*0.001D0

END SUBROUTINE IKEDA_SETTINGS


!
!     CalculiX - A 3-dimensional finite element program
!              Copyright (C) 1998-2020 Guido Dhondt
!
!     This program is free software; you can redistribute it and/or
!     modify it under the terms of the GNU General Public License as
!     published by the Free Software Foundation(version 2);
!
!
!     This program is distributed in the hope that it will be useful,
!     but WITHOUT ANY WARRANTY; without even the implied warranty of
!     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
!     GNU General Public License for more details.
!
!     You should have received a copy of the GNU General Public License
!     along with this program; if not, write to the Free Software
!     Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
!
      subroutine shape9q(xi,et,xl,xsj,xs,shp,iflag)
!
!     shape functions and derivatives for a 9-node quadratic
!     isoparametric quadrilateral element. -1<=xi,et<=1
!
!     iflag=1: calculate only the value of the shape functions
!     iflag=2: calculate the value of the shape functions,
!              their derivatives w.r.t. the local coordinates
!              and the Jacobian vector (local normal to the
!              surface)
!     iflag=3: calculate the value of the shape functions, the
!              value of their derivatives w.r.t. the global
!              coordinates and the Jacobian vector (local normal
!              to the surface)
!     iflag=4: calculate the value of the shape functions, the
!              value of their 1st and 2nd order derivatives
!              w.r.t. the local coordinates, the Jacobian vector
!              (local normal to the surface)
!
      implicit none
!
      integer i,j,k,iflag
!
      real*8 shp(7,9),xs(3,7),xsi(2,3),xl(3,9),sh(3),xsj(3),xi,et,
     &  fxi1,fxi2,fxi3,fet1,fet2,fet3,dfxi1,dfxi2,dfxi3,dfet1,dfet2,
     &  dfet3,ddfxi1,ddfxi2,ddfxi3,ddfet1,ddfet2,ddfet3
!
!
!
!     shape functions and their glocal derivatives for an element
!     described with two local parameters and three global ones.
!
!     shape functions in one dimension
!
      fxi1=xi*(xi-1.d0)/2.d0
      fxi2=(1.d0-xi)*(1.d0+xi)
      fxi3=xi*(xi+1.d0)/2.d0
!
      fet1=et*(et-1.d0)/2.d0
      fet2=(1.d0-et)*(1.d0+et)
      fet3=et*(et+1.d0)/2.d0
!
!     shape functions
!
      shp(4,1)=fxi1*fet1
      shp(4,2)=fxi3*fet1
      shp(4,3)=fxi3*fet3
      shp(4,4)=fxi1*fet3
      shp(4,5)=fxi2*fet1
      shp(4,6)=fxi3*fet2
      shp(4,7)=fxi2*fet3
      shp(4,8)=fxi1*fet2
      shp(4,9)=fxi2*fet2
!
      if(iflag.eq.1) return
!
!     derivative of the shape functions in one dimension
!
      dfxi1=(2.d0*xi-1.d0)/2.d0
      dfxi2=-2.d0*xi
      dfxi3=(2.d0*xi+1.d0)/2.d0
!
      dfet1=(2.d0*et-1.d0)/2.d0
      dfet2=-2.d0*et
      dfet3=(2.d0*et+1.d0)/2.d0
!
!     local derivatives of the shape functions: xi-derivative
!
      shp(1,1)=dfxi1*fet1
      shp(1,2)=dfxi3*fet1
      shp(1,3)=dfxi3*fet3
      shp(1,4)=dfxi1*fet3
      shp(1,5)=dfxi2*fet1
      shp(1,6)=dfxi3*fet2
      shp(1,7)=dfxi2*fet3
      shp(1,8)=dfxi1*fet2
      shp(1,9)=dfxi2*fet2
!
!     local derivatives of the shape functions: eta-derivative
!
      shp(2,1)=fxi1*dfet1
      shp(2,2)=fxi3*dfet1
      shp(2,3)=fxi3*dfet3
      shp(2,4)=fxi1*dfet3
      shp(2,5)=fxi2*dfet1
      shp(2,6)=fxi3*dfet2
      shp(2,7)=fxi2*dfet3
      shp(2,8)=fxi1*dfet2
      shp(2,9)=fxi2*dfet2
!
!     computation of the local derivative of the global coordinates
!     (xs)
!
      do i=1,3
        do j=1,2
          xs(i,j)=0.d0
          do k=1,9
            xs(i,j)=xs(i,j)+xl(i,k)*shp(j,k)
          enddo
        enddo
      enddo
!
!     computation of the jacobian vector
!
      xsj(1)=xs(2,1)*xs(3,2)-xs(3,1)*xs(2,2)
      xsj(2)=xs(1,2)*xs(3,1)-xs(3,2)*xs(1,1)
      xsj(3)=xs(1,1)*xs(2,2)-xs(2,1)*xs(1,2)
!
      if(iflag.eq.3) then
!
!     computation of the global derivative of the local coordinates
!     (xsi) (inversion of xs)
!
         if(dabs(xsj(3)).gt.1.d-10) then
            xsi(1,1)=xs(2,2)/xsj(3)
            xsi(2,2)=xs(1,1)/xsj(3)
            xsi(1,2)=-xs(1,2)/xsj(3)
            xsi(2,1)=-xs(2,1)/xsj(3)
            if(dabs(xsj(2)).gt.1.d-10) then
               xsi(2,3)=xs(1,1)/(-xsj(2))
               xsi(1,3)=-xs(1,2)/(-xsj(2))
            elseif(dabs(xsj(1)).gt.1.d-10) then
               xsi(2,3)=xs(2,1)/xsj(1)
               xsi(1,3)=-xs(2,2)/xsj(1)
            else
               xsi(2,3)=0.d0
               xsi(1,3)=0.d0
            endif
         elseif(dabs(xsj(2)).gt.1.d-10) then
            xsi(1,1)=xs(3,2)/(-xsj(2))
            xsi(2,3)=xs(1,1)/(-xsj(2))
            xsi(1,3)=-xs(1,2)/(-xsj(2))
            xsi(2,1)=-xs(3,1)/(-xsj(2))
            if(dabs(xsj(1)).gt.1.d-10) then
               xsi(1,2)=xs(3,2)/xsj(1)
               xsi(2,2)=-xs(3,1)/xsj(1)
            else
               xsi(1,2)=0.d0
               xsi(2,2)=0.d0
            endif
         else
            xsi(1,2)=xs(3,2)/xsj(1)
            xsi(2,3)=xs(2,1)/xsj(1)
            xsi(1,3)=-xs(2,2)/xsj(1)
            xsi(2,2)=-xs(3,1)/xsj(1)
            xsi(1,1)=0.d0
            xsi(2,1)=0.d0
         endif
!
!     computation of the global derivatives of the shape functions
!
         do k=1,9
            do j=1,3
               sh(j)=shp(1,k)*xsi(1,j)+shp(2,k)*xsi(2,j)
            enddo
            do j=1,3
               shp(j,k)=sh(j)
            enddo
         enddo
!
      elseif(iflag.eq.4) then
!
!     second derivative of the shape functions in one dimension
!
         ddfxi1=1.d0
         ddfxi2=-2.d0
         ddfxi3=1.d0
!
         ddfet1=1.d0
         ddfet2=-2.d0
         ddfet3=1.d0
!
!     local 2nd order derivatives of the shape functions: xi,xi-derivative
!
         shp(5,1)=ddfxi1*fet1
         shp(5,2)=ddfxi3*fet1
         shp(5,3)=ddfxi3*fet3
         shp(5,4)=ddfxi1*fet3
         shp(5,5)=ddfxi2*fet1
         shp(5,6)=ddfxi3*fet2
         shp(5,7)=ddfxi2*fet3
         shp(5,8)=ddfxi1*fet2
         shp(5,9)=ddfxi2*fet2
!
!     local 2nd order derivatives of the shape functions: xi,eta-derivative
!
         shp(6,1)=dfxi1*dfet1
         shp(6,2)=dfxi3*dfet1
         shp(6,3)=dfxi3*dfet3
         shp(6,4)=dfxi1*dfet3
         shp(6,5)=dfxi2*dfet1
         shp(6,6)=dfxi3*dfet2
         shp(6,7)=dfxi2*dfet3
         shp(6,8)=dfxi1*dfet2
         shp(6,9)=dfxi2*dfet2
!
!     local 2nd order derivatives of the shape functions: eta,eta-derivative
!
         shp(7,1)=fxi1*ddfet1
         shp(7,2)=fxi3*ddfet1
         shp(7,3)=fxi3*ddfet3
         shp(7,4)=fxi1*ddfet3
         shp(7,5)=fxi2*ddfet1
         shp(7,6)=fxi3*ddfet2
         shp(7,7)=fxi2*ddfet3
         shp(7,8)=fxi1*ddfet2
         shp(7,9)=fxi2*ddfet2
!
!     computation of the local 2nd derivatives of the global coordinates
!     (xs)
!
         do i=1,3
            do j=5,7
               xs(i,j)=0.d0
               do k=1,9
                  xs(i,j)=xs(i,j)+xl(i,k)*shp(j,k)
               enddo
            enddo
         enddo
      endif
!
      return
      end


c=======================================================================
c
c     subroutine PEGBMX
c
c     Simulation of a Multidimentional Geometric Brownian Motion
c
c               dSt = St*[mu*dt + sigma*dWt]
c
c     Method: Euler discretization of SDE
c
c                S(1)    = S
c                S(1+t)  = S(t)*[1 + mu*dt +  sigma*sqrt(dt)*N(0,1)]
c
c                with dt = T/(N-1)
c
c-----------------------------------------------------------------------
      SUBROUTINE pegbmx ( p, T, N, S, mu, cov, iwork, dwork, y, info )
c-----------------------------------------------------------------------
c
c     INPUT
c       p          : number of element(s) (p > 1)                integer
c       T          : time (days, months, years)                  integer
c       N          : number of steps to maturity                 integer
c       S[p]       : initial values, (p)                          double
c       mu[p]      : process drift (p)                            double
c       cov[p,p]   : covariance matrix (p*p)                      double
c
c     WORKSPACE
c       iwork      : 12*p                                        integer
c       dwork      : p(5*p + 31)                                  double
c
c     OUTPUT
c       y[N+1,p]   : generated step, matrix(N*p)                  double
c       info       : diagnostic argument                         integer
c
c     CALL
c        YVLM      : copy a vector in a row of a vectorized matrix
c        GBMSTEP   : multidimensional GBM: dSt = mu*dt + chol(gamma)*dWt
c
c-----------------------------------------------------------------------
c
      IMPLICIT NONE
c
c     arguments i/o
      INTEGER p, T, N, info
      DOUBLE PRECISION S(*), mu(*), cov(*), y(N,*)
c
c     workspaces
      INTEGER iwork(*)
      DOUBLE PRECISION dwork(*)
c
c     local variables
      INTEGER pdstep, pdw, pdmu, pdcov, pichol, pdchol,
     &        i, k, ks
      DOUBLE PRECISION dt, sqrdt
c
c-----------------------------------------------------------------------
c
c     initializations
      info = 0
c
c     dt and sqrt(dt)
      dt    = (DFLOAT(T)/N)
      sqrdt = SQRT(dt)
c
c     pointers for integer workspace : iwork
c     --------------------------------------
      pichol = 1
c     pichol : pointer for CHOL dwork (12*p)
c
c     Total size of iwork array = 12*p
c
c     pointers for double precision work space : dwork
c     ------------------------------------------------
      pdstep = 1
c     pdstep : pointer for steps on each factor (p)
      pdmu   = pdstep + ( p )
c     pdmu   : pointer for mu*dt (p)
      pdcov  = pdmu + ( p )
c     pdcov  : pointer for Choleski matrix (p*p)
      pdchol = pdcov + ( p*p )
c     pdchol : pointer for CHOL dwork p(4*p + 27)
      pdw    = pdchol + ( p*( 4*p + 27 ))
c     pdw   : pointer for GBMSTEP workspaces (2*p)
c
c     Total size of dwork array =  p + p + p*p
c                               +  p(4*p + 27)
c                               + 2*p
c                               = p(5*p + 31)
c
c-----------------------------------------------------------------------
c
c     initialization of trails at initial price
      CALL YVLM ( N, p, y, S, 1, info )
c
c     process drift: mu*dt
      CALL PVX ( p, mu, dt, dwork(pdmu) )
c
c     Choleski decomposition of covariance matrix
c      CALL CHOL ( p, cov, dwork(pdchol), dwork(pdcov), info )
c      IF (info .LT. 0) RETURN
c
c     robust choleski decomposition of covariance matrix
      CALL rcho ( p, cov, iwork(pichol),
     &            dwork(pdchol), dwork(pdcov), info )
      IF (info .LT. 0) RETURN

c
c     GBM trails: S(t+1) = S(t)*[1 + mu*dt + chol(gamma)*dWt]
      DO i = 1,N-1
c
c        simulation step
         CALL GBMSTEP ( p, dwork(pdmu), dwork(pdcov), sqrdt, dwork(pdw),
     &                  dwork(pdstep))
c
c        price(n+1) = price(n)*(step+1)
         ks = pdstep
         DO k = 1,p
            y(i + 1,k) = y(i,k) * ( dwork(ks) + 1 )
            ks = ks + 1
         ENDDO
      ENDDO
c
      RETURN
      END


C
C
       real*4 function ct_enh_col( rgb, ci, cimin, cimax )
C      ---------------------------------------------------
C
C Function defining an enhanced colour-scale.
C
C defining:
C             x = (ci-cimin)/(cimax-cimin)
C then:
C   ct_enh_col = ((x-start_colour)/(upper_bound-lower_bound))**power_law
C
C for:
C  lower_bound,start_colour  <=  x  <=  upper_bound
C
C otherwise:
C   ct_enh_col = 0.0 or 1.0
C
C Where the parameters upper_bound, lower_bound and power_law are passed
C in common and depend on the colour index
*-

       include '../include/tv_modify.inc'

       integer        rgb, ci, cimin, cimax
       real*4         x

       x  = (float(ci-cimin)/float(cimax-cimin))
       if (x.ge.lower_bound .and. x.le.upper_bound) then
         if ((x-lower_bound).ge.col_starts(rgb)) then
           ct_enh_col = (       (x-col_starts(rgb))
     *                     /(upper_bound-col_starts(rgb))
     *                  )**col_power_law(rgb)
         else
           ct_enh_col = 0.0
         end if
       else if (x.lt.lower_bound) then
         ct_enh_col = 0.0
       else
         ct_enh_col = 1.0
       end if
       end


!^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^!^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
!^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^!^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
!! 3D oil reservoir Simulator project
!! by Mehrdad Gharib Shirangi From Spring 2010 until Fall 2010
!! mehrdad.ghsh@gmail.com
!! Copy Right by Mehrdad Gharib Shirangi
!^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^!^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
!^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^!^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^

Module Trans

! contains transmissibility functions
use globalvar
!!use  Derivative
!************************************************************************************************************************************************************
!                                                     Explanations

!************************************************************************************************************************************************************
implicit none

real*8 :: Dip_cor, & ! dip correction which is cos(theta)
          delax_avg , delay_avg ,  denomenator , press_term ! pressure dependent term
!!integer:: i1 , j1

contains
   real*8 function Transxb(i,j,k,m) ! the value of the transmissibility between a gridblock and a grid before that ! gridblock (i-1,j,k)\\
   integer :: Index , N_Index
   integer :: i,j,k
   Character*1 :: m
   real*8 :: Dip_cor, delax_avg, denomenator, press_term
   real*8 :: Press
      Index = (k-1) * Nx * Ny + (j-1) * Nx + i
      N_Index = Index - 1
      delax_avg = ( Deltax(i-1) + Deltax(i)) / 2.0
      Dip_cor = delax_avg ** 2 / ((Zblock(Index)-Zblock(Index-1)) ** 2 + delax_avg ** 2)
      denomenator = 1 / 2.0 * ( Deltax(i-1) / ( kx(Index-1) * Deltay(j) * Deltaz(Index-1) ) + Deltax(i)/( kx(Index)*Deltay(j)*Deltaz(Index) ) )

      if  ( D_Poten(Index , Index - 1 , m ) > 0 ) then ! (Potential(Index,m) > Potential(Index - 1,m) ) then ! upstream block
         if ( m == 'w') then
			press_term = k_rw(Index) / ( mu_w ( Index) * B_w(Index) )
         Else
			press_term = k_ro(Index) / ( mu_o ( Index) * B_o(Index) )
         EndIf
      else
         if (m == 'w') then
			press_term = k_rw(N_Index) / ( mu_w ( N_Index) * B_w( N_Index ) )
         Else
			press_term = k_ro(N_Index) / ( mu_o ( N_Index) * B_o( N_Index ) )
         EndIf
      Endif
      Transxb = betac * Dip_cor * press_term /denomenator
   endfunction Transxb
!***************************************
   real*8 function Transxa(i,j,k,m)
   integer :: Index , N_Index
   integer :: i,j,k
   Character*1 :: m
   real*8 :: Dip_cor, delax_avg, denomenator, press_term
   real*8 :: Press
      Index = (k-1) * Nx * Ny + (j-1) * Nx + i
      N_Index = Index + 1
      delax_avg = (Deltax(i+1) + Deltax(i)) / 2.0
      Dip_cor = delax_avg ** 2 / ((Zblock(Index)-Zblock(Index+1)) ** 2 + delax_avg ** 2)
      denomenator = 1 / 2.0 *( Deltax(i+1)/(kx(Index+1)* Deltay(j)*Deltaz(Index+1)) + Deltax(i)/(kx(Index)*Deltay(j)*Deltaz(Index)) )

      if ( D_Poten(Index , Index + 1 , m ) > 0 ) then ! upstream block
         if ( m == 'w') then
			press_term = k_rw(Index) / ( mu_w ( Index) * B_w(Index) )
         Else
			press_term = k_ro(Index) / ( mu_o ( Index) * B_o(Index) )
         EndIf
      else
         if (m == 'w') then
			press_term = k_rw(N_Index) / ( mu_w ( N_Index) * B_w( N_Index ) )
         Else
			press_term = k_ro(N_Index) / ( mu_o ( N_Index) * B_o( N_Index ) )
         EndIf
      Endif
      Transxa = betac * Dip_cor * press_term /denomenator

   endfunction Transxa
!***************************************
   real*8 function Transyb(i,j,k,m) ! grid block (i,j-1,k)
   integer :: Index , N_Index
   integer :: i,j,k
   Character*1 :: m
   real*8 :: Dip_cor, delay_avg, denomenator, press_term
   real*8 :: Press

      Index = (k-1) * Nx * Ny + (j-1) * Nx + i
      N_Index = Index - Nx
      delay_avg = (Deltay(j-1) + Deltay(j)) / 2.0
      Dip_cor = delay_avg ** 2 / ( ( Zblock(Index)-Zblock(N_Index) )**2 + delay_avg ** 2)
      denomenator = 1 / 2.0 *( Deltay(j-1)/(ky(N_Index)* Deltax(i)*Deltaz(N_Index)) + Deltay(j)/(ky(Index)*Deltax(i)*Deltaz(Index)) )

      if ( D_Poten(Index , N_Index , m ) > 0 ) then ! upstream block
         if ( m == 'w') then
			press_term = k_rw(Index) / ( mu_w ( Index) * B_w(Index) )
         Else
			press_term = k_ro(Index) / ( mu_o ( Index) * B_o(Index) )
         EndIf
      else
         if (m == 'w') then
			press_term = k_rw(N_Index) / ( mu_w ( N_Index) * B_w( N_Index ) )
         Else
			press_term = k_ro(N_Index) / ( mu_o ( N_Index) * B_o( N_Index ) )
         EndIf
      Endif
      Transyb = betac * Dip_cor * press_term /denomenator
   endfunction Transyb
!***************************************
   real*8 function Transya(i,j,k,m) ! grid (i,j+1,k)
   integer :: Index , N_Index
   integer :: i,j,k
   Character*1 :: m
   real*8 :: Dip_cor, delay_avg, denomenator, press_term
   real*8 :: Press
      Index = (k-1) * Nx * Ny + (j-1) * Nx + i
      N_Index  = Index + Nx
      delay_avg = (Deltay(j+1) + Deltay(j))/2.0
      Dip_cor = delay_avg ** 2 / ((Zblock(Index)-Zblock( N_Index )) ** 2 + delay_avg ** 2)
      denomenator = 1 / 2.0 *( Deltay(j+1)/(ky( N_Index )* Deltax(i)*Deltaz( N_Index )) + Deltay(j)/(ky(Index)*Deltax(i)*Deltaz(Index)) )
      if ( D_Poten(Index , N_Index , m ) > 0 ) then ! upstream block
         if ( m == 'w') then
			press_term = k_rw(Index) / ( mu_w ( Index) * B_w(Index) )
         Else
			press_term = k_ro(Index) / ( mu_o ( Index) * B_o(Index) )
         EndIf
      else
         if (m == 'w') then
			press_term = k_rw(N_Index) / ( mu_w ( N_Index) * B_w( N_Index ) )
         Else
			press_term = k_ro(N_Index) / ( mu_o ( N_Index) * B_o( N_Index ) )
         EndIf
      Endif
      Transya = betac * Dip_cor * press_term /denomenator
   endfunction Transya
!***************************************
   real*8 function Transzb(i,j,k,m) ! gridblock (i,j,k-1)
   integer :: Index ,  N_Index
   integer :: i,j,k
   real*8 :: delaz_avg , Press
   Character*1 :: m
   real*8 :: denomenator, press_term
      Index = (k-1) * Nx * Ny + (j-1) * Nx + i
      N_Index  = Index - Nx * Ny
      denomenator = 1 / 2.0 *( Deltaz( N_Index )/(kz( N_Index )* Deltax(i)*Deltay(j)) + Deltaz(Index)/(kz(Index) * Deltax(i) * Deltay(j)) )
      if ( D_Poten(Index , N_Index , m ) > 0 ) then ! upstream block
         if ( m == 'w') then
			press_term = k_rw(Index) / ( mu_w ( Index) * B_w(Index) )
         Else
			press_term = k_ro(Index) / ( mu_o ( Index) * B_o(Index) )
         EndIf
      else
         if (m == 'w') then
			press_term = k_rw(N_Index) / ( mu_w ( N_Index) * B_w( N_Index ) )
         Else
			press_term = k_ro(N_Index) / ( mu_o ( N_Index) * B_o( N_Index ) )
         EndIf
      Endif
      Transzb = betac * press_term /denomenator
   endfunction Transzb
!***************************************
   real*8 function Transza(i,j,k,m) ! gridblock (i,j,k+1)
   integer :: Index , N_Index
   integer :: i,j,k
   real*8 :: delaz_avg , Press
   Character*1 :: m
   real*8 :: denomenator, press_term
      Index = (k-1) * Nx * Ny + (j-1) * Nx + i
      N_Index  = Index + Nx * Ny
      denomenator = 1 / 2.0 *( Deltaz( N_Index )/(kz( N_Index )* Deltax(i)*Deltay(j)) + Deltaz(Index)/(kz(Index)*Deltax(i)*Deltay(j)) )
      if ( D_Poten(Index , N_Index , m ) > 0 ) then ! upstream block
         if ( m == 'w') then
			press_term = k_rw(Index) / ( mu_w ( Index) * B_w(Index) )
         Else
			press_term = k_ro(Index) / ( mu_o ( Index) * B_o(Index) )
         EndIf
      else
         if (m == 'w') then
			press_term = k_rw(N_Index) / ( mu_w ( N_Index) * B_w( N_Index ) )
         Else
			press_term = k_ro(N_Index) / ( mu_o ( N_Index) * B_o( N_Index ) )
         EndIf
      Endif
      Transza = betac * press_term /denomenator
   endfunction Transza
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

   real*8 function Potential(iii,m)

   Character*1 :: m
   integer:: iii
      if ( m == 'o') then
          Potential = pressure(iii) - density(pressure(iii),m)/144.0 * (Zblock(iii))
      Else
          Potential = pressure(iii) - pco(iii) - density(pressure(iii),m)/144.0 * (Zblock(iii))
      Endif

   endfunction Potential
!##################################################
   subroutine initialize
   ! sets initial pressures according to depth
   Integer :: m ,n , alfa
   integer :: i,j,k , i6 , iWell, alfawell , ik , B_index
   Real :: Denom , term , Z

If (USEISW) then
	Sw = SWI
ELSE
    Do k = 1,Nz
       Do j=1,Ny
          Do i=1,Nx
             alfa = (k-1) * Nx * Ny + (j-1) * Nx + i
             n = size_table + 1
             m = 1
             z = Zblock(alfa)
             do while ( abs(n-m) > 1 )
                i6 = floor(m + (n - m + 1)/2.0)
                if (z < Z_table(i6) )  then
                    n =  i6 !floor(m2+(n2-m2+1)/2.0);
                else
                    m =  i6 !floor(m2+(n2-m2+1)/2.0);
                end if
             end do
             SW( alfa ) = Sw_table( m ) + ( Zblock(alfa) -  Z_table(m) ) / (  Z_table(n) - Z_table(m) ) * ( Sw_table(n) - Sw_table(m) )
          Enddo
       Enddo
    Enddo
EndIf

if (USEIP == 'YES') then
		PRESSURE = Initial_P
ELSE

    Do k = 1,Nz
       Do j=1,Ny
          Do i=1,Nx
             alfa = (k-1) * Nx * Ny + (j-1) * Nx + i
             n = size_table
             m = 1
             z = Zblock(alfa)
             do while ( abs(n-m) > 1 )
                i6 = floor(m + (n - m + 1)/2.0)
                if (z < Z_table(i6) )  then
                    n =  i6 !floor(m2+(n2-m2+1)/2.0);
                else
                    m =  i6 !floor(m2+(n2-m2+1)/2.0);
                end if
             end do
             pressure( alfa ) = Op_table( m ) + ( Zblock(alfa) -  Z_table(m) ) / (  Z_table(n) - Z_table(m) ) * ( Op_table(n) - Op_table(m) )
!!             SW( alfa ) = Sw_table( m ) + ( Zblock(alfa) -  Z_table(m) ) / (  Z_table(n) - Z_table(m) ) * ( Sw_table(n) - Sw_table(m) )

          Enddo
       Enddo
    Enddo
ENDIF

      ! putting pressure and Saturation values into YY vector
    Do k=1,Nz
       Do j=1,Ny
          Do i=1,Nx
              B_index = (k-1) * Nx * Ny + (j-1) * Nx + i ! B_index is the block number, while
              alfa = 2 * (B_index ) - 1                ! alfa is the location in the Jacobian Matrix , I will use B_index to point the Block Number and pressure of that Block
              YY(alfa) = pressure(B_index)
              YY(alfa + 1) = Sw(B_index)

              W_press(B_index) = Pressure(B_index) - PCO(B_index)

              k_ro(B_index) = k_r( B_index , 'o')
			  k_rw(B_index) = k_r( B_index , 'w')

              B_o(B_index) = B_f( pressure(B_index) , 'o')
			  B_w(B_index) = B_f( W_press(B_index) , 'w')

    		  mu_o(B_index) = mu_f ( pressure(B_index),'o')
			  mu_w(B_index) = mu_f ( W_press(B_index),'w')

          EndDO
       EndDO
    EndDO
!                Open(1,FILE='initial_pressure.DAT', status='unknown')
!                !Write(1,*) 'ptable values'
!                Do i = 1 , Ntotal
!                   Write(1,*) pressure(i) , Zblock(i)
!                EndDO
!                close(1)

            Do i = 1 , Ntotal
				W_press(i) = Pressure(i) - PCO(i)
            EndDO

   if (.NOT. USEIP == 'YES') then
       DeAllocate( OP_table )  ! Oil pressure
       DeAllocate( WP_table ) ! Water pressure
       DeAllocate( SW_table )
       DeAllocate( Z_table)
   EndIF

   Endsubroutine initialize
!##################################################

subroutine initialize_BHP
   ! sets initial BHP ; Not too precise but Calc_Delpwf will take care of it
   Integer :: alfa2  , alfa
   Integer :: i , j , i6 , iWell, alfawell  , B_index
   Real*8 :: Denom , term, pres
   integer :: i_well, i_k,  alfa_well , alfa_w , W_index , N_index
   !Real, Allocatable, Dimension(:) :: O_Volume, W_Volume , mix_den ! O_Volume is the vector of Volume of oil in each completion ( for dt = 1 day , and dp = 1 psi )
   integer :: con

    Do i_well = 1 , Nwell
        W_index = Ntotal + i_well  ! Pwf position in pressure vector
        if ( W_type(i_well) == 'prod') then
           if ( Schedule(i_well , 2 , sche_N) .EQ. 1 ) then ! oil rate is given
              !Do while (con == 0)
                  term = 0.0
                  Denom = 0.0
                  Do i_k = Well_k(i_well , 1) , Well_k(i_well ,2)
                     B_index = Well_loc(i_well,1) + ( Well_loc(i_well,2) - 1) * Nx + ( i_k - 1 ) * Nx * Ny
                     Denom = Denom + W_index_o(i_well,i_k)
                     term = term + W_index_o(i_well,i_k) * pressure(B_index)
                  EndDo
              !EndDo
              pressure(Ntotal + i_well) = ( term - Schedule(i_well,3,1) )/Denom
		   Elseif ( Schedule(i_well , 2 , sche_N) .EQ. 3 ) then ! Total Liquid rate is given
                  term = 0.0
                  Denom = 0.0
                  Do i_k = Well_k(i_well , 1) , Well_k(i_well ,2)
                     B_index = Well_loc(i_well,1) + ( Well_loc(i_well,2) - 1) * Nx + ( i_k - 1 ) * Nx * Ny
                     Denom = Denom + W_index_o(i_well,i_k)+ W_index_w(i_well,i_k)
                     term = term + (W_index_o(i_well,i_k) + W_index_w(i_well,i_k) )* pressure(B_index)
                  EndDo
              pressure(Ntotal + i_well) = ( term - Schedule(i_well,3,1) )/Denom
           Else ! BHP was specified
              pressure(Ntotal + i_well) = Schedule(i_well,3,1)
           EndIf
        Else ! injection Well
           if ( Schedule(i_well , 2 , sche_N) .EQ. 1 ) then ! water injection rate is given
                 term = 0.0
                 Denom = 0.0
              Do i_k = Well_k(i_well , 1) , Well_k(i_well ,2)
                 B_index = Well_loc(i_well,1) + ( Well_loc(i_well,2) - 1) * Nx + ( i_k - 1 ) * Nx * Ny
                 Denom = Denom + W_index_w(i_well,i_k)
                 term = term + W_index_w(i_well,i_k) * pressure(B_index)
              EndDo
              pressure(Ntotal + i_well) = ( term + Schedule(i_well,3,1) )/Denom
           Else ! constant BHP injection
              pressure(Ntotal + i_well) = Schedule(i_well,3,1)
           EndIf
        EndIf
        If (pressure(Ntotal + i_well) .LT. MINBHP) then
			pressure(Ntotal + i_well) = MINBHP
		ElseIf (pressure(Ntotal + i_well) .GT. MAXBHP) then
			pressure(Ntotal + i_well) = MAXBHP
		EndIf
    EndDo

   Do i=1, Nwell
      B_index = Ntotal + i ! B_index is the block number, while
      alfa = 2 * Ntotal + i                ! alfa is the location in the Jacobian Matrix , I will use B_index to point the Block Number and pressure of that Block
      YY(alfa) = pressure(B_index)
   EndDo

!                Open(1,FILE='initial_BHP.DAT', status='unknown')
!                !Write(1,*) 'ptable values'
!                Write(1,*) 'Well Pressure , 1st Block Pressure,    Oil Rate, '
!                Do i_well = 1 , Nwell
!                   B_index = Well_loc(i_well,1) + ( Well_loc(i_well,2) - 1) * Nx + ( Well_k(i_well , 1) - 1 ) * Nx * Ny
!                   Write(1,*) pressure(i_well) , Schedule(i_well,3,1)
!                EndDO
!                close(1)
   Endsubroutine initialize_BHP

!##################################################
   real*8 function mu_f(p1,m)
   real*8 :: p1
   Integer :: m1,n1 , i5
   Character*1 :: m

   if (m=='w') then
      mu_f = PVTW(4)
   else
        n1 = N_mup
        m1 = 1
        do while (abs(n1-m1).NE.1)
            i5 = floor(m1 + (n1-m1+1)/2.0)
            if (p1 < mu_p(i5,1) )  then
                n1 = floor(m1+(n1-m1+1)/2.0);
            else
                m1 = floor(m1+(n1-m1+1)/2.0);
            end if
        end do
        mu_f = mu_p(m1,2)+ (p1 -mu_p(m1,1))/(mu_p(n1,1)-mu_p(m1,1))*(mu_p(n1,2)-mu_p(m1,2));
   Endif

   Endfunction mu_f
!##################################################
   real*8 function B_f(p2,m)
   real*8 :: p2 , X
   Integer :: m2,n2 , i4
   Character*1 :: m

       if (m=='o') then
            n2 = N_Bo
            m2 = 1
!           m2 = N_Bo - 1
!           Do
!              if ( p2 > Bo_p(m2,1) )  then
!                 n2 = m2 + 1
!                 exit
!              Else
!                 m2 = m2 - 1
!              EndIf
!           EndDO

            do while (abs(n2-m2).NE. 1)
                i4 = FLOOR(m2 + (n2-m2+1)/2.0)
                if (p2 < Bo_p(i4,1) )  then
                    n2 = FLOOR(m2+(n2-m2+1)/2.0);
                else
                    m2 = FLOOR(m2+(n2-m2+1)/2.0);
                end if
            end do
            B_f = Bo_p(m2,2)+ (p2 -Bo_p(m2,1))/(Bo_p(n2,1)-Bo_p(m2,1))*(Bo_p(n2,2)-Bo_p(m2,2));
       Else
            X =  PVTW(3) * (p2 - PVTW(1) )
            B_f = PVTW(2) / ( 1 + X + ( X ** 2 )/2.0 )
       EndIf

   Endfunction B_f
   !##################################################
    real function density(p3,m)

    real*8 :: p3
    Character*1 :: m

        if (m=='o') then
            density = den_o / B_f(p3,'o')
        Else
            density = den_w / B_f(p3,'w')
        Endif
        ! WRITE(*,*) 'DENSITY=', density
        ! pause
    Endfunction density

    !##################################################
  subroutine ref_press_table

    implicit none

    real :: delta1
    real*8 :: c1 , c2 , CW1
    real :: maxdepth , mindepth , Delta
    integer :: j1,i1,ref_entry , up_length , down_length ,i , WOC_entry, j
   ! finding maximum depth
       maxdepth = 1.0
       do i1 = 1 , Ntotal
          !maxdepth = max( maxdepth , Zblock(i1) )
          maxdepth = max( maxdepth , TOPS(i1) + deltaz(i1) )
       End do

        mindepth = 100000
        do i1 = 1 , Ntotal
            mindepth = min( mindepth , TOPS(i1))
        End do
                                                        write (*,*) 'minimum depth = ',mindepth
                                                        write (*,*) 'maximum depth = ',maxdepth
                                                        write (*,*) 'ref depth was = ' , initialp(1)

       Delta = 0.05

       size_table = FLOOR((maxdepth - mindepth) / Delta) + 100

       Allocate( OP_table(size_table) )  ! Oil pressure
       Allocate( WP_table(size_table) ) ! Water pressure
       Allocate( SW_table(size_table) )
       Allocate( Z_table(size_table) )

       ref_entry = abs( FLOOR(( Datum_D - mindepth ) / Delta) ) + 50
       if ( Datum_D < OWC_depth ) then
          Write(*,*) 'The procedure is ok as , Datum_D =',Datum_D,' < ',OWC_depth , '= OWC_depth'
          !pause
       Else
          Write(*,*) 'Sorry, you should change the subroutine for Initial Table'
          write(*,*) 'Datum_D =', Datum_D
          write(*,*)  'OWC_depth=',OWC_depth
          !pause
       EndIf

       Z_table(ref_entry) = Datum_D
       Op_table(ref_entry) = Datum_P ! I supposed that the pressure here is Oil pressure, or in other words the Ref. Press is given above WOC

       up_length = size_table - ref_entry

       Do j1 = 1 , up_length
          Z_table(ref_entry + j1) = Z_table(ref_entry + j1 - 1 ) + Delta
          if  ( Z_table( ref_entry + j1 ) > OWC_depth ) then
             Z_table( ref_entry + j1 ) =  OWC_depth
             Delta = OWC_depth - z_table(ref_entry + j1 - 1 )
             c1 = Op_table( ref_entry + j1 - 1) + density( Op_table(ref_entry + j1 - 1) , 'o' ) / 144.0 *  Delta
             delta1 = 1d-1
             do while ( delta1 > 1d-4 )
                c2 = Op_table( ref_entry + j1 - 1) + ( density( Op_table(ref_entry + j1 - 1) , 'o' ) + density( c1, 'o' ) ) /2.0  / 144.0 * Delta
                delta1 = abs(c2 - c1)
                c1 = c2
             end do
             WOC_entry = ref_entry  + j1
             Op_table( ref_entry  + j1) = c1
             Wp_table( ref_entry  + j1) = Op_table( ref_entry  + j1) - OWC_PCOW

             Exit
          EndIF

          c1 = Op_table( ref_entry + j1 - 1) + density( Op_table(ref_entry + j1 - 1) , 'o' ) / 144.0 *  Delta
          !write(*,*) density( p_table(ref_entry + j1-1,2) )
          !write(*,*) p_table(ref_entry + j1-1,2)

          delta1 = 1d-1
          do while ( delta1 > 1d-6 )
             c2 = Op_table(ref_entry + j1 - 1) + ( density( Op_table(ref_entry + j1 - 1) , 'o' ) + density( c1, 'o' ) ) /2.0 / 144.0 * Delta !( p_table(ref_entry + j1,1) - p_table(ref_entry + j1-1,1) )     density( ( Op_table(ref_entry + j1 - 1) + c1 ) / 2.0 , 'o')
             delta1 = abs(c2 - c1)
             !write(*,*) 'p_table =' ,
             c1 = c2
          end do
          Op_table( ref_entry  + j1) = c1

!                                    write (*,*) Op_table( ref_entry  + j1)
!                                    pause
       End DO

       Delta = 0.05
	If (.NOT. USEISW) then
		   Do i = WOC_entry + 1 , size_table !up_length  ! below OWC there is only water , which means Oil pressure should be calculated according to water pressure calculated first
			  Z_table(i) = Z_table( i - 1 ) + Delta
			  CW1 = Wp_table( i - 1) + density( Wp_table(i - 1) , 'w' ) / 144.0 *  Delta

			  delta1 = 1d-1
			  do while ( delta1 > 1d-6 )
				 c2 = Wp_table(i - 1) + ( density( Wp_table(i - 1) , 'w') + density( CW1 , 'w' ) )/2.0 / 144.0 * Delta !( p_table(ref_entry + j1,1) - p_table(ref_entry + j1-1,1) )
				 delta1 = abs(c2 - CW1)
				 !write(*,*) 'p_table =' ,
				 CW1 = c2
			  end do
			  Wp_table(i) = CW1
			  Op_table(i) = Wp_table(i) +  OWC_PCOW
		   EndDO
	EndIF
       Delta = 0.05
       down_length = ref_entry - 1

       Do j1 = 1 , down_length
          i = ref_entry - j1
          Z_table(i) = Z_table( i + 1 ) - Delta
          c1 = Op_table(i + 1) - density( Op_table(i + 1 ) , 'o' ) / 144.0 * Delta !( p_table(ref_entry - j1,1) - p_table(ref_entry - j1 + 1,1) )
          delta1 = 1d-1
          do while ( delta1 > 1d-6 )
             c2 = Op_table( i + 1) - ( density( Op_table(i + 1) , 'o' ) + density( c1 , 'o' ) ) / 2.0 / 144.0 * Delta !( p_table(ref_entry - j1,1) - p_table(ref_entry - j1 + 1,1) )
             delta1 = abs(c2 - c1)
             c1 = c2
          enddo
          Op_table(i) = c1
       End DO

       ! PW_table values before WOC are calculated at this step
		If (WOC_entry >	size_table) then
				WOC_entry =	size_table
		EndIf
       Do i = 1 , WOC_entry - 1
          j = WOC_entry - i
          Delta = Z_table(j + 1) - Z_table( j )
          CW1 = Wp_table( j + 1) - density( Wp_table(j + 1) , 'w' ) / 144.0 *  Delta

          delta1 = 1d-1
          do while ( delta1 > 1d-4 )
             c2 = Wp_table(j + 1) - ( density( Wp_table(j + 1) , 'w' ) + density( CW1 , 'w' ) ) / 2.0 / 144.0 * Delta !( p_table(ref_entry + j1,1) - p_table(ref_entry + j1-1,1) )
             delta1 = abs(c2 - CW1)
             CW1 = c2
          end do
          Wp_table(j) = CW1
       EndDo

       !write(*,*) down_length
       !write(*,*) size_p_table - up_length - 1
       !pause

                Open(1,FILE='OP_table.DAT', status='unknown')
                Write(1,*) 'Depth ,    Oil Pressure,  Water Pressure,          Sw'

                Do j1 = 1, size_table
                   Write(1,*)  Z_table(j1) , Op_table(j1) , Wp_table(j1)
                EndDo   !
                close(1)

       If (.NOT. USEISW) then
		   Do i = 1 , size_table!WOC_entry
			   Sw_table ( i ) = PCO_inv( Op_table(i) - Wp_table(i) )
		   EndDO
	   EndIf
!       write(*,*) 'maximum p_table is ' , max(op_table),'   min P_table is ', min(op_table)
!       pause

!                Open(1,FILE='Sw_table.DAT', status='unknown')
!                Write(1,*) 'Depth ,    Oil Pressure - Water Pressure,          Sw'
!
!                Do j1 = 1, size_table
!                   Write(1,*)  Z_table(j1) , Op_table(j1) - Wp_table(j1), Sw_table(j1)
!                EndDo
!
!                close(1)

    Endsubroutine ref_press_table
   !##################################################
    real function c_f(p4)
    real*8 :: p4
        c_f = 0.00005 / B_f(p4,'o')
    Endfunction c_f

    !##################################################
    real*8 function PCO(ind) ! computed the cappilary pressure in the given block according to its saturation

    real :: swater
    Integer :: m,n , ind
            swater = sw(ind)
            n = n_Kr
            m=1
            do while (abs(n-m) .NE. 1)
                if (swater < Sw_mat( floor( m+(n-m+1)/2.0 ) ))  then
                    n = floor(m+ ( n - m + 1 ) / 2.0 );
                else
                    m = floor(m + ( n - m + 1) / 2.0);
                end if
            end do
            PCO = Pcow(m)+ (swater - Sw_mat(m))/(Sw_mat(n) - Sw_mat(m))*(Pcow(n) - Pcow(m));
    !PCO = - 34.98 * Swater ** 3 + 83.96 * Swater**2 - 67.17 * Swater
    Endfunction PCO

    !##################################################

    real function k_r(ind , m1 )
    ! You Must Notice that in this Function the assumption is that the value of kro is 0 for the last 2 values of Sw is Sw_mat matrix
    ! E.G. Sw = 0.8 , kro = 0 ; Sw = 1 , kro =0 ,
    ! if kro(Sw = Sw_mat(n_kr - 1 ) ) .NE. 0 , then this function should be revised

    !-------------------------------------Variable Declaration Part-------------------------------------------------------
    Implicit None
    !
    Character*1 :: m1  ! 'oil or water'
    real :: swater
    Integer :: m , n , ind
            swater = sw(ind)
            n = n_Kr
            m = 1

!		   m = n_Kr - 1
!           Do
!              if ( swater > Sw_mat(m) )  then   ! It means that Water Saturaion is never below ( even by a very very small value) the minimum value
!                 n = m + 1
!                 exit
!              Else
!                 m = m - 1
!              EndIf
!           EndDO

            do while (abs(n-m) .NE. 1)
                if (swater < Sw_mat(floor( m + (n-m+1)/2.0) ) )  then
                    n = floor(m + ( n - m + 1) / 2.0);
                else
                    m = floor(m + ( n - m + 1) / 2.0);
                end if
            end do
            if  (m1 == 'o') then
				if (swater .LE. Sw_mat(1) ) then
					k_r = kro(1)
				Elseif (swater .GE. Sw_mat(n_Kr) ) then
					k_r = 0.0
				Else
					k_r = kro(m)+ (swater -Sw_mat(m))/(Sw_mat(n)-Sw_mat(m))*(kro(n)-kro(m))
				EndIf
            else
				if (swater .LE. Sw_mat(1)) then
!					sw(ind) = Sw_mat(1)
					k_r = 0.0
				Elseif (swater .GE. 1.0 ) then
					k_r = krw(n_Kr)
				Else
					k_r = krw(m)+ (swater -Sw_mat(m))/(Sw_mat(n)-Sw_mat(m))*(krw(n)-krw(m));
				EndIf
            EndIf
    endfunction k_r
    !##################################################

!    real*8 function W_press(ind) ! this function calculates Water pressure in Block # ind by subtracting Capillary pressure from Oil Pressure
!    Implicit none
!    integer :: ind
!    real :: Swater
!
!        Swater = SW(ind)
!        W_press = Pressure(ind) - PCO(ind)
!    Endfunction W_press
    !##################################################
  real function PCO_inv(S)

    real*8 :: S ! the type of the input variable is PRESSURE
    Integer :: m,n , ind
        n = n_Kr
        m=1
        if ((S .LE. Pcow(n_kr))  ) then ! minimum Capillary pressure  .OR. (abs( S - Pcow(n_kr)) .LE. 0.00004 )
           PCO_inv = Sw_mat(n_kr) !- Epsilon
        Elseif ( S .GE. Pcow(1) ) then ! maximum capillary pressure
           PCO_inv = Sw_mat(1)
        Else
           m = n_kr - 1
           Do
              if ( S < Pcow(m) )  then
                 n = m + 1
                 exit
              Else
                 m = m - 1
              EndIf
           EndDO
           PCO_inv = Sw_mat(m) + ( S - Pcow(m) ) / ( Pcow(n) - Pcow(m) ) * ( Sw_mat(n) - Sw_mat(m) )
        EndIf

    Endfunction PCO_inv
    !##################################################

   subroutine initial_swi
   ! sets initial pressures according to depth
   Integer :: m ,n , alfa
   integer :: i,j,k , i6 , iWell, alfawell , ik , B_index
   Real :: Denom , term , Z
   !Allocate(pressure(NTOTAL + Nwell ))

    Do k = 1,Nz
       Do j=1,Ny
          Do i=1,Nx
             alfa = (k-1) * Nx * Ny + (j-1) * Nx + i
             n = size_table + 1
             m = 1
             z = Zblock(alfa)
             do while ( abs(n-m) > 1 )
                i6 = floor(m + (n - m + 1)/2.0)
                if (z < Z_table(i6) )  then
                    n =  i6 !floor(m2+(n2-m2+1)/2.0);
                else
                    m =  i6 !floor(m2+(n2-m2+1)/2.0);
                end if
             end do
             pressure( alfa ) = Op_table( m ) + ( Zblock(alfa) -  Z_table(m) ) / (  Z_table(n) - Z_table(m) ) * ( Op_table(n) - Op_table(m) )
             SW( alfa ) = 0.2

          Enddo
       Enddo
    Enddo
      ! putting pressure and Saturation values into YY vector
    Do k=1,Nz
       Do j=1,Ny
          Do i=1,Nx
              B_index = (k-1) * Nx * Ny + (j-1) * Nx + i ! B_index is the block number, while
              alfa = 2 * (B_index ) - 1                ! alfa is the location in the Jacobian Matrix , I will use B_index to point the Block Number and pressure of that Block
              YY(alfa) = pressure(B_index)
              YY(alfa + 1) = Sw(B_index)
          EndDO
       EndDO
    EndDO
                Open(1,FILE='initial_pressure.DAT', status='unknown')
                !Write(1,*) 'ptable values'
                Do i = 1 , Ntotal
                   Write(1,*) pressure(i) , Zblock(i)
                EndDO
                close(1)

   Endsubroutine initial_swi
!##################################################
   real*8 function D_Poten(ind1,ind2,m)

   Character*1 :: m
   integer:: ind1, ind2
   real*8 :: den_avg

      if ( m == 'o') then
		 den_avg = ( density( pressure(ind1),'o' ) + density( pressure(ind2),'o' ) )/ 2.0
         D_Poten = (pressure(ind1) - pressure(ind2)) - den_avg / 144.0 * ( Zblock(ind1) - Zblock(ind2) )
      Else
		 den_avg = ( density( W_press(ind1) ,'w') + density( W_press(ind2) , 'w') )/ 2.0
         D_Poten = W_press(ind1) - W_press(ind2) - den_avg / 144.0 * ( Zblock(ind1) - Zblock(ind2) )
      Endif

   endfunction D_Poten
!*******************************************************************************************
   subroutine change_Sw

   integer :: i , j , k , B_index, counter

	  counter = 0
      Do k = 1 , Nz
         Do j = 1 , Ny
            Do i = 1 , Nx
                B_index = (k-1) * Nx * Ny + (j-1) * Nx + i ! B_index is the block number, while
                if ( abs(1 - Sw(B_index)) < 1d-4) then
                   Sw(B_index) = 1 - 1d-4
                   counter = counter + 1
                EndIf
            EndDO
         EndDO
      EndDO

   Endsubroutine change_Sw
!*******************************************************************************************
    !##################################################
    real function PCO_Sw(W_saturation) ! computed the cappilary pressure in the given block according to its saturation

    real*8 :: W_saturation
    Integer :: m,n

            n = n_Kr
            m=1
            do while (abs(n-m)>1)
                if (W_saturation < Sw_mat( floor( m+(n-m+1)/2.0 ) ))  then
                    n = floor(m+ ( n-m+1 ) / 2.0 );
                else
                    m = floor(m + ( n - m + 1) / 2.0);
                end if
            end do
            PCO_Sw = Pcow(m)+ (W_saturation - Sw_mat(m))/(Sw_mat(n) - Sw_mat(m))*(Pcow(n) - Pcow(m));

    Endfunction PCO_Sw

    !##################################################

EndModule Trans


!   --------------------------------------------------------------------
!   DMET DELUX 2000	Subrutine	statistikk
!   --------------------------------------------------------------------
!   HENSIKT :
!   Beregner bølgestatistikk fra oppgitt JONSWAP-spekter
!
!   METODE :
!   Tar inn frekvensvektor,spekterverdier og spekterparametere fra
!   tidligere subrutiner. Beregner spektermomenter, midlere periode
!   og maksimal bølgehøyde for en femtimers periode.
!
!   KALLESEKVENS:
!   CALL statistikk(a,b,n,omega,Sn,Hs,pi)
!
!   PARAMETERE:
!   Navn	I/O	Type			Innhold/Beskrivelse
!   ....................................................................
!   omega	I	flyttals vektor		bølgefrekvens
!   n		I	heltall			antall frekvensintervaller
!   k		I	flyttallsvektor		bølgetall
!   zeta_an	I	flyttallsvektor		bølgeamplitude
!   hs		I	heltall	  		signifikant bølgehøyde
!   tp		I	heltall			midlere periode
!   gamma	I	heltall			toppethetsfaktor
!   pi		I	flyttall		pi
!   g		I	flyttall		tyngdelfeltsakselerasjon
!   sn		I	flyttallsvektor		spekterverdi
!   a		I	heltall			nedre frekvensverdi
!   b		I	heltall			øvre frekvensverdi
!   pi		I	flyttall		pi
!   rho		I	flyttal			tetthet sjøvann
!   g		I	flyttall		tyngdeakselerasjonen
!   Tm02	O	flyttall		nullkrysningsperiode
!   Tm0e	O	flyttall		middelperiode
!   Tm24	O	flyttall		middelperiode mellom topper
!    Hmax	O	flyttal			største bølgehøyde fem timer
!
!   INTERNE VARIABLE:
!   Navn			Funksjon
!   .....................................................................
!   i,n				tellevariabler
!   deltaomega			frekvensintervall
!   m0,m1,m2,m4			spektermomenter
!   mndelsum			mellomregningsverdier
!
!   SUBRUTINER:
!   Navn			Funksjonsbeskrivelse
!   .....................................................................
!   konstanter			beregner metasenter og andre arealmomenter
!   akalk			beregner tilleggmasse i hiv
!   bckalk			beregner demping og fjærkoeffisienter
!   h3kalk			beregner transferfunksjoner hiv
!   h5kalk			beregner transferfunksjoner stamp
!   fasekalk			beregner fasevinkel for bevegelser
!
!   LESEFILER:
!   Navn			Eventuell beskrivelse
!   .....................................................................
!   konstantinput.txt		inneholder lektergeometri
!
!
!   SKRIVEFILER:
!   Navn			Eventuell beskrivelse
!   .....................................................................
!   statistikk.txt		resultater for bølgestatistikk
!
!   --------------------------------------------------------------------
!
!   Programmert av:	     Tor Erik Larsen
!   Dato/Versjon  : 	     27.04.15 / 1.0
!
!   --------------------------------------------------------------------

SUBROUTINE statistikk(a,b,n,omega,Sn,Hs,pi)
IMPLICIT NONE
INTEGER i,n
REAL::m0delsum, m1delsum,m2delsum,m4delsum
REAL::m0,m1,m2,m4
REAL::Tz,Tm02,Tmo2,Tm24,Hmax,NN,Tmoe
REAL::pi,Hs,a,b,deltaomega
DOUBLE PRECISION,DIMENSION(1:n)::omega,sn

!Beregner deltaomega
deltaomega = (b-a)/n

!Beregner spektermomentet m0
m0delsum = 0
DO i = 1,n
   m0delsum = m0delsum +  sn(i)
END DO
m0 = deltaomega * m0delsum

!Beregner spektermomentet m1
m1delsum = 0
DO i = 1,n
   m1delsum = m1delsum + sn(i)*omega(i)
END DO
m1 = deltaomega*m1delsum

!Beregner m2 og tm02
m2delsum = 0
DO i=1,n
   m2delsum = m2delsum + omega(i)**2 * sn(i)
END DO
m2 = deltaomega*m2delsum

!Beregner spektermomentet m4
m4delsum = 0
DO i=1,n
   m4delsum = m4delsum + omega(i)**4 * sn(i)
END DO
m4 = deltaomega*m4delsum

!Beregner nullkrysningsperiode Tz
Tz = pi*Hs / (2.0*SQRT(m2))
Tm02= 2.0*pi*SQRT(m0/m2)
Tmoe = 2.0*pi*(m0/m1)
Tm24 = 2.0*pi*SQRT(m2/m4)

!Beregner antall bølger N for en varighet på 5 timer eller 18000 sekunder
NN = 18000.0 / Tz
Hmax = Hs*SQRT(LOG(NN)/2.0)

!Skriver resultater til fil
OPEN(252,FILE="statistikk.txt",ACTION="WRITE",STATUS="UNKNOWN")
WRITE(*,*) ''
WRITE(252,*) '---------------------------------------------------------'
WRITE(252,"(A,F10.1,A)") 'Nullkrysningsperioden Tm0z er: ', Tm02, '[s]'
WRITE(252,"(A,F10.1,A)") 'Midlere periode Tm0e er:       ', Tmoe, '[s]'
WRITE(252,"(A,F10.1,A)") 'Midlere periode mellom bølgetoppene er: ',Tm24, '[s]'
WRITE(252,"(A,F10.1,A)") 'Høyeste bølge i en 5-timers periode er: ',Hmax, '[m]'
WRITE(252,*) '--------------------------------------------------------'
WRITE(*,*) ''
CLOSE(252)

RETURN
END SUBROUTINE


module ptsGaussLib
	use funcAux
	implicit none

	public GaussRuleQ, setFEMtype, setNodG

	!! A class to encapsulate issues related to shape function and its derivatives evaluated in Gauss Points. Provides as well the N, B matrices for scalar and vectors
	type :: PtGaussClass

		integer :: NGP, NodG, NdimE
		real*8 , allocatable :: dPhi_G(:,:,:), Phi(:,:) , dV(:)  ! allocate(s%dPhi_G(NdimE,NodG,NGP),s%Phi(NodG,NGP),s%dV(NGP))

		Contains

		procedure, public :: init, calcGradU, calcU, initCollapsed, initWithPsi, calcTheta, &
							calcGradTheta, getBmat, getBmatSym, getBmatScalar, getNvecScalar, getNmat

	end type

	contains

	!! Given numerical parameters and the element coordinates, stores the shape functions and its derivatives, in a gauss rule. Its works for both simplexes and quadrangles
	subroutine init(s,XLL,NodG,NdimE,NGP, pOrder,iBu, iSimplex)
		class(PtGaussClass) :: s
		integer , intent(in) :: NodG, NGP, NdimE, iBu, iSimplex, pOrder
		real*8 , intent(in) :: XLL(NdimE*NodG)
		integer :: i
		real*8 :: Det, W(NGP), Psi(NdimE,NGP), Jac(NdimE,NdimE), dPhi_L(NdimE,NodG)

		s%NodG = NodG
		s%NdimE = NdimE
		s%NGP = NGP

		allocate(s%dPhi_G(NdimE,NodG,NGP),s%Phi(NodG,NGP),s%dV(NGP))

		if(iSimplex == 0) then
			Call GaussRule (Psi,W,NdimE,NGP,iSimplex)
		else
			Call GaussRuleQ (Psi,W,NdimE,NGP,iSimplex)
		end if

		do i = 1 , NGP
			if(iSimplex == 0) then
				Call LocalShapeDer(NodG,NdimE,dPhi_L,PSI(1,i),pOrder,iBu)
				Call ShapeF (NodG,NdimE,s%Phi(1,i),PSI(1,i),pOrder,iBu)
			else
				Call LocalShapeDerQ(NodG,NdimE,dPhi_L,PSI(1,i),pOrder,iBu)
				Call ShapeFQ (NodG,NdimE,s%Phi(1,i),PSI(1,i),pOrder,iBu)
			end if

			Call Jacobian(Jac,Det,NdimE,NodG,XLL,dPhi_L)
			Call GlobalShapeDer(NodG,NdimE,dPhi_L,s%dPhi_G(1,1,i),Jac)
			s%dV(i) = W(i)*Det

		end do

	end subroutine

	!! Similar to init but the evaluation points and its weights (which may be gauss points) are given externally
	subroutine initWithPsi(s,Psi,W,XLL,NodG,NdimE,NGP, pOrder,iBu, iSimplex)
		class(PtGaussClass) :: s
		integer , intent(in) :: NodG, NGP, NdimE, iBu, iSimplex, pOrder
		real*8 , intent(in) :: XLL(NdimE*NodG), Psi(NdimE,NodG), W(NGP)
		integer :: i
		real*8 :: Det, Jac(NdimE,NdimE), dPhi_L(NdimE,NodG)

		s%NodG = NodG
		s%NdimE = NdimE
		s%NGP = NGP

		allocate(s%dPhi_G(NdimE,NodG,NGP),s%Phi(NodG,NGP),s%dV(NGP))

		do i = 1 , NGP
			if(iSimplex == 0) then
				Call LocalShapeDer(NodG,NdimE,dPhi_L,PSI(1,i),pOrder,iBu)
				Call ShapeF (NodG,NdimE,s%Phi(1,i),PSI(1,i),pOrder,iBu)
			else
				Call LocalShapeDerQ(NodG,NdimE,dPhi_L,PSI(1,i),pOrder,iBu)
				Call ShapeFQ (NodG,NdimE,s%Phi(1,i),PSI(1,i),pOrder,iBu)
			end if

			Call Jacobian(Jac,Det,NdimE,NodG,XLL,dPhi_L)
			Call GlobalShapeDer(NodG,NdimE,dPhi_L,s%dPhi_G(1,1,i),Jac)
			s%dV(i) = W(i)*Det

		end do

	end subroutine

	!! Similar to init but the gauss points are collapsed to one dimension below, used when we want gradients but the region is a surface, e.g. to evaluation the Neumann term due to spatial normal pressure in material configuration.
	subroutine initCollapsed(s,XLL,NodG,NdimE,NGP, pOrder,iBu, iSimplex)
		class(PtGaussClass) :: s
		integer , intent(in) :: NodG, NGP, NdimE, iBu, iSimplex, pOrder
		real*8 , intent(in) :: XLL(NdimE*NodG)
		integer :: i, j
		real*8 :: Det, W(NGP), Psi(NdimE,NGP), Jac(NdimE,NdimE), dPhi_L(NdimE,NodG)
		real*8 :: DetCollap, PsiCollap(NdimE-1,NGP)

		s%NodG = NodG
		s%NdimE = NdimE
		s%NGP = NGP

		allocate(s%dPhi_G(NdimE,NodG,NGP),s%Phi(NodG,NGP),s%dV(NGP))

		if(iSimplex == 0) then
			Call GaussRule (PsiCollap,W,NdimE-1,NGP,iSimplex)
		else
			Call GaussRuleQ (PsiCollap,W,NdimE-1,NGP,iSimplex)
		end if

		Psi(1:NdimE-1,:) = PsiCollap(1:NdimE-1,:)
		Psi(NdimE,:) = 0.0d0

		do i = 1 , NGP
			if(iSimplex == 0) then
				Call LocalShapeDer(NodG,NdimE,dPhi_L,PSI(1,i),pOrder,iBu)
				Call ShapeF (NodG,NdimE,s%Phi(1,i),PSI(1,i),pOrder,iBu)
			else
				Call LocalShapeDerQ(NodG,NdimE,dPhi_L,PSI(1,i),pOrder,iBu)
				Call ShapeFQ (NodG,NdimE,s%Phi(1,i),PSI(1,i),pOrder,iBu)
			end if

!~ 			write(0,*) dPhi_L
!~ 			pause

			Call Jacobian(Jac,Det,NdimE,NodG,XLL,dPhi_L)
			Call GlobalShapeDer(NodG,NdimE,dPhi_L,s%dPhi_G(1,1,i),Jac)
			s%dV(i) = W(i)*Det

		end do

	end subroutine

	!! encapsulates the GradU (U vector) calc, deprecated, you should use B matrix instead
	subroutine calcGradU(s,GradU,SolU,nG)
		class(PtGaussClass) :: s
		integer, intent(in) :: nG
		Real*8, intent(out) :: GradU(:,:) !! have NdimE x NdimE dimension
		Real*8, intent(in) :: SolU(:) !! have NdimE*NodG dimension
		integer :: i, j , e ,ep

		GradU = 0.0d0
		do e = 1 , s%NodG
			ep = (e-1)*s%NdimE
			do i = 1, s%NdimE
				do j = 1, s%NdimE
					GradU(i,j) = GradU(i,j) + SolU(ep+i)*s%dPhi_G(j,e,nG)
				end do
			end do
		end do

	end subroutine

	!! encapsulates the U vector calc, deprecated, you should use N matrix instead
	subroutine calcU(s,U,SolU,nG)
		class(PtGaussClass) :: s
		integer, intent(in) :: nG
		Real*8, intent(out) :: U(:) !! have NdimE dimension
		Real*8, intent(in) :: SolU(:) !! have NdimE*NodG dimension
		integer :: i, e ,ep

		U= 0.0d0
		do e = 1 , s%NodG
			ep = (e-1)*s%NdimE
			do i = 1, s%NdimE
				U(i) = U(i) + SolU(ep+i)*s%Phi(e,nG)
			end do
		end do

	end subroutine

	!! encapsulates the GradTheta (Theta scalar) calc, deprecated, you should use B matrix instead
	subroutine calcGradTheta(s,GradTheta,SolTheta,nG) !! scalar field
		class(PtGaussClass) :: s
		integer, intent(in) :: nG
		Real*8, intent(out) :: GradTheta(:) !! have NdimE dimension
		Real*8, intent(in) :: SolTheta(:) !! have NodG dimension
		integer :: i, j , e

		GradTheta = 0.0d0
		do e = 1 , s%NodG
			do i = 1, s%NdimE
				GradTheta(i) = GradTheta(i) + SolTheta(e)*s%dPhi_G(i,e,nG)
			end do
		end do

	end subroutine

	!! encapsulates the Theta (Theta scalar) calc, deprecated, you should use N matrix instead
	subroutine calcTheta(s,Theta,SolTheta,nG)
		class(PtGaussClass) :: s
		integer, intent(in) :: nG
		Real*8, intent(out) :: Theta
		Real*8, intent(in) :: SolTheta(:) !! have NodG dimension
		integer :: i, e

		Theta= 0.0d0
		do e = 1 , s%NodG
			Theta = Theta + SolTheta(e)*s%Phi(e,nG)
		end do

	end subroutine

	subroutine getBmat(s,B,nG)
		class(PtGaussClass) :: s
		integer , intent(in) :: nG
		real*8 , intent(out) :: B(:,:) !! B is NdimE^2 X NodG*NdimE

		integer , parameter :: n2 = 4 !! assuming two dimension
		integer :: voigtMapI(n2), voigtMapJ(n2), p,q, i, j, qp

		voigtMapI = (/1,1,2,2/)
		voigtMapJ = (/1,2,1,2/)

		B = 0.0d0

		do p = 1 , n2
			i = voigtMapI(p)
			j = voigtMapJ(p)
			do q = 1 , s%NodG
				qp = (q-1)*s%NdimE + i
				B(p, qp) = s%dPhi_G(j,q,nG)
			end do
		end do

!~ 		B(1,1) = s%dPhi_G(1,1,nG)
!~ 		B(1,3) = s%dPhi_G(1,2,nG)
!~ 		B(1,5) = s%dPhi_G(1,3,nG)
!~
!~ 		B(2,1) = s%dPhi_G(2,1,nG)
!~ 		B(2,3) = s%dPhi_G(2,2,nG)
!~ 		B(2,5) = s%dPhi_G(2,3,nG)
!~
!~ 		B(3,2) = s%dPhi_G(1,1,nG)
!~ 		B(3,4) = s%dPhi_G(1,2,nG)
!~ 		B(3,6) = s%dPhi_G(1,3,nG)
!~
!~ 		B(4,2) = s%dPhi_G(2,1,nG)
!~ 		B(4,4) = s%dPhi_G(2,2,nG)
!~ 		B(4,6) = s%dPhi_G(2,3,nG)

	end subroutine
!~

	subroutine getBmatSym(s,B,nG) !! Following Hughes pag. 90
		class(PtGaussClass) :: s
		integer , intent(in) :: nG
		real*8 , intent(out) :: B(:,:)

		B = 0.0d0

		B(1,1) = s%dPhi_G(1,1,nG)
		B(1,3) = s%dPhi_G(1,2,nG)
		B(1,5) = s%dPhi_G(1,3,nG)

		B(2,2) = s%dPhi_G(2,1,nG)
		B(2,4) = s%dPhi_G(2,2,nG)
		B(2,6) = s%dPhi_G(2,3,nG)

		B(3,1) = s%dPhi_G(2,1,nG)
		B(3,3) = s%dPhi_G(2,2,nG)
		B(3,5) = s%dPhi_G(2,3,nG)

		B(3,2) = s%dPhi_G(1,1,nG)
		B(3,4) = s%dPhi_G(1,2,nG)
		B(3,6) = s%dPhi_G(1,3,nG)

	end subroutine

	subroutine getBmatScalar(s,B,nG)
		class(PtGaussClass) :: s
		integer , intent(in) :: nG
		real*8 , intent(out) :: B(:,:) !! B is NdimE X NodG

		B = s%dPhi_G(:,:,nG)

	end subroutine

 	subroutine getNvecScalar(s,N,nG)
		class(PtGaussClass) :: s
		integer , intent(in) :: nG
		real*8 , intent(out) :: N(:) !! N is NodG

		N = s%Phi(:,nG)

	end subroutine

 	subroutine getNmat(s,N,nG) !! particular case of triangle
		class(PtGaussClass) :: s
		integer , intent(in) :: nG
		real*8 , intent(out) :: N(:,:) !! N is NdimE x (NdimE*NodG)

		N(1,1) = s%Phi(1,nG)
		N(2,2) = s%Phi(1,nG)
		N(1,3) = s%Phi(2,nG)
		N(2,4) = s%Phi(2,nG)
		N(1,5) = s%Phi(3,nG)
		N(2,6) = s%Phi(3,nG)

	end subroutine

	subroutine setFEMtype(FEMtype,NodG,pOrder,NGP,iSimplex,iBubble)
		integer , intent(in) :: FEMtype
		integer , intent(out) :: NodG,pOrder,NGP,iSimplex,iBubble

		select case(FEMtype)
			case(1) !! linear triangle
				NGP = 1
				NodG = 3
				pOrder = 1
				iSimplex = 0
				iBubble = 0

			case(2) !! linear quadrangle
				NGP = 4
				NodG = 4
				pOrder = 1
				iSimplex = 1
				iBubble = 0

			case(3) !! quadratic triangle with 3 gauss points
				NGP = 3
				NodG = 6
				pOrder = 2
				iSimplex = 0
				iBubble = 0

			case(4) !! quadratic quadrangle with 9 gauss points
				NGP = 16
				NodG = 9
				pOrder = 2
				iSimplex = 1
				iBubble = 0

			case(5) !! Linear Line with 1 gauss points
				NGP = 1
				NodG = 2
				pOrder = 1
				iSimplex = 0
				iBubble = 0
			case(6) !! Linear Tetrahedra
				NGP = 4 !! just 1 or 3
				NodG = 4
				pOrder = 1
				iSimplex = 0
				iBubble = 0
			case(7) !! Point
				NGP = 1 !! just 1 or 3
				NodG = 1
				pOrder = 0
				iSimplex = 0
				iBubble = 0
			case(8) !! Quadratic Line with 2 gauss points
				NGP = 2
				NodG = 3
				pOrder = 2
				iSimplex = 0
				iBubble = 0
			case default
				write(*,*) "FEMtype = " , FEMtype,  "not supported at moment"
				stop
		end select

	end subroutine

	subroutine setNodG(FEMtype,NodG)
		integer , intent(in) :: FEMtype
		integer , intent(out) :: NodG
		integer :: dummy

		call setFEMtype(FEMtype,NodG,dummy,dummy,dummy,dummy)

	end subroutine

	subroutine GaussRuleQ(Psi,W,NdimE,NGP, iSimplex)
		integer , intent(in) :: NdimE, NGP,  iSimplex
		real*8, intent(out) :: Psi(NdimE,NGP), W(NGP)
		integer , parameter :: NGP1Dmax = 3, Ndim1D = 1
		integer :: nGi, nGj, nGk, NGP1D, nGpp
		real*8 :: Psi1D(1,NGP1Dmax), W1D(NGP1Dmax)

		NGP1D = nint(real(NGP)**(1.0d0/real(NdimE)))

		Call GaussRule(Psi1D(:,1:NGP1D) ,W1D(1:NGP1D),Ndim1D,NGP1D,iSimplex)

		select case(NdimE)
			case(1)
				Psi(1,:) = Psi1D(1,1:NGP1D)
				W = W1D(1:NGP1D)
			case(2)
				do nGi = 1,NGP1D
				do nGj = 1,NGP1D
					nGpp = (nGi - 1)*NGP1D + nGj
					Psi(1,nGpp) = Psi1D(1,nGi)
					Psi(2,nGpp) = Psi1D(1,nGj)
					W(nGpp) = W1D(nGi) * W1D(nGj)
				end do
				end do

			case(3)
				do nGi = 1,NGP1D
				do nGj = 1,NGP1D
				do nGk = 1,NGP1D
					nGpp = (nGi - 1)*NGP1D*NGP1D + (nGj-1)*NGP1D + nGk
					Psi(1,nGpp) = Psi1D(1,nGi)
					Psi(2,nGpp) = Psi1D(1,nGj)
					Psi(3,nGpp) = Psi1D(1,nGk)
					W(nGpp) = W1D(nGi) * W1D(nGj) * W1D(nGk)
				end do
				end do
				end do
		end select

	end subroutine

end module


c /***************************************************
c   prof.f  for bulhalo
c  22 Aug. 2006  written by D.Kawata
c ****************************************************/
c70*******************************************************************

c /*****   NFW density profile ****/
      function rhonfwsw(r,c,rvir,rt,flag)
      include 'define.f'
      integer flag
      double precision rhonfwsw
      double precision r,c,rvir,rcut
      double precision x,t,a,n,ct,rt

      x=r/rvir
      t=rt*c/rvir

      if(flag.eq.0) then
        rhonfwsw=dexp(-r**2/rt**2)/(c*x*((1.0d0+c*x)**2))
      else
        rhonfwsw=1.0d0/(c*x*((1.0d0+c*x)**2))
      endif

      return
      end

      function mrnfw(r,c,rvir)
      include 'define.f'
      double precision mrnfw
      double precision r,c,rvir

      mrnfw=(rvir**3)*(4.0d0*M_PI)*((c*r+(c*r+rvir)*dlog(rvir))
     &   /(-c*r-rvir)+dlog(c*r+rvir))/(c**3)

      return
      end

c /*****   Hernquist mass profile  *****/
c /*****   M(r)  *****/
      function mrhp(r,ms,ah)
      include 'define.f'
      double precision mrhp
      double precision r,ms,ah

      mrhp = ms*(r**2)/((r+ah)**2)

      return
      end

c /*****   rho(r)  *****/
      function rhohp(r,ms,ah)
      include 'define.f'
      double precision rhohp
      double precision r,ms,ah

      rhohp = (ms/(2.0d0*M_PI))*(ah/r)/((r+ah)**3)

      return
      end

c /*****   r mrhp(r)  *****/
      function rmrhp(f,ms,ah)
      include 'define.f'
      double precision rmrhp
      double precision f,ms,ah

      rmrhp = ah*dsqrt(f)/(1.0d0-dsqrt(f))

      return
      end

c modified NFW by Maller & Bullock (2004) for halo hot gas
      function rhombhg(x)
      double precision rhombhg,x

      rhombhg=1.0d0/((x+0.75d0)*((1.0d0+x)**2))

      return
      end

      function mrmbhg(x)
      double precision mrmbhg,x

      mrmbhg=9.0d0*dlog(1.0d0+(4.0d0/3.0d0)*x)-8.0d0*dlog(1.0d0+x)
     &  -4.0d0*x/(1.0d0+x)

      return
      end

c /*****   Exponential disk mass profile  *****/
c /*****   M(r)  from particle *****/
      function mr3dexpd(r,nd,rlistd,r3dd,massp)
      include 'define.f'
      double precision mr3dexpd
      integer i,ip,ipp
      integer nd,rlistd(MN)
      double precision r,r3dd(MN),mrp,massp(MN)

      mrp = 0.0d0
      ipp = rlistd(1)
      do i=1,nd
        ip=rlistd(i)
        if(r3dd(ip).lt.r) then
          mrp=mrp+massp(ip)
        else
          if(ipp.eq.rlistd(1)) then
            ip = rlistd(2)
            mrp=massp(ip)+massp(ip)*(r-r3dd(ipp))/(r3dd(ip)-r3dd(ipp))
          else
            mrp=mrp+massp(ip)*(r-r3dd(ipp))/(r3dd(ip)-r3dd(ipp))
          endif
          goto 70
         endif
         ipp = ip
      enddo
 70   mr3dexpd = mrp
      if(mr3dexpd.lt.0.0d0) then
        mr3dexpd = 0.0d0
      endif

      return
      end

c /*****   M(<r)  assuming thin disk *****/
      function mrexpdf(r,hd,mdisk)
      include 'define.f'
      double precision mrexpdf
      double precision r,hd,mdisk

c      if(flagdp.eq.0) then
        mrexpdf = mdisk*(1.0d0-(1.0d0+r/hd)*dexp(-r/hd))
c      else
c        mrexpdf = mdisk*(1.0d0-(1.0d0+(r/hd)+0.5d0*((r/hd)**2)
c     &    +(1.0d0/6.0d0)*((r/hd)**3))*dexp(-r/hd))
c      endif

      return
      end