!================================================================
!================================================================
program spg
  implicit none
  !===============================================================
  ! This code splits grafic initial conditions files in ncpu files
  ! following a 3D space filling curve.
  !
  ! Syntax : split_grafic input output ncpu
  !
  ! - input is a directory which contains the 7 grafic files
  ! - output will contain the splitted files
  ! - ncpu must be a power of 2
  ! - a verbose mode may be activated by adding 1 at the end of the
  ! command line
  !
  ! v 0.1 (Dominique Aubert/SAP) initial version
  !===============================================================
  integer::np1,np2,np3
  real::dx,x1off,x2off,x3off
  real::astart,omegam,omegav,h0
  real::zstart
  character(len=80)::filegraf,fname,fdir,input,output,ncpu_string,commande,fcurr
  character(len=5)::extnum
  character(len=80)::debug_string
  character(len=80),dimension(14)::filename
  logical::verbose=.false.,yorick=.false.
  integer,dimension(:),allocatable::open_flag,open_line
  integer::ncoarse,ncpu,debug

  real(kind=8),dimension(0:2048)::bound_key
  real(kind=8)::dx_loc,x_plan,y_plan,z_plan
  real(kind=8),dimension(:,:),allocatable::plan
  real(kind=8),dimension(1,3)::x

  real(kind=8)::boxlen,dl
  integer::nlevelmax,icoarse_min,icoarse_max,nx_loc
  integer::jcoarse_min,jcoarse_max,kcoarse_min,kcoarse_max,ind
  real(kind=8),dimension(:),allocatable::order,order_min,order_max,order_plan,o
  real(kind=8)::order_all_min,order_all_max

  integer,dimension(:),allocatable::cpu_map,cpu_plan
  integer,dimension(:,:),allocatable::cpu_plan_min,cpu_plan_max

  integer::i1,i2,i3,il,ix,iy,iz,i,minunit,ifile,c

  real(kind=4)::x1o_loc,x2o_loc,x3o_loc
  integer::np1_loc,np2_loc,np3_loc

  integer::nplan,info
  integer::narg
  integer::iargc
  real,dimension(:,:),allocatable::ics
  integer::ncode,bit_length

  common /graficparam/np1,np2,np3,dx,x1off,x2off,x3off,astart,omegam,omegav,h0
  common /ioparam/filegraf
  common /simuparam/boxlen,nlevelmax,icoarse_min,icoarse_max
  common /cpumap/ncpu
  common /ordcom/order_all_min,order_all_max
  common /bound/bound_key
  common /hilbertparam1/nx_loc,ncode,bit_length

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

  !! Command line analysis

  narg=iargc()
  IF(narg .LT. 3)THEN
     write(*,*)'You should type: split_grafic input output ncpu'
     write(*,*)'where directory input should contain GRAFIC files'
     write(*,*)'and directory output should be empty'
     write(*,*)'ncpu MUST BE a power of 2'
     STOP
  END IF

  CALL getarg(1,input)
  CALL getarg(2,output)
  CALL getarg(3,ncpu_string)

  if(narg.eq.4) then
     CALL getarg(4,debug_string)
     read(debug_string,*) debug
     if(debug.eq.1) then
        verbose=.true.
     elseif(debug.eq.2) then
        verbose=.true.
        yorick=.true.
     end if
  end if

  !!Getting the number of cpus
  read(ncpu_string,*) ncpu
  dl=log(real(ncpu))/log(2.)
  if(ncpu.eq.1.or.(dl-int(dl)).ne.0) then
     write(*,*) 'ERROR: ncpu should be a power of 2'
     stop
  end if

  !! Reading the Grafic Header
  filegraf=trim(input)//'/ic_deltab'
  call read_grafic_header

  !! Defining some constants
  zstart=1./astart-1.
  boxlen=np1*dx

  ncoarse=np1*np2*np3

  icoarse_min=1
  icoarse_max=np1

  jcoarse_min=icoarse_min
  jcoarse_max=icoarse_max

  kcoarse_min=icoarse_min
  kcoarse_max=icoarse_max

  ! Hilbert curve domain decomposition
  nx_loc=icoarse_max-icoarse_min+1
  ncode=2*nx_loc
  bit_length=int(log(dble(ncode))/log(2.))+1

  if(verbose) then
     write(*,*) '*************************'
     write(*,*) 'Cosmology found in grafic files'
     write(*,*) 'astart=',astart
     write(*,*) 'zstart=',zstart
     write(*,*) 'omegam=',omegam
     write(*,*) 'omegav=',omegav
     write(*,*) 'h0=',h0
     write(*,*) 'dx (Mpc)=',dx
     write(*,*) 'Boxlen (Mpc)=',boxlen
     write(*,*) '*************************'
  end if

  !! allocation of CPU boundaries
  allocate(cpu_plan(1:ncpu))
  allocate(cpu_plan_min(2,1:ncpu))
  allocate(cpu_plan_max(2,1:ncpu))
  allocate(open_flag(ncpu))
  allocate(open_line(ncpu))
  allocate(ics(np1,np2))

  !! Get Min and Max order
  dx_loc=boxlen
  x(1,:)=0.5*boxlen
  order_all_min=dble(0d0)
  order_all_max=dble(2d0*np1)**3
  if(verbose) write(*,*) 'Minimal Hilbert order =',order_all_min
  if(verbose) write(*,*) 'Maximal Hilbert order =',order_all_max

  !!Bound_keys
  do i=0,ncpu-1
     bound_key(i)=order_all_min+dble(i)/dble(ncpu)*(order_all_max-order_all_min)
  end do
  bound_key(ncpu)=order_all_max

  !! **********
  !! Z Climbing
  !! **********

  ! init files and directories names
  filename(1) = '/ic_deltab'
  filename(2) = '/ic_velcx'
  filename(3) = '/ic_velcy'
  filename(4) = '/ic_velcz'
  filename(5) = '/ic_velbx'
  filename(6) = '/ic_velby'
  filename(7) = '/ic_velbz'

  filename(8) = '/dir_deltab'
  filename(9) = '/dir_velcx'
  filename(10)= '/dir_velcy'
  filename(11)= '/dir_velcz'
  filename(12)= '/dir_velbx'
  filename(13)= '/dir_velby'
  filename(14)= '/dir_velbz'

  if(verbose) write(*,*) 'Z Splitting over ',ncpu,' cpus : Start'

  ! Main loop over grafic files
  do ifile=1,4

     write(*,*) 'Splitting '//filename(ifile)

     !! Creating directory structure
     fdir=trim(output)//filename(ifile+7)
     commande='mkdir '//fdir
!     call system(commande)
     call PXFMKDIR(TRIM(fdir),LEN(TRIM(fdir)),O'755',info)

     !opening ICs files
     open(unit=10,file=trim(input)//filename(ifile),form='unformatted')
     read(10) np1,np2,np3,dx,x1off,x2off,x3off,astart,omegam,omegav,h0

     ! some inits
     minunit=20
     open_flag(:)=-1

     ! main Loop over Grafic planes
     do iz=kcoarse_min,kcoarse_max

        if(verbose) write(*,*) 'Parsing plane #',iz
        z_plan=dble(iz+0.5-kcoarse_min)*2d0

        ! some inits in the plane
        cpu_plan(:)=-1
        cpu_plan_min(:,:)=-1
        cpu_plan_max(:,:)=-1

        ! looking for cpus in current plane
        do iy=jcoarse_min,jcoarse_max
        y_plan=dble(iy+0.5-jcoarse_min)*2d0
           do ix=icoarse_min,icoarse_max
           x_plan=dble(ix+0.5-icoarse_min)*2d0

           call cmp_cpumap(x_plan,y_plan,z_plan,c)

           ! The cpu c has been found
           cpu_plan(c)=1

           ! Looking for Rectangles corners
           if(cpu_plan_min(1,c).eq.-1) then
              cpu_plan_min(1,c)=ix
              cpu_plan_min(2,c)=iy
           end if

           if(ix.gt.cpu_plan_max(1,c))cpu_plan_max(1,c)=ix
           if(iy.gt.cpu_plan_max(2,c))cpu_plan_max(2,c)=iy

           end do
        end do

        ! reading data
        read(10) ((ics(i1,i2),i1=1,np1),i2=1,np2)

        !loop over cpus
        do i=1,ncpu

           ! have the cpu been found in this plane ?
           if(cpu_plan(i).ne.-1) then

              ! is the file already open ? if no we create it
              if(open_flag(i).eq.-1) then

                 open_flag(i)=minunit
                 call title(i,extnum)

                 fcurr=trim(fdir)//filename(ifile)
                 fcurr=trim(fcurr)//'.'
                 fname=trim(fcurr)//trim(extnum)

                 if(verbose) write(*,*) '************  opening file '//fname
                 open(unit=minunit,file=fname,form='unformatted')
                 minunit=minunit+1

                 ! we should write the header
                 np1_loc=cpu_plan_max(1,i)-cpu_plan_min(1,i)+1
                 np2_loc=cpu_plan_max(2,i)-cpu_plan_min(2,i)+1
                 np3_loc=ncoarse/ncpu/np1_loc/np2_loc

                 x1o_loc=real((cpu_plan_min(1,i)-icoarse_min)*dx)
                 x2o_loc=real((cpu_plan_min(2,i)-jcoarse_min)*dx)
                 x3o_loc=real((iz               -kcoarse_min)*dx)

                 write(open_flag(i)) np1_loc,np2_loc,np3_loc,dx,x1o_loc,x2o_loc,x3o_loc,astart,omegam,omegav,h0

                 ! we write the first line of data
                 write(open_flag(i)) ((ics(i1,i2),i1=cpu_plan_min(1,i),cpu_plan_max(1,i)),i2=cpu_plan_min(2,i),cpu_plan_max(2,i))

                 open_line(i)=np3_loc-1

              else

                 ! we write the current line of data
                 write(open_flag(i)) ((ics(i1,i2),i1=cpu_plan_min(1,i),cpu_plan_max(1,i)),i2=cpu_plan_min(2,i),cpu_plan_max(2,i))
                 open_line(i)=open_line(i)-1

                 !we check if the current file is finished and should be closed
                 if(open_line(i).eq.0) then
                    if(verbose) write(*,*) '*********** closing cpu file #',i
                    close(open_flag(i))
                 end if

              end if
           end if
        end do
        !Loop end over the z-planes
     end do

     close(10)
     ! Loop end over the current grafic file
  end do

  if(verbose) write(*,*) 'Z Climbing : Done'

end program spg

!================================================================
!================================================================
!===========SUBROUTINES SECTION ================================
!================================================================
!================================================================
subroutine cmp_cpumap(x,y,z,c)
  implicit none
  integer::c
  real(kind=8)::x,y,z
  integer::ncpu,icpu
  real(kind=8)::order
  real(kind=8),dimension(0:2048)::bound_key
  common /cpumap/ncpu
  common /bound/bound_key
  call cmp_ordering(x,y,z,order)
  c=ncpu ! default value
  do icpu=1,ncpu
     if(    order.ge.bound_key(icpu-1).and. &
          & order.lt.bound_key(icpu  ))then
        c=icpu
     endif
  end do
end subroutine cmp_cpumap
!================================================================
!================================================================
subroutine cmp_ordering(x,y,z,order)
  implicit none
  real(kind=8)::x,y,z,order
  !--------------------------------------------------------
  ! This routine computes the index key of the input cell
  ! according to its position in space and for the chosen
  ! ordering. Position x are in user units.
  !-----------------------------------------------------
  integer::i,ncode,bit_length,nx_loc
  integer,dimension(1)::ix,iy,iz
  real(kind=8),dimension(1)::xorder
  common /hilbertparam1/nx_loc,ncode,bit_length
  ix(1)=int(x)
  iy(1)=int(y)
  iz(1)=int(z)
  call hilbert3d(ix,iy,iz,xorder,bit_length,1)
  order=xorder(1)
end subroutine cmp_ordering
!================================================================
!================================================================
subroutine hilbert3d(x,y,z,order,bit_length,npoint)
  implicit none

  integer     ,INTENT(IN)                     ::bit_length,npoint
  integer     ,INTENT(IN) ,dimension(1:npoint)::x,y,z
  real(kind=8),INTENT(OUT),dimension(1:npoint)::order

  logical,dimension(0:3*bit_length-1)::i_bit_mask
  logical,dimension(0:1*bit_length-1)::x_bit_mask,y_bit_mask,z_bit_mask
  integer,dimension(0:7,0:1,0:11)::state_diagram
  integer::i,ip,cstate,nstate,b0,b1,b2,sdigit,hdigit

  if(bit_length>bit_size(bit_length))then
     write(*,*)'Maximum bit length=',bit_size(bit_length)
     write(*,*)'stop in hilbert3d'
     stop
  endif

  state_diagram = RESHAPE( (/   1, 2, 3, 2, 4, 5, 3, 5,&
                            &   0, 1, 3, 2, 7, 6, 4, 5,&
                            &   2, 6, 0, 7, 8, 8, 0, 7,&
                            &   0, 7, 1, 6, 3, 4, 2, 5,&
                            &   0, 9,10, 9, 1, 1,11,11,&
                            &   0, 3, 7, 4, 1, 2, 6, 5,&
                            &   6, 0, 6,11, 9, 0, 9, 8,&
                            &   2, 3, 1, 0, 5, 4, 6, 7,&
                            &  11,11, 0, 7, 5, 9, 0, 7,&
                            &   4, 3, 5, 2, 7, 0, 6, 1,&
                            &   4, 4, 8, 8, 0, 6,10, 6,&
                            &   6, 5, 1, 2, 7, 4, 0, 3,&
                            &   5, 7, 5, 3, 1, 1,11,11,&
                            &   4, 7, 3, 0, 5, 6, 2, 1,&
                            &   6, 1, 6,10, 9, 4, 9,10,&
                            &   6, 7, 5, 4, 1, 0, 2, 3,&
                            &  10, 3, 1, 1,10, 3, 5, 9,&
                            &   2, 5, 3, 4, 1, 6, 0, 7,&
                            &   4, 4, 8, 8, 2, 7, 2, 3,&
                            &   2, 1, 5, 6, 3, 0, 4, 7,&
                            &   7, 2,11, 2, 7, 5, 8, 5,&
                            &   4, 5, 7, 6, 3, 2, 0, 1,&
                            &  10, 3, 2, 6,10, 3, 4, 4,&
                            &   6, 1, 7, 0, 5, 2, 4, 3 /), &
                            & (/8 ,2, 12 /) )

  do ip=1,npoint

     ! convert to binary
     do i=0,bit_length-1

        x_bit_mask(i)=btest(x(ip),i)
        y_bit_mask(i)=btest(y(ip),i)
        z_bit_mask(i)=btest(z(ip),i)
     enddo

     ! interleave bits
     do i=0,bit_length-1
        i_bit_mask(3*i+2)=x_bit_mask(i)
        i_bit_mask(3*i+1)=y_bit_mask(i)
        i_bit_mask(3*i  )=z_bit_mask(i)
     end do

     ! build Hilbert ordering using state diagram
     cstate=0
     do i=bit_length-1,0,-1
        b2=0 ; if(i_bit_mask(3*i+2))b2=1
        b1=0 ; if(i_bit_mask(3*i+1))b1=1
        b0=0 ; if(i_bit_mask(3*i  ))b0=1
        sdigit=b2*4+b1*2+b0
        nstate=state_diagram(sdigit,0,cstate)
        hdigit=state_diagram(sdigit,1,cstate)
        i_bit_mask(3*i+2)=btest(hdigit,2)
        i_bit_mask(3*i+1)=btest(hdigit,1)
        i_bit_mask(3*i  )=btest(hdigit,0)
        cstate=nstate
     enddo
     ! save Hilbert key as double precision real
     order(ip)=0.
     do i=0,3*bit_length-1
        b0=0 ; if(i_bit_mask(i))b0=1
        order(ip)=order(ip)+dble(b0)*dble(2)**i
     end do

  end do

end subroutine hilbert3d

!================================================================
!================================================================
subroutine read_grafic_header
  implicit none

  integer::np1,np2,np3
  real::dx,x1off,x2off,x3off
  real::astart,omegam,omegav,h0
  character(len=80)::filegraf

  common /graficparam/np1,np2,np3,dx,x1off,x2off,x3off,astart,omegam,omegav,h0
  common /ioparam/filegraf

  open(unit=10,file=trim(filegraf),form='unformatted')
  read(10) np1,np2,np3,dx,x1off,x2off,x3off,astart,omegam,omegav,h0
  close(10)

end subroutine read_grafic_header
!================================================================
!================================================================
!================================================================
!=======================================================================
subroutine title(n,nchar)
!=======================================================================
  implicit none
  integer::n
  character(LEN=5)::nchar

  character(LEN=1)::nchar1
  character(LEN=2)::nchar2
  character(LEN=3)::nchar3
  character(LEN=4)::nchar4
  character(LEN=5)::nchar5

  if(n.ge.10000)then
     write(nchar5,'(i5)') n
     nchar = nchar5
  elseif(n.ge.1000)then
     write(nchar4,'(i4)') n
     nchar = '0'//nchar4
  elseif(n.ge.100)then
     write(nchar3,'(i3)') n
     nchar = '00'//nchar3
  elseif(n.ge.10)then
     write(nchar2,'(i2)') n
     nchar = '000'//nchar2
  else
     write(nchar1,'(i1)') n
     nchar = '0000'//nchar1
  endif

end subroutine title


SUBROUTINE eop_cor2 (mjd , delta_EOP )

! ----------------------------------------------------------------------
! Subroutine:  eop_cor2.f90
! ----------------------------------------------------------------------
! Purpose:
!  Earth Orientation Parameters (EOP) corrections due to tidal variations:
!  - diurnal and semi-diurnal variations in EOP (polar motion, UT1) due to ocean tides
!  - Sub-diurnal libration effects in UT1, LOD and polar motion
!  - Zonal tides effects
! ----------------------------------------------------------------------
! Input arguments:
! - mjd:			Modified Julian Day number of the epoch (in TT)
!
! Output arguments:
! - delta_EOP:		Array of the tidal variations in the Earth Rotation (see Note 1)
! ----------------------------------------------------------------------
! Note1:
! delta_EOP array elements:
! - dxp_ot:			diurnal and semi-diurnal variations in polar motion (xp) due to ocean tides (arcsec)
! - dyp_ot:			diurnal and semi-diurnal variations in polar motion (yp) due to ocean tides (arcsec)
! - dUT1_ot:        diurnal and semi-diurnal variations in UT1 due to ocean tides (sec)
! - dUT1_libr:		Sub-diurnal libration effects on UT1 (sec)
! - dLOD_libr:		Sub-diurnal libration effects on LOD (sec/day)
! - dxp_libr:		Sub-diurnal libration effects on polar motion (arcsec)
! - dyp_libr:		Sub-diurnal libration effects on polar motion (arcsec)
! - DUT_zont2		Zonal tides effect on UT1 (sec)
! - DLOD_zont2		Zonal tides effect on LOD (sec)
! - DOMEGA_zont2	Zonal tides effect on Omega (radians/sec)
! ----------------------------------------------------------------------
! IERS called subroutines for the tidal variations (see IERS Conv.2010 Ch.8)
! - ORTHO_EOP.f:	Diurnal and semi-diurnal variations in polar motion and UT1 due to ocean tides
! - UTLIBR.f:		Sub-diurnal libration effects in UT1 and LOD
! - PMSDNUT2.f:		Sub-diurnal libration effects in polar motion
! - RG_ZONT2.f:		Tidal deformation (zonal tides) corrections
! ----------------------------------------------------------------------
! Dr. Thomas Papanikolaou, Geoscience Australia               March 2016
! ----------------------------------------------------------------------

      USE mdl_precision
      USE mdl_num
      IMPLICIT NONE

! ----------------------------------------------------------------------
! Dummy arguments declaration
! ----------------------------------------------------------------------
! IN
      REAL (KIND = prec_d), INTENT(IN) :: mjd
! OUT
      REAL (KIND = prec_d), INTENT(OUT) :: delta_EOP (10)
! ----------------------------------------------------------------------

! ----------------------------------------------------------------------
! Local variables declaration
! ----------------------------------------------------------------------
      REAL (KIND = prec_d) :: mjd_TT, mjd_GPS, mjd_TAI, mjd_UTC, mjd_UT1
      DOUBLE PRECISION TT1, TT2, TT1_UT1, TT2_UT1, TAI1, TAI2
      INTEGER (KIND = prec_int8) :: mjd_UTC_day
      REAL (KIND = prec_d) :: d_otides(3), PM_libr(2)
      DOUBLE PRECISION dxp_ot, dyp_ot, dUT1_ot, dUT1_libr, dLOD_libr, dxp_libr, dyp_libr
      DOUBLE PRECISION JD_TT, TT_cent, DUT_zont2, DLOD_zont2, DOMEGA_zont2
! ----------------------------------------------------------------------

! ----------------------------------------------------------------------
! Time Systems transformation
! ----------------------------------------------------------------------
      CALL time_TT (mjd , mjd_TT, mjd_GPS, mjd_TAI, mjd_UTC)
! ----------------------------------------------------------------------
! TT
      TT1 = 2400000.5D0
      TT2 = mjd_TT
! ----------------------------------------------------------------------
! TAI
      TAI1 = 2400000.5D0
      TAI2 = mjd_TAI
! ----------------------------------------------------------------------
! UTC
      mjd_UTC_day = INT (mjd_UTC)
! ----------------------------------------------------------------------

! ----------------------------------------------------------------------
! Diurnal and semi-diurnal variations in polar motion and UT1 due to ocean tides.
! - Subroutine ORTHO_EOP.f
      CALL ORTHO_EOP ( mjd_UTC, d_otides )
      dxp_ot  = d_otides (1)  ! delta_x, in microarcseconds
      dyp_ot  = d_otides (2)  ! delta_y, in microarcseconds
      dUT1_ot = d_otides (3)  ! delta_UT1, in microseconds
! ----------------------------------------------------------------------

! ----------------------------------------------------------------------
! Sub-diurnal libration effects in UT1 and LOD
! - UTLIBR.f  :  DUT1 (microseconds), DLOD (microseconds/day)
      CALL UTLIBR (mjd_UTC, dUT1_libr, dLOD_libr)
! ----------------------------------------------------------------------

! ----------------------------------------------------------------------
! Sub-diurnal libration effects in polar motion
! - PMSDNUT2.f  :  (dxp,dyp) in microarcseconds
      CALL PMSDNUT2 (mjd_UTC, PM_libr)
      dxp_libr = PM_libr (1)
      dyp_libr = PM_libr (2)
! ----------------------------------------------------------------------

! ----------------------------------------------------------------------
! Tidal deformation (zonal tides) corrections
! ----------------------------------------------------------------------
      JD_TT = mjd_TT + 2400000.5D0
      TT_cent = (JD_TT - 2451545.0D0) / 36525D0
      CALL RG_ZONT2 ( TT_cent, DUT_zont2, DLOD_zont2, DOMEGA_zont2 )
! ----------------------------------------------------------------------
      !PRINT *,"-------------------- Zonal tides ----------------------"
      !PRINT *,"DUT_zont2"   , DUT_zont2
      !PRINT *,"DLOD_zont2"  , DLOD_zont2
      !PRINT *,"DOMEGA_zont2", DOMEGA_zont2
      !PRINT *,"------------------------------------------------------"
      !PRINT *," "

! ----------------------------------------------------------------------
! - dxp_ot:			diurnal and semi-diurnal variations in polar motion (xp) due to ocean tides (arcsec)
! - dyp_ot:			diurnal and semi-diurnal variations in polar motion (yp) due to ocean tides (arcsec)
! - dUT1_ot:        diurnal and semi-diurnal variations in UT1 due to ocean tides (sec)
! - dUT1_libr:		Sub-diurnal libration effects on UT1 (sec)
! - dLOD_libr:		Sub-diurnal libration effects on LOD (sec/day)
! - dxp_libr:		Sub-diurnal libration effects on polar motion (arcsec)
! - dyp_libr:		Sub-diurnal libration effects on polar motion (arcsec)
! - DUT_zont2		Zonal tides effect on UT1 (sec)
! - DLOD_zont2		Zonal tides effect on LOD (sec)
! - DOMEGA_zont2	Zonal tides effect on rotation velocity (radians/sec)
      delta_EOP (1) = dxp_ot * 1.0D-6
      delta_EOP (2) = dyp_ot * 1.0D-6
      delta_EOP (3) = dUT1_ot * 1.0D-6
      delta_EOP (4) = dUT1_libr * 1.0D-6
      delta_EOP (5) = dLOD_libr * 1.0D-6
      delta_EOP (6) = dxp_libr * 1.0D-6
      delta_EOP (7) = dyp_libr * 1.0D-6
      delta_EOP (8) = DUT_zont2
      delta_EOP (9) = DLOD_zont2
      delta_EOP (10) = DOMEGA_zont2
! ----------------------------------------------------------------------

END


      module m_matriz
        implicit none
        private

        type, public :: tipo_matriz(filas, columnas, k)
            integer, len :: filas, columnas
            integer, kind :: k = kind(0.0)
            real(kind=k), dimension(filas,columnas) :: valores
        end type
      end module m_matriz

      program testear_matriz
        use m_matriz
        implicit none
        type(tipo_matriz(filas=5,columnas=5)) :: m
        print *,m
      end program testear_matriz


MODULE InitializationModule

  USE KindModule, ONLY: &
    DP, Zero, Half, One, Three, &
    Pi, TwoPi, FourPi
  USE ProgramHeaderModule, ONLY: &
    ProgramName, &
    nX, nNodesX, &
    nDOFX
  USE ReferenceElementModuleX, ONLY: &
    NodeNumberTableX
  USE MeshModule, ONLY: &
    MeshX, &
    NodeCoordinate
  USE GeometryFieldsModule, ONLY: &
    uGF, iGF_Phi_N, iGF_Gm_dd_11, iGF_Gm_dd_22, iGF_Gm_dd_33
  USE FluidFieldsModule, ONLY: &
    uPF, iPF_D, iPF_V1, iPF_V2, iPF_V3, iPF_E, iPF_Ne, &
    uCF, iCF_D, iCF_S1, iCF_S2, iCF_S3, iCF_E, iCF_Ne, &
    uAF
  USE Euler_UtilitiesModule_NonRelativistic, ONLY: &
    ComputeConserved_Euler_NonRelativistic

  IMPLICIT NONE
  PRIVATE

  PUBLIC :: InitializeFields

CONTAINS

  SUBROUTINE InitializeFields &
    ( AdvectionProfile_Option, Direction_Option, RiemannProblemName_Option, &
      SedovEnergy_Option, nDetCells_Option )

    CHARACTER(LEN=*), INTENT(in), OPTIONAL :: &
      AdvectionProfile_Option
    CHARACTER(LEN=*), INTENT(in), OPTIONAL :: &
      Direction_Option
    CHARACTER(LEN=*), INTENT(in), OPTIONAL :: &
      RiemannProblemName_Option

    REAL(DP), INTENT(in), OPTIONAL :: SedovEnergy_Option

    INTEGER, INTENT(in), OPTIONAL :: nDetCells_Option

    WRITE(*,*)
    WRITE(*,'(A2,A6,A)') '', 'INFO: ', TRIM( ProgramName )

    SELECT CASE ( TRIM( ProgramName ) )

      CASE( 'Advection' )

        CALL InitializeFields_Advection &
               ( AdvectionProfile_Option &
                   = AdvectionProfile_Option, &
                 Direction_Option &
                   = Direction_Option )

      CASE ( 'RiemannProblem' )

        CALL InitializeFields_RiemannProblem &
               ( RiemannProblemName_Option &
                   = RiemannProblemName_Option )

      CASE ( 'RiemannProblemSpherical' )

        CALL InitializeFields_RiemannProblemSpherical

      CASE ( 'SphericalSedov' )

        CALL InitializeFields_SphericalSedov &
               ( SedovEnergy_Option &
                   = SedovEnergy_Option, &
                 nDetCells_Option &
                   = nDetCells_Option )

      CASE( 'IsentropicVortex' )

        CALL InitializeFields_IsentropicVortex

      CASE( 'KelvinHelmholtz' )

        CALL InitializeFields_KelvinHelmholtz

      CASE( 'RayleighTaylor' )

        CALL InitializeFields_RayleighTaylor

      CASE( 'Implosion' )

        CALL InitializeFields_Implosion

      CASE( 'Explosion' )

        CALL InitializeFields_Explosion

    END SELECT

  END SUBROUTINE InitializeFields

  SUBROUTINE InitializeFields_Advection &
    ( AdvectionProfile_Option, Direction_Option )

    CHARACTER(LEN=*), INTENT(in), OPTIONAL :: &
      AdvectionProfile_Option
    CHARACTER(LEN=*), INTENT(in), OPTIONAL :: &
      Direction_Option

    REAL(DP), PARAMETER :: Amp = 0.1_DP

    CHARACTER(32) :: AdvectionProfile
    CHARACTER(32) :: Direction
    INTEGER       :: iX1, iX2, iX3
    INTEGER       :: iNodeX, iNodeX1, iNodeX2
    REAL(DP)      :: X1, X2

    AdvectionProfile = 'SineWave'
    IF( PRESENT( AdvectionProfile_Option ) ) &
      AdvectionProfile = TRIM( AdvectionProfile_Option )

    Direction = 'X'
    IF( PRESENT( Direction_Option ) ) &
      Direction = Direction_Option

    WRITE(*,*)
    WRITE(*,'(A4,A20,A)') &
      '', 'Advection Profile: ', TRIM( AdvectionProfile )
    WRITE(*,'(A4,A20,A)') &
      '', 'Direction: ', TRIM( Direction )

    DO iX3 = 1, nX(3)
      DO iX2 = 1, nX(2)
        DO iX1 = 1, nX(1)

          DO iNodeX = 1, nDOFX

            iNodeX1 = NodeNumberTableX(1,iNodeX)
            iNodeX2 = NodeNumberTableX(2,iNodeX)

            X1 = NodeCoordinate( MeshX(1), iX1, iNodeX1 )
            X2 = NodeCoordinate( MeshX(2), iX2, iNodeX2 )

            SELECT CASE ( TRIM( AdvectionProfile ) )

              CASE( 'SineWave' )

                IF( TRIM( Direction ) .EQ. 'X' )THEN

                  uPF(iNodeX,iX1,iX2,iX3,iPF_D) &
                    = One + Amp * SIN( TwoPi * X1 )

                ELSEIF( TRIM( Direction ) .EQ. 'Y' )THEN

                  uPF(iNodeX,iX1,iX2,iX3,iPF_D) &
                    = One + Amp * SIN( TwoPi * X2 )

                END IF

              CASE( 'QuarticSineWave' )

                IF( TRIM( Direction ) .EQ. 'X' )THEN

                  uPF(iNodeX,iX1,iX2,iX3,iPF_D) &
                    = One + Amp * SIN( Pi * X1 )**4

                ELSEIF( TRIM( Direction ) .EQ. 'Y' )THEN

                  uPF(iNodeX,iX1,iX2,iX3,iPF_D) &
                    = One + Amp * SIN( Pi * X2 )**4

                END IF

              CASE( 'TopHat' )

                IF( TRIM( Direction ) .EQ. 'X' )THEN

                  IF( ABS( X1 - 0.5_DP ) .LE. 0.25_DP )THEN

                    uPF(iNodeX,iX1,iX2,iX3,iPF_D) = 2.0_DP

                  ELSE

                    uPF(iNodeX,iX1,iX2,iX3,iPF_D) = 1.0_DP

                  END IF

                ELSEIF( TRIM( Direction ) .EQ. 'Y' )THEN

                  IF( ABS( X2 - 0.5_DP ) .LE. 0.25_DP )THEN

                    uPF(iNodeX,iX1,iX2,iX3,iPF_D) = 2.0_DP

                  ELSE

                    uPF(iNodeX,iX1,iX2,iX3,iPF_D) = 1.0_DP

                  END IF

                ELSEIF( TRIM( Direction ) .EQ. 'XY' )THEN

                  IF( ( ABS( X1 - 0.5_DP ) .LE. 0.25_DP ) &
                      .AND. ( ABS( X2 - 0.5_DP ) .LE. 0.25_DP ) )THEN

                    uPF(iNodeX,iX1,iX2,iX3,iPF_D) = 2.0_DP

                  ELSE

                    uPF(iNodeX,iX1,iX2,iX3,iPF_D) = 1.0_DP

                  END IF

                END IF

            END SELECT

            IF( TRIM( Direction ) .EQ. 'X' )THEN

              uPF(iNodeX,iX1,iX2,iX3,iPF_V1) = 1.0_DP
              uPF(iNodeX,iX1,iX2,iX3,iPF_V2) = 0.0_DP
              uPF(iNodeX,iX1,iX2,iX3,iPF_V3) = 0.0_DP

            ELSEIF( TRIM( Direction ) .EQ. 'Y' )THEN

              uPF(iNodeX,iX1,iX2,iX3,iPF_V1) = 0.0_DP
              uPF(iNodeX,iX1,iX2,iX3,iPF_V2) = 1.0_DP
              uPF(iNodeX,iX1,iX2,iX3,iPF_V3) = 0.0_DP

            ELSEIF( TRIM( Direction ) .EQ. 'XY' )THEN

              uPF(iNodeX,iX1,iX2,iX3,iPF_V1) = 1.0_DP / SQRT( 2.0_DP )
              uPF(iNodeX,iX1,iX2,iX3,iPF_V2) = 0.5_DP / SQRT( 2.0_DP )
              uPF(iNodeX,iX1,iX2,iX3,iPF_V3) = 0.0_DP

            END IF

            uPF(iNodeX,iX1,iX2,iX3,iPF_E) = 1.0d-2

          END DO

          CALL ComputeConserved_Euler_NonRelativistic &
                 ( uPF(:,iX1,iX2,iX3,iPF_D ), uPF(:,iX1,iX2,iX3,iPF_V1), &
                   uPF(:,iX1,iX2,iX3,iPF_V2), uPF(:,iX1,iX2,iX3,iPF_V3), &
                   uPF(:,iX1,iX2,iX3,iPF_E ), uPF(:,iX1,iX2,iX3,iPF_Ne), &
                   uCF(:,iX1,iX2,iX3,iCF_D ), uCF(:,iX1,iX2,iX3,iCF_S1), &
                   uCF(:,iX1,iX2,iX3,iCF_S2), uCF(:,iX1,iX2,iX3,iCF_S3), &
                   uCF(:,iX1,iX2,iX3,iCF_E ), uCF(:,iX1,iX2,iX3,iCF_Ne), &
                   uGF(:,iX1,iX2,iX3,iGF_Gm_dd_11), &
                   uGF(:,iX1,iX2,iX3,iGF_Gm_dd_22), &
                   uGF(:,iX1,iX2,iX3,iGF_Gm_dd_33) )

        END DO
      END DO
    END DO

  END SUBROUTINE InitializeFields_Advection

  SUBROUTINE InitializeFields_RiemannProblem &
    ( RiemannProblemName_Option )

    CHARACTER(LEN=*), INTENT(in), OPTIONAL :: &
      RiemannProblemName_Option

    CHARACTER(32) :: RiemannProblemName
    INTEGER       :: iX1, iX2, iX3
    INTEGER       :: iNodeX, iNodeX1
    REAL(DP)      :: X1

    RiemannProblemName = 'Sod'
    IF( PRESENT( RiemannProblemName_Option ) ) &
       RiemannProblemName = TRIM( RiemannProblemName_Option )

    WRITE(*,*)
    WRITE(*,'(A4,A,A)') &
      '', 'Riemann Problem Name: ', TRIM( RiemannProblemName )

    DO iX3 = 1, nX(3)
      DO iX2 = 1, nX(2)
        DO iX1 = 1, nX(1)

          DO iNodeX = 1, nDOFX

            iNodeX1 = NodeNumberTableX(1,iNodeX)

            X1 = NodeCoordinate( MeshX(1), iX1, iNodeX1 )

            SELECT CASE ( TRIM( RiemannProblemName ) )

              CASE( 'Sod' )

                IF( X1 <= Half )THEN

                  uPF(iNodeX,iX1,iX2,iX3,iPF_D)  = 1.0_DP
                  uPF(iNodeX,iX1,iX2,iX3,iPF_V1) = 0.0_DP
                  uPF(iNodeX,iX1,iX2,iX3,iPF_V2) = 0.0_DP
                  uPF(iNodeX,iX1,iX2,iX3,iPF_V3) = 0.0_DP
                  uPF(iNodeX,iX1,iX2,iX3,iPF_E)  = 1.0_DP / 0.4_DP

                ELSE

                  uPF(iNodeX,iX1,iX2,iX3,iPF_D)  = 0.125_DP
                  uPF(iNodeX,iX1,iX2,iX3,iPF_V1) = 0.0_DP
                  uPF(iNodeX,iX1,iX2,iX3,iPF_V2) = 0.0_DP
                  uPF(iNodeX,iX1,iX2,iX3,iPF_V3) = 0.0_DP
                  uPF(iNodeX,iX1,iX2,iX3,iPF_E)  = 0.1_DP / 0.4_DP

                END IF

              CASE( 'SteadyContact' )

                IF( X1 <= Half )THEN

                  uPF(iNodeX,iX1,iX2,iX3,iPF_D)  = 1.4_DP
                  uPF(iNodeX,iX1,iX2,iX3,iPF_V1) = 0.0_DP
                  uPF(iNodeX,iX1,iX2,iX3,iPF_V2) = 0.0_DP
                  uPF(iNodeX,iX1,iX2,iX3,iPF_V3) = 0.0_DP
                  uPF(iNodeX,iX1,iX2,iX3,iPF_E)  = 1.0_DP / 0.4_DP

                ELSE

                  uPF(iNodeX,iX1,iX2,iX3,iPF_D)  = 1.0_DP
                  uPF(iNodeX,iX1,iX2,iX3,iPF_V1) = 0.0_DP
                  uPF(iNodeX,iX1,iX2,iX3,iPF_V2) = 0.0_DP
                  uPF(iNodeX,iX1,iX2,iX3,iPF_V3) = 0.0_DP
                  uPF(iNodeX,iX1,iX2,iX3,iPF_E)  = 1.0_DP / 0.4_DP

                END IF

              CASE( 'MovingContact' )

                IF( X1 <= Half )THEN

                  uPF(iNodeX,iX1,iX2,iX3,iPF_D)  = 1.4_DP
                  uPF(iNodeX,iX1,iX2,iX3,iPF_V1) = 0.1_DP
                  uPF(iNodeX,iX1,iX2,iX3,iPF_V2) = 0.0_DP
                  uPF(iNodeX,iX1,iX2,iX3,iPF_V3) = 0.0_DP
                  uPF(iNodeX,iX1,iX2,iX3,iPF_E)  = 1.0_DP / 0.4_DP

                ELSE

                  uPF(iNodeX,iX1,iX2,iX3,iPF_D)  = 1.0_DP
                  uPF(iNodeX,iX1,iX2,iX3,iPF_V1) = 0.1_DP
                  uPF(iNodeX,iX1,iX2,iX3,iPF_V2) = 0.0_DP
                  uPF(iNodeX,iX1,iX2,iX3,iPF_V3) = 0.0_DP
                  uPF(iNodeX,iX1,iX2,iX3,iPF_E)  = 1.0_DP / 0.4_DP

                END IF

              CASE( 'Toro' )

              CASE( 'InteractingBlasts' )

              CASE( 'ShockEntropyWave' )

                IF( X1 < -4.0_DP )THEN

                  uPF(iNodeX,iX1,iX2,iX3,iPF_D)  = 3.857143_DP
                  uPF(iNodeX,iX1,iX2,iX3,iPF_V1) = 2.629369_DP
                  uPF(iNodeX,iX1,iX2,iX3,iPF_V2) = 0.0_DP
                  uPF(iNodeX,iX1,iX2,iX3,iPF_V3) = 0.0_DP
                  uPF(iNodeX,iX1,iX2,iX3,iPF_E)  = 10.333333_DP / 0.4_DP

                ELSE

                  uPF(iNodeX,iX1,iX2,iX3,iPF_D)  = 1.0_DP + 0.2 * SIN(5*X1)
                  uPF(iNodeX,iX1,iX2,iX3,iPF_V1) = 0.0_DP
                  uPF(iNodeX,iX1,iX2,iX3,iPF_V2) = 0.0_DP
                  uPF(iNodeX,iX1,iX2,iX3,iPF_V3) = 0.0_DP
                  uPF(iNodeX,iX1,iX2,iX3,iPF_E)  = 1.0_DP / 0.4_DP

                END IF

            END SELECT

          END DO

          CALL ComputeConserved_Euler_NonRelativistic &
                 ( uPF(:,iX1,iX2,iX3,iPF_D ), uPF(:,iX1,iX2,iX3,iPF_V1), &
                   uPF(:,iX1,iX2,iX3,iPF_V2), uPF(:,iX1,iX2,iX3,iPF_V3), &
                   uPF(:,iX1,iX2,iX3,iPF_E ), uPF(:,iX1,iX2,iX3,iPF_Ne), &
                   uCF(:,iX1,iX2,iX3,iCF_D ), uCF(:,iX1,iX2,iX3,iCF_S1), &
                   uCF(:,iX1,iX2,iX3,iCF_S2), uCF(:,iX1,iX2,iX3,iCF_S3), &
                   uCF(:,iX1,iX2,iX3,iCF_E ), uCF(:,iX1,iX2,iX3,iCF_Ne), &
                   uGF(:,iX1,iX2,iX3,iGF_Gm_dd_11), &
                   uGF(:,iX1,iX2,iX3,iGF_Gm_dd_22), &
                   uGF(:,iX1,iX2,iX3,iGF_Gm_dd_33) )

        END DO
      END DO
    END DO

  END SUBROUTINE InitializeFields_RiemannProblem

  SUBROUTINE InitializeFields_RiemannProblemSpherical

    INTEGER       :: iX1, iX2, iX3
    INTEGER       :: iNodeX, iNodeX1
    REAL(DP)      :: X1

    DO iX3 = 1, nX(3)
      DO iX2 = 1, nX(2)
        DO iX1 = 1, nX(1)

          DO iNodeX = 1, nDOFX

            iNodeX1 = NodeNumberTableX(1,iNodeX)

            X1 = NodeCoordinate( MeshX(1), iX1, iNodeX1 )

            IF( X1 <= One )THEN

              uPF(iNodeX,iX1,iX2,iX3,iPF_D)  = 1.0_DP
              uPF(iNodeX,iX1,iX2,iX3,iPF_V1) = 0.0_DP
              uPF(iNodeX,iX1,iX2,iX3,iPF_V2) = 0.0_DP
              uPF(iNodeX,iX1,iX2,iX3,iPF_V3) = 0.0_DP
              uPF(iNodeX,iX1,iX2,iX3,iPF_E)  = 1.0_DP / 0.4_DP

            ELSE

              uPF(iNodeX,iX1,iX2,iX3,iPF_D)  = 0.125_DP
              uPF(iNodeX,iX1,iX2,iX3,iPF_V1) = 0.0_DP
              uPF(iNodeX,iX1,iX2,iX3,iPF_V2) = 0.0_DP
              uPF(iNodeX,iX1,iX2,iX3,iPF_V3) = 0.0_DP
              uPF(iNodeX,iX1,iX2,iX3,iPF_E)  = 0.1_DP / 0.4_DP

            END IF

          END DO

          CALL ComputeConserved_Euler_NonRelativistic &
                 ( uPF(:,iX1,iX2,iX3,iPF_D ), uPF(:,iX1,iX2,iX3,iPF_V1), &
                   uPF(:,iX1,iX2,iX3,iPF_V2), uPF(:,iX1,iX2,iX3,iPF_V3), &
                   uPF(:,iX1,iX2,iX3,iPF_E ), uPF(:,iX1,iX2,iX3,iPF_Ne), &
                   uCF(:,iX1,iX2,iX3,iCF_D ), uCF(:,iX1,iX2,iX3,iCF_S1), &
                   uCF(:,iX1,iX2,iX3,iCF_S2), uCF(:,iX1,iX2,iX3,iCF_S3), &
                   uCF(:,iX1,iX2,iX3,iCF_E ), uCF(:,iX1,iX2,iX3,iCF_Ne), &
                   uGF(:,iX1,iX2,iX3,iGF_Gm_dd_11), &
                   uGF(:,iX1,iX2,iX3,iGF_Gm_dd_22), &
                   uGF(:,iX1,iX2,iX3,iGF_Gm_dd_33) )

        END DO
      END DO
    END DO

  END SUBROUTINE InitializeFields_RiemannProblemSpherical

  SUBROUTINE InitializeFields_SphericalSedov &
    ( SedovEnergy_Option, nDetCells_Option )

    REAL(DP), INTENT(in), OPTIONAL :: SedovEnergy_Option
    INTEGER,  INTENT(in), OPTIONAL :: nDetCells_Option

    INTEGER  :: iX1, iX2, iX3, nDetCells
    INTEGER  :: iNodeX, iNodeX1
    REAL(DP) :: X1, R_0, E_0

    nDetCells = 1
    IF( PRESENT( nDetCells_Option ) ) &
      nDetCells = nDetCells_Option

    E_0 = 1.0_DP
    IF( PRESENT( SedovEnergy_Option ) ) &
      E_0 = SedovEnergy_Option

    R_0 = REAL( nDetCells ) * MeshX(1) % Width(1)

    WRITE(*,*)
    WRITE(*,'(A7,A,ES10.3E2,A2,I2.2,A2,ES10.3E2)') &
      '', 'E_0, # of Detonation Cells, R_0 = ', E_0, ', ', nDetCells, ',', R_0

    DO iX3 = 1, nX(3)
      DO iX2 = 1, nX(2)
        DO iX1 = 1, nX(1)

          DO iNodeX = 1, nDOFX

            iNodeX1 = NodeNumberTableX(1,iNodeX)

            X1 = NodeCoordinate( MeshX(1), iX1, iNodeX1 )

            uPF(iNodeX,iX1,iX2,iX3,iPF_D)  = 1.0_DP
            uPF(iNodeX,iX1,iX2,iX3,iPF_V1) = 0.0_DP
            uPF(iNodeX,iX1,iX2,iX3,iPF_V2) = 0.0_DP
            uPF(iNodeX,iX1,iX2,iX3,iPF_V3) = 0.0_DP

            IF( X1 < R_0 )THEN

              uPF(iNodeX,iX1,iX2,iX3,iPF_E) = 3.0_DP * E_0 &
                                            / ( 4.0_DP * Pi * R_0**3 )

            ELSE

              uPF(iNodeX,iX1,iX2,iX3,iPF_E) = 1.0d-5

            END IF

          END DO

          CALL ComputeConserved_Euler_NonRelativistic &
                 ( uPF(:,iX1,iX2,iX3,iPF_D ), uPF(:,iX1,iX2,iX3,iPF_V1), &
                   uPF(:,iX1,iX2,iX3,iPF_V2), uPF(:,iX1,iX2,iX3,iPF_V3), &
                   uPF(:,iX1,iX2,iX3,iPF_E ), uPF(:,iX1,iX2,iX3,iPF_Ne), &
                   uCF(:,iX1,iX2,iX3,iCF_D ), uCF(:,iX1,iX2,iX3,iCF_S1), &
                   uCF(:,iX1,iX2,iX3,iCF_S2), uCF(:,iX1,iX2,iX3,iCF_S3), &
                   uCF(:,iX1,iX2,iX3,iCF_E ), uCF(:,iX1,iX2,iX3,iCF_Ne), &
                   uGF(:,iX1,iX2,iX3,iGF_Gm_dd_11), &
                   uGF(:,iX1,iX2,iX3,iGF_Gm_dd_22), &
                   uGF(:,iX1,iX2,iX3,iGF_Gm_dd_33) )

        END DO
      END DO
    END DO

  END SUBROUTINE

  SUBROUTINE InitializeFields_IsentropicVortex

    INTEGER  :: iX1, iX2, iX3
    INTEGER  :: iNodeX, iNodeX1, iNodeX2
    REAL(DP) :: X1, X2, R

    REAL(DP), PARAMETER :: Beta  = 5.0_DP
    REAL(DP), PARAMETER :: Gamma = 1.4_DP

    DO iX3 = 1, nX(3)
    DO iX2 = 1, nX(2)
    DO iX1 = 1, nX(1)

      DO iNodeX = 1, nDOFX

        iNodeX1 = NodeNumberTableX(1,iNodeX)
        iNodeX2 = NodeNumberTableX(2,iNodeX)

        X1 = NodeCoordinate( MeshX(1), iX1, iNodeX1 )
        X2 = NodeCoordinate( MeshX(2), iX2, iNodeX2 )

        R  = SQRT( X1**2 + X2**2 )

        uPF(iNodeX,iX1,iX2,iX3,iPF_D) &
          = ( One - ( Gamma - One ) * Beta**2 &
                    / ( 8.0_DP * Gamma * Pi**2 ) * EXP( One - R**2 ) &
            )**( One / ( Gamma - One ) )

        uPF(iNodeX,iX1,iX2,iX3,iPF_V1) &
          = One &
            - X2 * ( Beta / TwoPi ) * EXP( Half * ( One - R**2 ) )

        uPF(iNodeX,iX1,iX2,iX3,iPF_V2) &
          = One &
            + X1 * ( Beta / TwoPi ) * EXP( Half * ( One - R**2 ) )

        uPF(iNodeX,iX1,iX2,iX3,iPF_V3) &
          = 0.0_DP

        uPF(iNodeX,iX1,iX2,iX3,iPF_E) &
          = uPF(iNodeX,iX1,iX2,iX3,iPF_D)**Gamma / ( Gamma - One )

      END DO

      CALL ComputeConserved_Euler_NonRelativistic &
             ( uPF(:,iX1,iX2,iX3,iPF_D ), uPF(:,iX1,iX2,iX3,iPF_V1), &
               uPF(:,iX1,iX2,iX3,iPF_V2), uPF(:,iX1,iX2,iX3,iPF_V3), &
               uPF(:,iX1,iX2,iX3,iPF_E ), uPF(:,iX1,iX2,iX3,iPF_Ne), &
               uCF(:,iX1,iX2,iX3,iCF_D ), uCF(:,iX1,iX2,iX3,iCF_S1), &
               uCF(:,iX1,iX2,iX3,iCF_S2), uCF(:,iX1,iX2,iX3,iCF_S3), &
               uCF(:,iX1,iX2,iX3,iCF_E ), uCF(:,iX1,iX2,iX3,iCF_Ne), &
               uGF(:,iX1,iX2,iX3,iGF_Gm_dd_11), &
               uGF(:,iX1,iX2,iX3,iGF_Gm_dd_22), &
               uGF(:,iX1,iX2,iX3,iGF_Gm_dd_33) )

    END DO
    END DO
    END DO

  END SUBROUTINE InitializeFields_IsentropicVortex

  SUBROUTINE InitializeFields_KelvinHelmholtz

    INTEGER  :: iX1, iX2, iX3
    INTEGER  :: iNodeX, iNodeX1, iNodeX2
    REAL(DP) :: X1, X2, D_M, V_M
    REAL(DP), PARAMETER :: D_1 = 1.0_DP
    REAL(DP), PARAMETER :: D_2 = 2.0_DP
    REAL(DP), PARAMETER :: L = 0.025_DP
    REAL(DP), PARAMETER :: V_1 = + 0.5_DP
    REAL(DP), PARAMETER :: V_2 = - 0.5_DP

    D_M = Half * ( D_1 - D_2 )
    V_M = Half * ( V_1 - V_2 )

    DO iX3 = 1, nX(3)
      DO iX2 = 1, nX(2)
        DO iX1 = 1, nX(1)

          DO iNodeX = 1, nDOFX

            iNodeX1 = NodeNumberTableX(1,iNodeX)
            iNodeX2 = NodeNumberTableX(2,iNodeX)

            X1 = NodeCoordinate( MeshX(1), iX1, iNodeX1 )
            X2 = NodeCoordinate( MeshX(2), iX2, iNodeX2 )

            IF(     ( X2 .GE. 0.00_DP ) .AND. ( X2 .LT. 0.25_DP ) )THEN

              uPF(iNodeX,iX1,iX2,iX3,iPF_D) &
                = D_1 - D_M * EXP( ( X2 - 0.25_DP ) / L )
              uPF(iNodeX,iX1,iX2,iX3,iPF_V1) &
                = V_1 - V_M * EXP( ( X2 - 0.25_DP ) / L )

            ELSEIF( ( X2 .GE. 0.25_DP ) .AND. ( X2 .LT. 0.50_DP ) )THEN

              uPF(iNodeX,iX1,iX2,iX3,iPF_D) &
                = D_2 + D_M * EXP( ( 0.25_DP - X2 ) / L )
              uPF(iNodeX,iX1,iX2,iX3,iPF_V1) &
                = V_2 + V_M * EXP( ( 0.25_DP - X2 ) / L )

            ELSEIF( ( X2 .GE. 0.50_DP ) .AND. ( X2 .LT. 0.75_DP ) )THEN

              uPF(iNodeX,iX1,iX2,iX3,iPF_D) &
                = D_2 + D_M * EXP( ( X2 - 0.75_DP ) / L )
              uPF(iNodeX,iX1,iX2,iX3,iPF_V1) &
                = V_2 + V_M * EXP( ( X2 - 0.75_DP ) / L )

            ELSEIF( ( X2 .GE. 0.75_DP ) .AND. ( X2 .LT. 1.00_DP ) )THEN

              uPF(iNodeX,iX1,iX2,iX3,iPF_D) &
                = D_1 - D_M * EXP( ( 0.75_DP - X2 ) / L )
              uPF(iNodeX,iX1,iX2,iX3,iPF_V1) &
                = V_1 - V_M * EXP( ( 0.75_DP - X2 ) / L )

            END IF

            uPF(iNodeX,iX1,iX2,iX3,iPF_V2) &
              = 0.01_DP * SIN( FourPi * X1 )
            uPF(iNodeX,iX1,iX2,iX3,iPF_V3) &
              = Zero
            uPF(iNodeX,iX1,iX2,iX3,iPF_E) &
              = 3.75_DP

          END DO

          CALL ComputeConserved_Euler_NonRelativistic &
                 ( uPF(:,iX1,iX2,iX3,iPF_D ), uPF(:,iX1,iX2,iX3,iPF_V1), &
                   uPF(:,iX1,iX2,iX3,iPF_V2), uPF(:,iX1,iX2,iX3,iPF_V3), &
                   uPF(:,iX1,iX2,iX3,iPF_E ), uPF(:,iX1,iX2,iX3,iPF_Ne), &
                   uCF(:,iX1,iX2,iX3,iCF_D ), uCF(:,iX1,iX2,iX3,iCF_S1), &
                   uCF(:,iX1,iX2,iX3,iCF_S2), uCF(:,iX1,iX2,iX3,iCF_S3), &
                   uCF(:,iX1,iX2,iX3,iCF_E ), uCF(:,iX1,iX2,iX3,iCF_Ne), &
                   uGF(:,iX1,iX2,iX3,iGF_Gm_dd_11), &
                   uGF(:,iX1,iX2,iX3,iGF_Gm_dd_22), &
                   uGF(:,iX1,iX2,iX3,iGF_Gm_dd_33) )

        END DO
      END DO
    END DO

  END SUBROUTINE InitializeFields_KelvinHelmholtz

  SUBROUTINE InitializeFields_RayleighTaylor

    INTEGER  :: iX1, iX2, iX3
    INTEGER  :: iNodeX, iNodeX1, iNodeX2
    REAL(DP) :: X1, X2

    REAL(DP), PARAMETER :: D_1  = 1.0_DP
    REAL(DP), PARAMETER :: D_2  = 2.0_DP
    REAL(DP), PARAMETER :: X1_b = - 0.75_DP
    REAL(DP), PARAMETER :: E_b  = 2.5_DP / 0.4_DP
    REAL(DP), PARAMETER :: g    = 0.1_DP

    DO iX3 = 1, nX(3)
       DO iX2 = 1, nX(2)
          DO iX1 = 0, nX(1) + 1

             DO iNodeX = 1, nDOFX

                iNodeX1 = NodeNumberTableX(1,iNodeX)
                iNodeX2 = NodeNumberTableX(2,iNodeX)

                X1 = NodeCoordinate( MeshX(1), iX1, iNodeX1 )
                X2 = NodeCoordinate( MeshX(2), iX2, iNodeX2 )

                IF( X1 .LE. 0.0_DP )THEN

                  uPF(iNodeX,iX1,iX2,iX3,iPF_D) = D_1

                ELSE

                  uPF(iNodeX,iX1,iX2,iX3,iPF_D) = D_2

                END IF

                uPF(iNodeX,iX1,iX2,iX3,iPF_V1) &
                  = 0.0025_DP * ( One + COS( FourPi * X2 ) ) &
                      * ( One + COS( Three * Pi * X1 ) )
                uPF(iNodeX,iX1,iX2,iX3,iPF_V2) &
                  = 0.0_DP
                uPF(iNodeX,iX1,iX2,iX3,iPF_V3) &
                  = 0.0_DP

                uPF(iNodeX,iX1,iX2,iX3,iPF_E) &
                  = E_b - g * D_1 * ( MIN( X1, 0.0_DP ) - X1_b ) &
                        - g * D_2 * MAX( X1, 0.0_DP )

                uGF(iNodeX,iX1,iX2,iX3,iGF_Phi_N) &
                  = g * X1

             END DO

             CALL ComputeConserved_Euler_NonRelativistic &
                 ( uPF(:,iX1,iX2,iX3,iPF_D ), uPF(:,iX1,iX2,iX3,iPF_V1), &
                   uPF(:,iX1,iX2,iX3,iPF_V2), uPF(:,iX1,iX2,iX3,iPF_V3), &
                   uPF(:,iX1,iX2,iX3,iPF_E ), uPF(:,iX1,iX2,iX3,iPF_Ne), &
                   uCF(:,iX1,iX2,iX3,iCF_D ), uCF(:,iX1,iX2,iX3,iCF_S1), &
                   uCF(:,iX1,iX2,iX3,iCF_S2), uCF(:,iX1,iX2,iX3,iCF_S3), &
                   uCF(:,iX1,iX2,iX3,iCF_E ), uCF(:,iX1,iX2,iX3,iCF_Ne), &
                   uGF(:,iX1,iX2,iX3,iGF_Gm_dd_11), &
                   uGF(:,iX1,iX2,iX3,iGF_Gm_dd_22), &
                   uGF(:,iX1,iX2,iX3,iGF_Gm_dd_33) )

          END DO
       END DO
    END DO

  END SUBROUTINE InitializeFields_RayleighTaylor

  SUBROUTINE InitializeFields_Implosion

    INTEGER  :: iX1, iX2, iX3
    INTEGER  :: iNodeX, iNodeX1, iNodeX2
    REAL(DP) :: X1, X2
    REAL(DP), PARAMETER :: D_0 = 0.125_DP
    REAL(DP), PARAMETER :: E_0 = 0.350_DP
    REAL(DP), PARAMETER :: D_1 = 1.000_DP
    REAL(DP), PARAMETER :: E_1 = 2.500_DP

    DO iX3 = 1, nX(3)
      DO iX2 = 1, nX(2)
        DO iX1 = 1, nX(1)

          DO iNodeX = 1, nDOFX

           iNodeX1 = NodeNumberTableX(1,iNodeX)
           iNodeX2 = NodeNumberTableX(2,iNodeX)

           X1 = NodeCoordinate( MeshX(1), iX1, iNodeX1 )
           X2 = NodeCoordinate( MeshX(2), iX2, iNodeX2 )

           IF( X1 + X2 .LT. 0.15_DP )THEN

             uPF(iNodeX,iX1,iX2,iX3,iPF_D) &
               = D_0
             uPF(iNodeX,iX1,iX2,iX3,iPF_E) &
               = E_0

           ELSE

             uPF(iNodeX,iX1,iX2,iX3,iPF_D) &
               = D_1
             uPF(iNodeX,iX1,iX2,iX3,iPF_E) &
               = E_1

           ENDIF

           uPF(iNodeX,iX1,iX2,iX3,iPF_V1) &
             = Zero
           uPF(iNodeX,iX1,iX2,iX3,iPF_V2) &
             = Zero
           uPF(iNodeX,iX1,iX2,iX3,iPF_V3) &
             = Zero

         END DO

         CALL ComputeConserved_Euler_NonRelativistic &
                ( uPF(:,iX1,iX2,iX3,iPF_D ), uPF(:,iX1,iX2,iX3,iPF_V1), &
                  uPF(:,iX1,iX2,iX3,iPF_V2), uPF(:,iX1,iX2,iX3,iPF_V3), &
                  uPF(:,iX1,iX2,iX3,iPF_E ), uPF(:,iX1,iX2,iX3,iPF_Ne), &
                  uCF(:,iX1,iX2,iX3,iCF_D ), uCF(:,iX1,iX2,iX3,iCF_S1), &
                  uCF(:,iX1,iX2,iX3,iCF_S2), uCF(:,iX1,iX2,iX3,iCF_S3), &
                  uCF(:,iX1,iX2,iX3,iCF_E ), uCF(:,iX1,iX2,iX3,iCF_Ne), &
                  uGF(:,iX1,iX2,iX3,iGF_Gm_dd_11), &
                  uGF(:,iX1,iX2,iX3,iGF_Gm_dd_22), &
                  uGF(:,iX1,iX2,iX3,iGF_Gm_dd_33) )
        END DO
      END DO
    END DO

  END SUBROUTINE InitializeFields_Implosion

  SUBROUTINE InitializeFields_Explosion

    INTEGER  :: iX1, iX2, iX3
    INTEGER  :: iNodeX, iNodeX1, iNodeX2
    REAL(DP) :: X1, X2, R
    INTEGER,  PARAMETER :: p = 150
    REAL(DP), PARAMETER :: R_0 = 0.4_DP
    REAL(DP), PARAMETER :: D_O = 0.125_DP
    REAL(DP), PARAMETER :: E_O = 0.250_DP
    REAL(DP), PARAMETER :: D_I = 1.000_DP
    REAL(DP), PARAMETER :: E_I = 2.500_DP

    DO iX3 = 1, nX(3)
    DO iX2 = 1, nX(2)
    DO iX1 = 1, nX(1)

      DO iNodeX = 1, nDOFX

        iNodeX1 = NodeNumberTableX(1,iNodeX)
        iNodeX2 = NodeNumberTableX(2,iNodeX)

        X1 = NodeCoordinate( MeshX(1), iX1, iNodeX1 )
        X2 = NodeCoordinate( MeshX(2), iX2, iNodeX2 )

        R = SQRT( X1**2 + X2**2 )

        uPF(iNodeX,iX1,iX2,iX3,iPF_D) &
          = ( D_I + (R/R_0)**p * D_O ) / ( One + (R/R_0)**p )

        uPF(iNodeX,iX1,iX2,iX3,iPF_E) &
          = ( E_I + (R/R_0)**p * E_O ) / ( One + (R/R_0)**p )

!!$        IF( R <= R_0 )THEN
!!$
!!$          uPF(iNodeX,iX1,iX2,iX3,iPF_D) = D_I
!!$          uPF(iNodeX,iX1,iX2,iX3,iPF_E) = E_I
!!$
!!$        ELSE
!!$
!!$          uPF(iNodeX,iX1,iX2,iX3,iPF_D) = D_O
!!$          uPF(iNodeX,iX1,iX2,iX3,iPF_E) = E_O
!!$
!!$        ENDIF

        uPF(iNodeX,iX1,iX2,iX3,iPF_V1) = Zero
        uPF(iNodeX,iX1,iX2,iX3,iPF_V2) = Zero
        uPF(iNodeX,iX1,iX2,iX3,iPF_V3) = Zero

      END DO

      CALL ComputeConserved_Euler_NonRelativistic &
             ( uPF(:,iX1,iX2,iX3,iPF_D ), uPF(:,iX1,iX2,iX3,iPF_V1), &
               uPF(:,iX1,iX2,iX3,iPF_V2), uPF(:,iX1,iX2,iX3,iPF_V3), &
               uPF(:,iX1,iX2,iX3,iPF_E ), uPF(:,iX1,iX2,iX3,iPF_Ne), &
               uCF(:,iX1,iX2,iX3,iCF_D ), uCF(:,iX1,iX2,iX3,iCF_S1), &
               uCF(:,iX1,iX2,iX3,iCF_S2), uCF(:,iX1,iX2,iX3,iCF_S3), &
               uCF(:,iX1,iX2,iX3,iCF_E ), uCF(:,iX1,iX2,iX3,iCF_Ne), &
               uGF(:,iX1,iX2,iX3,iGF_Gm_dd_11), &
               uGF(:,iX1,iX2,iX3,iGF_Gm_dd_22), &
               uGF(:,iX1,iX2,iX3,iGF_Gm_dd_33) )

    END DO
    END DO
    END DO

  END SUBROUTINE InitializeFields_Explosion

END MODULE InitializationModule


SUBROUTINE SEDZLJ(L)
  USE GLOBAL
  IMPLICIT NONE
  INTEGER::LL,K,L,SURFACE
  INTEGER::NSC0,NSC1,NTAU0,NTAU1
  DOUBLE PRECISION::WDTDZ
  DOUBLE PRECISION::SN00
  DOUBLE PRECISION::SN01
  DOUBLE PRECISION::SN10
  DOUBLE PRECISION::SN11
  DOUBLE PRECISION,DIMENSION(NSCM)::PX,PY,PFY,PROB,SMASS,CSEDSS
  DOUBLE PRECISION::D50TMPP,TEMP,TEMP2
  DOUBLE PRECISION::ESED
  REAL(4) SECNDS
  IF(IS_TIMING)T1TMP=SECNDS(SECNDS_ZERO)
  !
  ! UCSB, Craig Jones and Wilbert Lick
  !
  ! CALCULATES DEPOSITION, ENTRAINMENT, NET FLUX, TOTAL THICKNESS,
  ! LAYER ORDER, AND COMPONENT LAYER FRACTION
  ! Assuming ISEDDT in EFDC is 1 for now
  ! REVISION DATE :  August 29th, 2007
  ! Craig Jones and Scott James
  ! Updated to fix Active Layer issues
  !**********************************************************************

  ! CALCULATE EROSION/DEPOSITION FOR TOP LAYER
  ! FOR ALL GRID POINTS
  ETOTO(L)=0.0 !initialize no total erosion for a cell
  DEP(L)=0.0   !initialize no total deposition for a cell
  HT(L)=HP(L)*100.0 ! Convert depth (HP) from Meters to Centimeters
  ! Convert Bottom Shear from (m/s)^2 to dynes/cm^2
  ! Only when shear from EFDC is used

  !TAU(L)=TAUBSED(L)*1000.0*10.0
  D(1:NSCM,L)=0.0    !initialize deposition from suspended load
  DBL(1:NSCM,L)=0.0  !initialize deposition from bedload
  ! Convert Bottom Concentration from mg/l=g/m^3 to g/cm^3

  IF (KC == 1) THEN
     DO K=1,NSCM
        VZDIF(L)=MAX(20.d0,0.067d0*HT(L)*USTAR(L)*100.d0) !PT due to units of USTAR calc. in s_shear.f90
        TEMP2=HT(L)*DWS(K)/VZDIF(L)
        CTB(K,L)=SED(L,1,K)*TEMP2*(1.0/(1.0-EXP(-TEMP2)))*1.0E-06
     ENDDO
  ELSE
     CTB(1:NSCM,L)=SED(L,1,1:NSCM)*1.0E-06
  ENDIF
  E (1:NSCM,L)=0.0  !initialize erosion rates for each size class and each cell
  ELAY(1:NSCM)=0.0  !initialize top-layer erosion rates for each sediment size class
  SMASS(1:NSCM)=0.0 !initializes sediment mass available for deposition
  !**********************************************
  ! CALCULATE DEPOSITION
  ! Temporarily calculate the SMASS in the active layer (g/cm^3)
  ! so that percentages can be determined after deposition.
  TTEMP(1:NSCM,L)=PER(1:NSCM,1,L)*TSED(1,L) !temporary thickness variable for each size class equals the mass fraction times the top-layer thickness
  ! Now calculate DEPOSITION
  ! Deposition from suspended load
  DO K=1,NSCM !loop through all sediment sizes
     IF(CTB(K,L)<1.0E-20)CYCLE !if there is no sediment of that size available in the water column, then it cannot be deposited
     ! Calculate probability for suspended load deposition
     ! based on Gessler (1965) if D50 > 200um or Krone if < 200 um
     IF(D50(K)>=200.0)THEN
!
        PY(K)=DABS(1.7544*(TCRSUS(K)/(TAU(L)+1.0d-18)-1.0))   ! PMC - Handle Tau=0
!        PFY(K)=0.39894*EXP(-0.5*PY(K)*PY(K)) !CAJ's old formula A&S 7.1.25 (wrong)
!        PX(K)=1.0/(1.0+0.3327*PY(K)) !CAJ's old formulation A&S 7.1.25 (wrong)
        PFY(K)=EXP(-0.25d0*PY(K)*PY(K)) !PFY(K)=0.39894*EXP(-0.5*PY(K)*PY(K)) CAJ's old formula A&S 7.1.25
        PX(K)=1.0/(1.0+0.235235*PY(K)) !PX(K)=1.0/(1.0+0.3327*PY(K)) CAJ's old formulation A&S 7.1.25
        PROB(K)=PFY(K)*(0.34802*PX(K)-0.09587*PX(K)*PX(K)+0.74785*PX(K)**3) !A&S 7.1.25 a1, a2, a3 used
        IF(TAU(L)>TCRSUS(K))PROB(K)=1.0-PROB(K) !account for negatives
     ELSEIF(TAU(L)<=TCRSUS(K))THEN !if the local shear is less than the critical shear for that size class
        PROB(K)=1.0-TAU(L)/(TCRSUS(K)) !deposition probability is calculated
     ELSE
        PROB(K)=0.0
     ENDIF
     ! Calculate SMASS of sediment present in water
     ! and allow only that much to be deposited.
     SMASS(K)=SED(L,1,K)*1.0E-6*DZC(1)*HT(L)*MAXDEPLIMIT !SMASS(K) is the total sediment mass in the first layer.  It is calculated as a precaution so that no more than the total amount of mass in the first layer can deposit onto the sediment bed per time step.
     D(K,L)=PROB(K)*(DWS(K)*DT)*CTB(K,L) !deposition of a size class is equal to the probability of deposition times the settling rate times the time step times the sediment concentration
  ENDDO
  D(1:NSCM,L)=MIN(MAX(D(1:NSCM,L),0.d0),SMASS(1:NSCM)) !do not allow more sediment to deposit than is available in the water-column layer above the bed
  ! Deposition from Bedload
  DO K=1,NSCM
     IF(CBL(1,L,K)>1.0E-10.AND.BLVEL(L,K)>0.0 .AND. BLFLAG(L,K)==1)THEN !if there is bedload
        CSEDSS(K)=EBL(L)/(DWS(K)*DT) !concentration eroded into bedload from the last time step
        CSEDVR(K,L)=(0.18*2.65*TRANS(L,K)/DISTAR(K)*0.65) !van Rijn's (1981, Eq. 21) equilibrium bedload concentration (here TRANS is the transport parameter for bedload calculations)
        !			CSEDVR(K,L)=(0.18*TRANS(L,K)/DISTAR(K)*0.65)
        IF(CSEDVR(K,L)<=0.0)THEN !if there is no equilibrium bedload available
           PROBVR(K,L)=1.0 !then deposition probability is unity
        ELSE
           PROBVR(K,L)=MIN(CSEDSS(K)/CSEDVR(K,L),1.d0) !van Rijn probability of deposition from bedload
        ENDIF

! In case Ebl = 0  The deposition from bedload reverts to Gessler's for
! That particle size.
        IF(CSEDSS(K)<=0.0)PROBVR(K,L)=PROB(K) !error prevention
        ! Calculate Bedload Deposition (DBL)
        SMASS(K)=CBL(1,L,K)*DZBL(L,K) !local mass available for deposition is the bedload concentration times the bedload height
        DBL(K,L)=PROBVR(K,L)*CBL(1,L,K)*(DWS(K)*DT) !deposition from bedload is the van Rijn probability time bedload concentration time settling velocity times the time step
     ENDIF
  ENDDO
  DBL(1:NSCM,L)=MIN(MAX(DBL(1:NSCM,L),0.d0),SMASS(1:NSCM)) !do not allow more bedload deposition than bedload mass available
  ! TOTAL DEPOSITION
  DEP(L)=SUM(DBL(1:NSCM,L),BLVEL(L,1:NSCM)>0.0)+SUM(D(1:NSCM,L)) !total depositopn is the sume of bedload and suspended load depositions for all size classes
  DEPO(L)=DEP(L)/(DT) !calculate the deposition rate
  ! ADD DEPOSITION TO TOP LAYER
  IF(DEP(L)>0.0)THEN !if there is deposition, calculate the new layer thickness and mass fractions
     ! LAYER: logical variable that is 0 if a layer is present at cell (this variable exists for each sediment bed layer initially defined)
     LAYER(1,L)=1 !top sediment bed layer exists (because there is deposition)
     TSED(1,L)=TSED(1,L)+DEP(L)
     WHERE(BLVEL(L,1:NSCM)>0.0) !where there is bedload possible
        PER(1:NSCM,1,L)=(TTEMP(1:NSCM,L)+DBL(1:NSCM,L)+D(1:NSCM,L))/(TSED(1,L)) !recalculate mass fractions
     ELSEWHERE
        PER(1:NSCM,1,L)=(TTEMP(1:NSCM,L)+D(1:NSCM,L))/(TSED(1,L))
     ENDWHERE
  ENDIF

!******************************************************
! Get things set up for Erosion Calculations
! Find the next layer (SLLN) of sediment below the top layer
  IF(LAYER(2,L)==1)THEN !check to ensure that there are at least 2 sediment layers present here
     SLLN(L)=2 !layer number below active layer (always 3 to start after SEDIC, always 2 when there at least 2 layers)
  ELSE
     DO LL=3,KB
        IF(LAYER(LL,L)==1.AND.LAYER(LL-1,L)/=1)THEN
           SLLN(L)=LL !next layer is renumbered as necessary (happens if active layer is eroded completely)
           EXIT
        ENDIF
     ENDDO
  ENDIF

  ! Calculate average particle size of surface layer so we can calculate
  ! Active layer thickness
  IF(LAYER(1,L)==1)THEN !is the top layer present?
     SURFACE=1 !surface variable established
  ELSE
     SURFACE=SLLN(L) !otherwise the top layer is SLLN
  ENDIF
  D50AVG(L)=SUM(PER(1:NSCM,SURFACE,L)*D50(1:NSCM)) !calculate local d50 at sediment bed surface
  FORALL(LL=1:KB)SEDDIA50(L,LL)=SUM(PER(1:NSCM,LL,L)*D50(1:NSCM)) !EFDC variable

  ! Identify Size Class interval to use for Taucrit erosion calculation
  DO K=1,NSICM-1
     IF(D50AVG(L)>=SCND(K).AND.D50AVG(L)<SCND(K+1))THEN
        NSCD(1)=SCND(K)
        NSCD(2)=SCND(K+1)
        NSC0=K
        NSC1=K+1
        EXIT
     ENDIF
  ENDDO

  ! Calculate TAUCRIT Based on the Average Particle Size of Surface
  ! Then calculate the Active Layer Thickness from it.
  ! Ta =  Tam * Davg * (Tau/Taucr)

  IF(SURFACE==1.OR.SURFACE==2)THEN
     TAUCRIT(L)=TAUCRITE(NSC0)+(TAUCRITE(NSC1)-TAUCRITE(NSC0))/(NSCD(2)-NSCD(1))*(D50AVG(L)-NSCD(1))
     TAUCOR(SURFACE,L)=TAUCRIT(L)
  ELSE
     TAUCRIT(L)=TAUCOR(SURFACE,L)
  ENDIF
  IF(TAU(L)/TAUCRIT(L)<1.0)THEN
     TACT(L)=TACTM*D50AVG(L)*(BULKDENS(1,L)/10000.0)
  ELSE
     TACT(L)=TACTM*D50AVG(L)*(TAU(L)/TAUCRIT(L))*(BULKDENS(1,L)/10000.0)
  ENDIF

! This is where we determine if there is an un-erodeable
! Size class.  If there is one, we need an active layer.
  NACTLAY=0
  DO LL=1,KB !search through all layers
     IF(LAYER(LL,L)>0)THEN !if the layer is present
        DO K=1,NSCM
           IF(PER(K,LL,L)>0.0.AND.TAU(L)<TCRE(K).AND.TAU(L)>TAUCRIT(L))THEN !if the size class is present and the sediment bed is eroding and there is insufficient shear stress for suspension
              NACTLAY=1    !there is an active layer (logical variable)
              LAYER(1,L)=1 !there is an active layer
           ENDIF
        ENDDO
        EXIT
     ENDIF
  ENDDO

  ! If the layer exposed can erode, then
  ! use the active layer model, otherwise just put deposited material
  ! on top.  Also if there is a size class present in the top layer
  ! that will not erode, create an active layer.
  IF(TSED(1,L)>0.0.OR.NACTLAY/=0)THEN !if there is mass in the active layer, we must go through the sorting routine
     !no active layer for pure erosion (active layer needed for coarsening and deposition)

     ! Sort layers so that the active layer is always Ta thick.
     ! Recalculate the mass fractions after borrowing from lower layers
     IF(LAYER(1,L)==1)THEN
        IF(TSED(1,L)>TACT(L))THEN !this happens when there is net deposition over this time step
           FORALL(K=1:NSCM)PER(K,2,L)=(PER(K,2,L)*TSED(2,L)+PER(K,1,L)*(TSED(1,L)-TACT(L)))/(TSED(2,L)+(TSED(1,L)-TACT(L))) !recalculate mass fractions
           LAYER(2,L)=1 !ensure that the second layer logical is turned on
           SLLN(L)=2 !next lower layer is 2
           TSED(2,L)=TSED(2,L)+TSED(1,L)-TACT(L) !add layer thickness in excess of active-layer thickness to next lower layer
           TSED(1,L)=TACT(L) !reset top layer thickness to active layer thickness
        ELSEIF(TSED(1,L)<TACT(L).AND.TSED(1,L)+TSED(SLLN(L),L)>TACT(L).AND.TAU(L)>TAUCOR(SLLN(L),L))THEN !this happens when there is net erosion over this time step and there is sufficient sediment below to reconstitute the active layer
           FORALL(K=1:NSCM)PER(K,1,L)=(PER(K,1,L)*TSED(1,L)+PER(K,SLLN(L),L)*(TACT(L)-TSED(1,L)))/TACT(L) !recalculate the mass fraction
           TSED(SLLN(L),L)=TSED(SLLN(L),L)-(TACT(L)-TSED(1,L)) !borrow thickness from lower layer
           TSED(1,L)=TACT(L) !reset top layer thickness to active layer thickness
        ELSEIF(TSED(1,L)<TACT(L).AND.TSED(1,L)+TSED(SLLN(L),L)<=TACT(L).AND.TAU(L)>TAUCOR(SLLN(L),L))THEN !this happens when there is net erosion over this time step and there is NOT sufficient sediment below to reconstitute the active layer
           FORALL(K=1:NSCM)
              PER(K,1,L)=(PER(K,1,L)*TSED(1,L)+PER(K,SLLN(L),L)*(TSED(SLLN(L),L)))/(TSED(1,L)+TSED(SLLN(L),L)) !recalculate the mass fraction
              PER(K,SLLN(L),L)=0.0 !no more sediment available in next lower layer
           ENDFORALL
           TSED(1,L)=TSED(1,L)+TSED(SLLN(L),L) !add available sediment to layer
           TSED(SLLN(L),L)=0.0 !no more sediment available below this
           LAYER(SLLN(L),L)=0 !layer has been eliminated in the logical variable
           SLLN(L)=SLLN(L)+1 !set next layer lower
           IF (SLLN(L)+1>KB) SLLN(L)=KB !do not allow specification of the next lower layer to be below the bottom sediment layer
        ENDIF
     ENDIF
  ENDIF
  !**************************************************************
  ! Now calculate the Erosion Rates
  ALL_LAYERS:DO LL=1,KB !go through all sediment layers so that they are properly eroded and sorted
     IF(LAYER(LL,L)==0)CYCLE !if the layer is gone don't consider it
     IF(LAYER(1,L)==1.AND.LL/=1)EXIT !if it is depositional, there is no need to consider erosion
     IF(LL/=1)THEN
        IF(LAYER(LL-1,L)==1)EXIT
     ENDIF
     D50AVG(L)=SUM(PER(1:NSCM,LL,L)*D50(1:NSCM)) ! Find mean diameter of Layer
     ! Find upper and lower limits of size classes on mean bed diameter
     DO K=1,NSICM-1
        IF(D50AVG(L)>=SCND(K).AND.D50AVG(L)<SCND(K+1))THEN
           NSCD(1)=SCND(K)
           NSCD(2)=SCND(K+1)
           NSC0=K
           NSC1=K+1
           EXIT
        ENDIF
     ENDDO
     ! Calculate TAUCRIT Based on the D50 of the bed or from Sedflume Data
     IF(LL==1.OR.LL==2)THEN !for active layer
        TAUCRIT(L)=TAUCRITE(NSC0)+(TAUCRITE(NSC1)-TAUCRITE(NSC0))/(NSCD(2)-NSCD(1))*(D50AVG(L)-NSCD(1)) !interpolation
        TAUCOR(LL,L)=TAUCRIT(L)
     ELSE
        SN01=TSED(LL,L)/TSED0(LL,L)               !weighting factor 1 for interpolation
        SN11=(TSED0(LL,L)-TSED(LL,L))/TSED0(LL,L) !weighting factor 2
        IF(LL+1<=KB)THEN !Avoid array exceedance when LL=KB and used in TAUCOR(L+1,L)
           TAUCRIT(L)=SN01*TAUCOR(LL,L)+SN11*TAUCOR(LL+1,L) !
        ELSE
           TAUCRIT(L)=1.0e6 !set arbitrarily high
        ENDIF
     ENDIF
     ! Now, calculate erosion rates
     IF(TAU(L)<SH_SCALE(L)*TAUCRIT(L))EXIT
     ! Find the upper and lower limits of the Shear Stress for the interpolation
     DO K=1,ITBM-1
        IF(TAU(L)>=TAULOC(K).AND.TAU(L)<TAULOC(K+1))THEN
           TAUDD(1)=TAULOC(K)
           TAUDD(2)=TAULOC(K+1)
           NTAU0=K
           NTAU1=K+1
           EXIT
        ELSEIF(TAU(L)>=TAULOC(ITBM))THEN
           TAUDD(1)=TAULOC(ITBM-1)
           TAUDD(2)=TAULOC(ITBM)
           NTAU0=ITBM-1
           NTAU1=ITBM
        ENDIF
     ENDDO
     ! Interpolate the erosion rates for shear stress and depth.
     ! This utilizes normal sedflume data for deeper layers.
     IF(LL>2)THEN !calculate erosion rates of deeper layers
        SN00=(TAUDD(2)-TAU(L))/(TAUDD(2)-TAUDD(1)) !weighting factor 1 for interpolation
        SN10=(TAUDD(1)-TAU(L))/(TAUDD(1)-TAUDD(2)) !weighting factor 2
        SN01=TSED(LL,L)/TSED0(LL,L)                !weighting factor 3
        SN11=(TSED0(LL,L)-TSED(LL,L))/TSED0(LL,L)  !weighting factor 4

        IF(LL+1<=KB)THEN !modeled erosion rate
           ERATEMOD(L)=(SN00*EXP(SN11*LOG(ERATE(LL+1,L,NTAU0))+SN01*LOG(ERATE(LL,L,NTAU0)))&
                +SN10*EXP(SN11*LOG(ERATE(LL+1,L,NTAU1))+SN01*LOG(ERATE(LL,L,NTAU1))))*BULKDENS(LL,L)*SQRT(1.0/SH_SCALE(L))
        ELSE !do not allow erosion through the bottom layer
           ERATEMOD(L)=(SN00*EXP(SN11*LOG(1.0E-9)+SN01*LOG(ERATE(LL,L,NTAU0)))&
                +SN10*EXP(SN11*LOG(1.0E-9)+SN01*LOG(ERATE(LL,L,NTAU1))))*BULKDENS(LL,L)*SQRT(1.0/SH_SCALE(L))
        ENDIF
     ELSE

        ! For Layers One and Two (the newly deposited sediments)
        ! The erosion rate for these layers is determined from
        ! Sedflume experiments and is based on average particle
        ! Size (D50AVG)
        NSCTOT=NSCD(2)-NSCD(1) !difference in interpolant size class
        D50TMPP=D50AVG(L)-NSCD(1) !difference from local size class and lower interpolant
        SN00=(TAUDD(2)-TAU(L))/(TAUDD(2)-TAUDD(1)) !weighting factor 1 for interpolation
        SN10=(TAUDD(1)-TAU(L))/(TAUDD(1)-TAUDD(2)) !weigthing factor 2
        SN01=D50TMPP/NSCTOT                        !weighting factor 3
        SN11=(NSCTOT-D50TMPP)/NSCTOT               !weighting factor 4
        ERATEMOD(L)=(SN00*EXP(SN11*LOG(ERATEND(NSC0,NTAU0))+SN01* &
        LOG(ERATEND(NSC1,NTAU0)))+SN10*EXP(SN11*LOG(ERATEND(NSC0,NTAU1))+ &
        SN01*LOG(ERATEND(NSC1,NTAU1))))*BULKDENS(LL,L)*SQRT(1./SH_SCALE(L)) !log-linear interpolation
     ENDIF

     ! Sort out Thicknesses and Erosion Rates
     ! Assuming ISEDDT in EFDC is 1 for now
     EBD(LL,L)=ERATEMOD(L)*DT !amount eroded this time step for this layer

     ! If the shear stress is less than the critical shear stress for a
     ! particular size class, then it is not eroded from the bed.
     !
     ! Calculate New SMASS (TTEMP) of each sediment in Bed (g/cm^2)
     ! Conservation of SMASS, you can only erode as much as is there.
     ! E(K,L)  = Total erosion at this cell of size class k
     ! ETOTO(L) = Total erosion at this cell
     ! ELAY(K) = Erosion from this layer of size class k
     ! ESED  =  Total erosion from layer

     WHERE(TAU(L)>=TCRE(1:NSCM))
        E(1:NSCM,L)=E(1:NSCM,L)+PER(1:NSCM,LL,L)*EBD(LL,L)
        ELAY(1:NSCM)=PER(1:NSCM,LL,L)*EBD(LL,L)
        TTEMP(1:NSCM,L)=PER(1:NSCM,LL,L)*TSED(LL,L)-ELAY(1:NSCM) !thickness due to each size class
     ELSEWHERE
        E(1:NSCM,L)=0.0
        ELAY(1:NSCM)=0.0
        TTEMP(1:NSCM,L)=PER(1:NSCM,LL,L)*TSED(LL,L)
     ENDWHERE
     WHERE(TTEMP(1:NSCM,L)<0.0) !if the thickness due to a size class is negative
        TTEMP(1:NSCM,L)=0.0 !set thickness to zero
        E(1:NSCM,L)=E(1:NSCM,L)-PER(1:NSCM,LL,L)*EBD(LL,L)+PER(1:NSCM,LL,L)*TSED(LL,L) !recalculate erosions
        ELAY(1:NSCM)=PER(1:NSCM,LL,L)*TSED(LL,L)
     ENDWHERE
     ESED=SUM(ELAY(1:NSCM))    !total erosion from the layer
     ETOTO(L)=SUM(E(1:NSCM,L)) !total erosion in cell

     ! Subtract total erosion from layer thickness
     ! Then Calculate new percentages
     TEMP=TSED(LL,L)-ESED !eroded layer thickness (recall that this is in a loop and calculated for each layer)
     IF(TEMP<=D50(1)/1.0e6)THEN !if the layer eroded (or smaller than the smallest size class), set its thicknesses to zero
        TSED(LL,L)=0.0  !this layer has no thickness
        LAYER(LL,L)=0   !this layer is absent
        FORALL(K=1:NSCM)PER(K,LL,L)=0.0 !zero mass fractions
     ELSE
        TSED(LL,L)=TEMP !new layer thickness
        FORALL(K=1:NSCM)PER(K,LL,L)=TTEMP(K,L)/TSED(LL,L) !new mass fractions
     ENDIF
     IF(IMORPH==0)HBED(L,KB+1-LL)=0.01*TSED(LL,L)/BULKDENS(LL,L)    !if there is no morphology, save the EFDC bed thickness
  ENDDO ALL_LAYERS

! DETERMINE TOTAL SEDIMENT FLUX
  EBL(L)=0.0  !zero erosion into bedload
  ESUS(L)=0.0 !zero erosion into suspended load
  DO K=1,NSCM
     IF(BLFLAG(L,K)==1)THEN !if there is bedload
        QBSED(L,K)=(1.0-PSUS(L,K))*E(K,L)-DBL(K,L) !flux of sediment from the bed into bedload
        BED_SED_FLX(L,K)=PSUS(L,K)*E(K,L)-D(K,L)   !flux into suspended load
     ELSE
        BED_SED_FLX(L,K)=E(K,L)-D(K,L) !if there is no bedload there is only erosion into suspended load
     ENDIF
  ENDDO
  EBL(L)=SUM((1.0-PSUS(L,1:NSCM))*E(1:NSCM,L),BLVEL(L,1:NSCM)>0.0) !reclaculate erosion into bedload
  ESUS(L)=SUM(PSUS(L,1:NSCM)*E(1:NSCM,L),BLVEL(L,1:NSCM)>0.0)      !recalculate erosion into suspended load

  ! Flux calculations for EFDC
  ! Convert the BED_SED_FLX from g/cm^2 to g/m^2*s
  WDTDZ=DT*HPI(L)*DZIC(1) !Detla t over Delta z
  SEDF(L,0,1:NSCM)=BED_SED_FLX(L,1:NSCM)*10000.0/DT !EFDC variable for sediment flux
  SED(L,1,1:NSCM)=SEDS(L,1,1:NSCM)+(SEDF(L,0,1:NSCM)-SEDF(L,1,1:NSCM))*WDTDZ !EFDC variable for suspended sediment concentration
  ETOTO(L)=ETOTO(L)/(DT) !total erosion rate

  TSSEDZLJ=TSSEDZLJ+SECNDS(T1TMP)

  RETURN
END SUBROUTINE SEDZLJ


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

subroutine modweight(j,n,wfit,y,yfit)

!                                                                               !
!  Authors:                                                                     !
!  Per J\"onsson, Malm\"o University, Sweden                                    !
!  e-mail per.jonsson@ts.mah.se                                                 !
!                                                                               !
!  Lars Eklundh, Lund University, Sweden                                        !
!  e-mail lars.eklundh@nateko.lu.se                                             !
!                                                                               !
!  Updated 26/3-2005                                                            !
!                                                                               !
!-------------------------------------------------------------------------------!

implicit none

integer :: i,j,m1,m2,nyear,nptperyear,npt,n,nenvi,printflag,debugflag,win(3)
double precision :: wfit(n),y(n),yfit(n),yfitmean,yfitstd,ydiff,wfact

common /parameters/ nyear,nptperyear,npt,nenvi,printflag,debugflag,wfact,win

!---- Compute mean and standard deviation --------------------------------------

yfitmean = sum(yfit)/n
yfitstd = sqrt(dot_product(yfit-yfitmean,yfit-yfitmean)/(n-1.d0))

!---- Adjust the weights dependent on if the values are above or below the -----
!     fitted values

do i = 1,n
  m1 = max(1,i - nptperyear/7)
  m2 = min(n,i + nptperyear/7)
  if (y(i) < yfit(i) - 1.d-8) then

!---- Modify weights of all points in the first iteration. After that ----------
!     only weights of high points are modified

    if ((minval(yfit(m1:m2)) > yfitmean) .or. (j < 2)) then

!---- If there is a low variation in an interval, i.e. if the interval ---------
!     is at a peak or at a minima compute the normalized distance
!     between the data point and the fitted point

      if (maxval(yfit(m1:m2))-minval(yfit(m1:m2)) < 0.4d0*2.d0*yfitstd) then
        ydiff = 2.d0*(yfit(i)-y(i))/yfitstd
      else
        ydiff = 0.d0
      end if

!---- Use the computed distance to modify the weight. Large distance -----------
!     will give a small weight

      wfit(i) = wfact*wfit(i)*exp(-ydiff**2.d0)

    end if
  end if
end do

end subroutine modweight


subroutine buoyancy()

use vars
use params
implicit none

integer i,j,k,kb
real betu, betd, du(nx,ny,nz,3)

if(docolumn) return

call t_startf ('buoyancy')

if(dostatis) then

  do k=1,nzm
    do j=1,ny
      do i=1,nx
         du(i,j,k,3)=dwdt(i,j,k,na)
      end do
    end do
  end do

endif

do k=2,nzm
 kb=k-1
 betu=adz(kb)/(adz(k)+adz(kb))
 betd=adz(k)/(adz(k)+adz(kb))
 do j=1,ny
  do i=1,nx

   dwdt(i,j,k,na)=dwdt(i,j,k,na) +  &
      bet(k)*betu* &
     ( tabs0(k)*(epsv*(qv(i,j,k)-qv0(k))-(qcl(i,j,k)+qci(i,j,k)-qn0(k)+qpl(i,j,k)+qpi(i,j,k)-qp0(k))) &
       +(tabs(i,j,k)-tabs0(k))*(1.+epsv*qv0(k)-qn0(k)-qp0(k)) ) &
    + bet(kb)*betd* &
     ( tabs0(kb)*(epsv*(qv(i,j,kb)-qv0(kb))-(qcl(i,j,kb)+qci(i,j,kb)-qn0(kb)+qpl(i,j,kb)+qpi(i,j,kb)-qp0(kb))) &
       +(tabs(i,j,kb)-tabs0(kb))*(1.+epsv*qv0(kb)-qn0(kb)-qp0(kb)) )

  end do ! i
 end do ! j
end do ! k

if(dostatis) then

  do k=1,nzm
    do j=1,ny
      do i=1,nx
        du(i,j,k,1)=0.
        du(i,j,k,2)=0.
        du(i,j,k,3)=dwdt(i,j,k,na)-du(i,j,k,3)
      end do
    end do
  end do

  call stat_tke(du,tkelebuoy)
  call stat_mom(du,momlebuoy)
  call setvalue(twlebuoy,nzm,0.)
  call setvalue(qwlebuoy,nzm,0.)
  call stat_sw1(du,twlebuoy,qwlebuoy)

endif

call t_stopf ('buoyancy')

end subroutine buoyancy


C> @file ausm.f Riemann solvers and other rocflu miscellany
! ******************************************************************************
!
! Purpose: Compute convective fluxes using AUSM+ scheme.
!
! Description: None.
!
! Input:
!   nx          x-component of face normal
!   ny          y-component of face normal
!   nz          z-component of face normal
!   nm          Magnitude of face normal
!   fs          Face speed
!   rl          Density of left state
!   ul          x-component of velocity of left state
!   vl          y-component of velocity of left state
!   wl          z-component of velocity of left state
!   Hl		Total enthalpy of left state
!   al		Speed of sound of left state
!   pl          Pressure of left state
!   rr          Density of right state
!   ur          x-component of velocity of right state
!   vr          y-component of velocity of right state
!   wr          z-component of velocity of right state
!   pr          Pressure of right state
!   Hr		Total enthalpy of right state
!   ar		Speed of sound of right state
!
! Output:
!   flx         Fluxes
!   vf          Face velocities ! NOT USED IN CMT-NEK YET
!
! Notes:
!   1. Liou M.-S., Progress towards an improved CFD method: AUSM+, AIAA Paper
!      95-1701, 1995
!   2. Do not use computation of face speed of sound which leads to exact
!      capturing of isolated normal shock waves because of robustness problems
!      for unsteady flows and because that formulation is not applicable to
!      anything but calorically and thermally perfect gases.
!
! ******************************************************************************

C> \ingroup isurf
C> @{
C> Computes inviscid numerical surface flux from AUSM+ Riemann solver
      SUBROUTINE AUSM_FluxFunction(ntot,nx,ny,nz,nm,fs,rl,ul,vl,wl,pl,
     >                         al,tl,rr,ur,vr,wr,pr,ar,tr,flx,el,er)

!     IMPLICIT NONE ! HAHAHHAHHAHA
! ******************************************************************************
! Definitions and declarations
! ******************************************************************************
      real     MixtJWL_Enthalpy
      external MixtJWL_Enthalpy

! ==============================================================================
! Arguments
! ==============================================================================
      integer ntot
      REAL al(ntot),ar(ntot),fs(ntot),nm(ntot),nx(ntot),ny(ntot),
     >     nz(ntot),pl(ntot),pr(ntot),rl(ntot),rr(ntot),ul(ntot),
     >     ur(ntot),vl(ntot),vr(ntot),wl(ntot),wr(ntot),el(ntot),
     >     er(ntot),tl(ntot),tr(ntot)! INTENT(IN) ::
      REAL flx(ntot,5)!,vf(3) ! INTENT(OUT) ::

! ==============================================================================
! Locals
! ==============================================================================

      REAL af,mf,mfa,mfm,mfp,ml,mla,mlp,mr,mra,mrm,pf,ql,qr,vml,vmr,
     >        wtl,wtr,Hl,Hr

! ******************************************************************************
! Start, compute face state
! ******************************************************************************

      do i=1,ntot
!        Change the Enthalpy
         Hl = MixtJWL_Enthalpy(rl(i),pl(i),ul(i),vl(i),wl(i),el(i))
         Hr = MixtJWL_Enthalpy(rr(i),pr(i),ur(i),vr(i),wr(i),er(i))

         ql = ul(i)*nx(i) + vl(i)*ny(i) + wl(i)*nz(i) - fs(i)
         qr = ur(i)*nx(i) + vr(i)*ny(i) + wr(i)*nz(i) - fs(i)

         af = 0.5*(al(i)+ar(i)) ! NOTE not using original formulation, see note
         ml  = ql/af
         mla = ABS(ml)

         mr  = qr/af
         mra = ABS(mr)

         IF ( mla .le. 1.0 ) THEN
            mlp = 0.25*(ml+1.0)*(ml+1.0) + 0.125*(ml*ml-1.0)*(ml*ml-1.0)
            wtl = 0.25*(ml+1.0)*(ml+1.0)*(2.0-ml) +
     >            0.1875*ml*(ml*ml-1.0)*(ml*ml-1.0)
         ELSE
            mlp = 0.5*(ml+mla)
            wtl = 0.5*(1.0+ml/mla)
         END IF ! mla

         IF ( mra .le. 1.0 ) THEN
            mrm = -0.25*(mr-1.0)*(mr-1.0)-0.125*(mr*mr-1.0)*(mr*mr-1.0)
            wtr = 0.25*(mr-1.0)*(mr-1.0)*(2.0+mr) -
     >            0.1875*mr*(mr*mr-1.0)*(mr*mr-1.0)
         ELSE
            mrm = 0.5*(mr-mra)
            wtr = 0.5*(1.0-mr/mra)
         END IF ! mla

         mf  = mlp + mrm
         mfa = ABS(mf)
         mfp = 0.5*(mf+mfa)
         mfm = 0.5*(mf-mfa)

         pf = wtl*pl(i) + wtr*pr(i)

! ******************************************************************************
! Compute fluxes
! ******************************************************************************

!        vf(1) = mfp*ul + mfm*ur ! I'm sure we'll need this someday
!        vf(2) = mfp*vl + mfm*vr
!        vf(3) = mfp*wl + mfm*wr

         flx(i,1)=(af*(mfp*rl(i)      +mfm*rr(i)   )        )*nm(i)
         flx(i,2)=(af*(mfp*rl(i)*ul(i)+mfm*rr(i)*ur(i))+pf*nx(i))*
     >            nm(i)
         flx(i,3)=(af*(mfp*rl(i)*vl(i)+mfm*rr(i)*vr(i))+pf*ny(i))*
     >            nm(i)
         flx(i,4)=(af*(mfp*rl(i)*wl(i)+mfm*rr(i)*wr(i))+pf*nz(i))*
     >            nm(i)
         flx(i,5)=(af*(mfp*rl(i)*Hl   +mfm*rr(i)*Hr) + pf*fs(i))*
     >            nm(i)
      enddo
C> @}
      return
      END

!-----------------------------------------------------------------------
! NOT LONG FOR THIS WORLD

      SUBROUTINE CentralInviscid_FluxFunction(ntot,nx,ny,nz,fs,ul,pl,
     >                                     ur,pr,flx)
! JH081915 More general, more obvious
! JH111815 HEY GENIUS THIS MAY BE SECOND ORDER AND THUS KILLING YOUR
!          CONVERGENCE. REPLACE WITH AUSM AND SHITCAN IT
! JH112015 This isn't why walls aren't converging. There's something
!          inherently second-order about your wall pressure. Think!
      real nx(ntot),ny(ntot),nz(ntot),fs(ntot),ul(ntot,5),pl(ntot),
     >     ur(ntot,5),pr(ntot) ! intent(in)
      real flx(ntot,5)! intent(out),dimension(5) ::

      do i=1,ntot
         rl =ul(i,1)
         rul=ul(i,2)
         rvl=ul(i,3)
         rwl=ul(i,4)
         rel=ul(i,5)

         rr =ur(i,1)
         rur=ur(i,2)
         rvr=ur(i,3)
         rwr=ur(i,4)
         rer=ur(i,5)

         ql = (rul*nx(i) + rvl*ny(i) + rwl*nz(i))/rl - fs(i)
         qr = (rur*nx(i) + rvr*ny(i) + rwr*nz(i))/rr - fs(i)

         flx(i,1) = 0.5*(ql* rl+ qr*rr               )
         flx(i,2) = 0.5*(ql* rul+pl(i)*nx(i) + qr* rur     +pr(i)*nx(i))
         flx(i,3) = 0.5*(ql* rvl+pl(i)*ny(i) + qr* rvr     +pr(i)*ny(i))
         flx(i,4) = 0.5*(ql* rwl+pl(i)*nz(i) + qr* rwr     +pr(i)*nz(i))
         flx(i,5) = 0.5*(ql*(rel+pl(i))+pl(i)*fs(i)+qr*(rer+pr(i))+
     >               pr(i)*fs(i))
      enddo

      return
      end


!**********************************************************************
!    LICENSED MATERIALS - PROPERTY OF IBM                             *
!    "RESTRICTED MATERIALS OF IBM"                                    *
!                                                                     *
!    5765-C41                                                         *
!    (C) COPYRIGHT IBM CORP. 1995, 1997. ALL RIGHTS RESERVED.         *
!                                                                     *
!    U.S. GOVERNMENT USERS RESTRICTED RIGHTS - USE, DUPLICATION       *
!    OR DISCLOSURE RESTRICTED BY GSA ADP SCHEDULE CONTRACT WITH       *
!    IBM CORP.                                                        *
!**********************************************************************
      program pdgexmp
      use putilities
!
!   calculate the performance of linear algebra solvers for
!   different block sizes, matrix sizes and processor configurations
!
!   Subroutines called
!     array_create   from utility library
!     broadcast      from utility library
!     initutils      from utility library
!     exitutils      from utility library
!     g2l            from utility library
!     blacs_pinfo    from blacs library
!     blacs_gridinfo from blacs library
!     blacs_barrier  from blacs library
!     dgsum2d        from blacs library
!     dgamx2d        from blacs library
!     numroc         from pessl library
!     pdgemm         from pessl library
!     pdgetrf        from pessl library
!     pdgetrs        from pessl library
!
      implicit none

!     .. parameters ..
      real(long_t), parameter :: zero=0.d0, one=1.d0
      integer, parameter      :: ia=1, ja=1, ib=1, jb=1, ix=1, jx=1

!     .. local arrays
      real(long_t), pointer :: a(:,:), b(:,:), x(:,:)
      integer          adesc(DESC_DIM), bdesc(DESC_DIM), xdesc(DESC_DIM)
      integer, allocatable   ::         ipiv(:)

!     .. local scalars ..
      real(long_t)       :: tf, t1, err, ts, t0, flf, xnrm, err2, fls
      real(long_t)       :: tmnull
      integer            :: icm, me, irm, i, j, imat
      integer            :: nprocs, n, nb, nrhs, ncases, nprows, status
      integer            :: npcols, mycol, myrow, ircode
      integer            :: iret, nqx, nbrhs, mpx
      integer            :: ierrcount, iam

!    .. external functions
      integer            :: numroc
      external           numroc
      real(long_t)       :: funca, funcx, timef, dnrm2
      external           funca, funcx, timef, dnrm2
!
!     interface block for local routines
!
      INTERFACE
        subroutine get2norm(x,b,mpx,nqx,err)
        use putilities
        real(long_t)    :: x(:,:), b(:,:)
        real(long_t)    :: err
        integer         :: mpx, nqx
        end subroutine get2norm
      END INTERFACE

!
!  set up communication will all the processors
!

      call blacs_pinfo(iam,nprocs)
!
!     the main input file
!
      do nprows = 1, nprocs
        npcols = nprocs/nprows
        if( nprows*npcols .ne. nprocs) cycle
        if (iam.eq.0) then
         open (10,file='pdgexmp.inp')
         read (10,fmt=*) ncases
         read (10,fmt=*)
         nprocs = nprows*npcols
        endif

!
!  initialize using all of the target number of rows and columns
!
        call initutils(status,nprows,npcols)
        if(status .ne. 0 ) then
          write(*,*) 'Failed to initialize communication'
          stop 1
        endif
        call broadcast(ncases,0,0)

        call blacs_gridinfo(p_context(),nprows,npcols,myrow,mycol)

!
!     the report header
!
       if (myrow.eq.0 .and. mycol.eq.0) then
         write (6,fmt=*) 'number of processors: ', nprocs
         write (6,fmt=*) 'processor array shape: ',nprows,' by ',npcols
         write (6,fmt=*)
         write (6,fmt=99997) 'n','nrhs','nb','nbrhs','time f','time s',
     +      'mflops f', 'mflops s','err'
       endif
!

!
!     calculate timing overhead
!
      tmnull = timef()
      tmnull = timef() - tmnull

!
!     loop over all requests
!
       do imat = 1, ncases

         if (myrow.eq.0 .and.mycol .eq. 0) then
            read (10,fmt=*) n, nrhs, nb, nbrhs
         endif
!
!  make sure everyone has the same problem size
!
         call broadcast(n,0,0)
         call broadcast(nrhs,0,0)
         call broadcast(nb,0,0)
         call broadcast(nbrhs,0,0)

         call array_create(a,adesc,n,n,CREATE_CYCLIC,nb,nb)
         call array_create(b,bdesc,n,nrhs,CREATE_CYCLIC,nb,nbrhs)
         call array_create(x,xdesc,n,nrhs,CREATE_CYCLIC,nb,nbrhs)

         mpx = numroc(xdesc(M_),xdesc(MB_),myrow,xdesc(RSRC_),nprows)
         nqx = numroc(xdesc(N_),xdesc(NB_),mycol,xdesc(CSRC_),npcols)

!
! we will not alway need n elements for the pivot vector, but
! it is always sufficient.
!
          allocate(ipiv(n),stat=ircode)
          if (ircode.ne.0) then
             write(0,*) 'error: memory allocation failure '
             call blacs_abort(p_context(),1)
          endif
!
!        generate two matrices a and x
!
         call pdgegen(funca,n,n,a,ia,ja,adesc,iret)
!
! if maxtrix generation fails, abort
         if(iret.ne.0) call blacs_abort(p_context(),1)
!
         call pdgegen(funcx,n,nrhs,x,ix,jx,xdesc,iret)
!
! if maxtrix generation fails, abort
         if(iret.ne.0) call blacs_abort(p_context(),1)
!

!
!       generate a rhs against a known solution
!
         call pdgemm('no transpose','no transpose',n,nrhs,n,
     +      one,a,ia,ja,adesc,x,ix,jx,xdesc,
     +      zero,b,ib,jb,bdesc)

!
!      factor the coefficient matrix
!
         call blacs_barrier(p_context(),'all')
         t0 = timef()
         call pdgetrf(n,n,a,ia,ja,adesc,ipiv,iret)
         t1 = timef()
         tf = (t1-t0-tmnull)/1.d3
!
!      solve for the rhs.
!
         if (iret.eq.0) then
            call blacs_barrier(p_context(),'all')
            t0 = timef()
            call pdgetrs('no transpose',n,nrhs,
     +         a,ia,ja,adesc,ipiv,
     +         b,ib,jb,bdesc,iret)
            t1 = timef()
            ts = (t1-t0-tmnull)/1.d3
!
!       check the result  for correctness and print error.
!       define error as  ||bx-x||/||x||
!
            call get2norm(x,b,mpx,nqx,err)
            call dgamx2d(p_context(),'all','1-tree',1,1,tf,1,irm,            &
     &                  icm,1,0,0)
            call dgamx2d(p_context(),'all','1-tree',1,1,ts,1,irm,            &
     &                  icm,1,0,0)
            flf = (((2./3.)*(dble(n)**3.))/tf)*1.d-6
            fls = (dble(nrhs)*(2.*dble(n)**2.)/ts)*1.d-6
         else
            write(0,*)
     +         'factorization error: no solution will take place'
            call dgamx2d(p_context(),'all','1-tree',1,1,tf,1,irm,         &
     &            icm,1,0,0)
            ts  = zero
            err = zero
            flf = (((2./3.)*(dble(n)**3.))/tf)*1.d-6
            fls = zero
         endif

         if ((myrow.eq.0).and.(mycol.eq.0)) then
            write(6,fmt=99996) n, nrhs,nb,nbrhs, tf,ts,
     +         flf,fls,err
         endif
!
         deallocate(ipiv)
         deallocate(a)
         deallocate(b)
         deallocate(x)
        enddo

        call exitutils
        close(10)
      enddo
!
      call exitutils(0)
      stop
!
!
99997 format (4(a6,1x),4(a8,1x),a10)
99996 format (4(i6,1x),2(f8.2,1x),2(f8.0,1x),e10.3)
      end
      double precision function funca(i,j,m,n)

      funca = 3.d0 +
     +   sqrt(abs(dble(i)-dble(j)))/sqrt(dble(max(m,n)))
      return
      end
      double precision function funcx(i,j,m,n)

      funcx = dble(i)*dble(j)
      return
      end

      subroutine pdgegen(func,m,n,a,ia,ja,adesc,ierr)
!     .. scalar arguments ..
      use putilities
      integer  m, n, ia, ja, ierr

!     ..
!     .. array arguments ..
      integer   adesc(DESC_DIM)

      double precision a(adesc(LLD_),*)
      integer, allocatable :: ig(:), jg(:)
!     ..
!     .. function arguments ..
!*********************************************
!*                                           *
!* for pdgegen the func interface is :       *
!*                                           *
!*     double precision func (i,j,m,n)       *
!*                                           *
!*********************************************
      double precision func
      external         func
!     ..
!     .. local scalars ..
      integer     i, j, jb, mb, nb
     +   irsr, icsr, icontxt, m_a, n_a, ii, jj, i1, j1, ib,
     +   ioff, joff, ip0, jp0, il, jl
!     ..

!

      ierr = 0
      m_a   = adesc(M_)
      n_a   = adesc(N_)
      mb    = adesc(MB_)
      nb    = adesc(NB_)
      irsr  = adesc(RSRC_)
      icsr  = adesc(CSRC_)

      if ((mb<=0).or.(nb<=0)) then
               write(0,*)
     +      'error: invalid block sizes'
         ierr = 1
         return
      endif

      if  ((ia+m-1.gt.m_a).or.(ja+n-1.gt.n_a).or.
     +   (ia.lt.1).or.(ja.lt.1)) then
         write(0,*)
     +      'error: submatrix specification outside matrix bounds',
     +      ia,ia+m-1,m_a,ja,ja+n-1,n_a
         ierr = 2
         return
      endif

!
!    throughout the loop i,j are global pointers,
!    il, jl are local pointers
!
      allocate(ig(m_a))
      allocate(jg(n_a))
      call g2l(adesc,ig,jg)

      do j = ja, ja+n-1
         if (jg(j) .ne. -1) then
            do i = ia, ia+m-1
               if (ig(i) .ne. -1) then
                  a(ig(i),jg(j)) = func(i,j,m,n)
               endif
            enddo
         endif
      enddo
      deallocate(ig)
      deallocate(jg)
      return
      end

      subroutine get2norm(x,b,mpx,nqx,err)
      use putilities
      implicit none
!
!  calculate 2-norm for ||x-b||
!  input arguments

      real(long_t)    :: x(:,:), b(:,:)
      real(long_t)    :: err
      integer         :: mpx, nqx
!
!  local variable
      integer         :: nprows, myrow, npcols, mycol, i, j
      integer         :: icontxt, icm, irm
      real(long_t), allocatable :: xnr(:), bnr(:)
      real(long_t)    :: err2, xnrm

      real(long_t)       :: funca, funcx, timef, dnrm2
      external           funca, funcx, timef, dnrm2

      call blacs_gridinfo(p_context(),nprows,npcols,myrow,mycol)
      icontxt = p_context()

      allocate(xnr(nprows))
      allocate(bnr(nprows))
c
c       check the result  for correctness and print error.
      err = 0.d0
      xnr = 0.d0
      bnr = 0.d0

      do j=1, nqx
        do i=1, mpx
          if (b(i,j).ne.b(i,j)) then
            write(0,*) 'warning: nanq in solution'
            err = b(i,j)
          endif
          b(i,j) = b(i,j) - x(i,j)
        enddo
        bnr(myrow+1) = dnrm2(mpx,b(1,j),1)
        call dgsum2d(icontxt,'col',' ',nprows,1,bnr,nprows,-1,mycol)
        xnr(myrow+1) = dnrm2(mpx,x(1,j),1)
        call dgsum2d(icontxt,'col',' ',nprows,1,xnr,nprows,-1,mycol)
        err2 = dnrm2(nprows,bnr,1)
        xnrm = dnrm2(nprows,xnr,1)
        err2 = err2/xnrm
        err  = max(err,err2)
      enddo

      call dgamx2d(icontxt,'all',' ',1,1,err,1,irm,icm,1,0,0)

      deallocate(xnr)
      deallocate(bnr)

      end subroutine get2norm


! You cannot use `digits` as a variable because this is an intrinsic function.
! n_perms at the end must give the factorial of n_digs.
!
! This problem is solved using two different permutations: either you rotate the
! array using the cfsit() intrinsic function, or you swap to array elements with
! backtracking swap back.
program number_permutation
    implicit none
    integer :: n, n_digs, n_perms, d, tmp, r
    integer, allocatable :: digs(:)

    print '(a)', "The number is"
    read *, n

    ! Decompose it into digits
    n_digs = floor(log10(real(n)) + 1)
    allocate(digs(n_digs))
    tmp = n
    do d = 1, n_digs
        r = mod(tmp, 10)
        digs(n_digs + 1 - d) = r
        tmp = (tmp - r) / 10
    end do
    n_perms = 0
    !call cshift_permute(digs, n_digs)
    call swap_permute(digs, 1)
    print '(i0, a)', n_perms, " permutations"
    deallocate(digs)
contains
    recursive subroutine cshift_permute(a, k)
        integer, intent(inout) :: a(:)
        integer, intent(in) :: k
        integer :: i
        if (k == 1) then
            print '(*(i1))', a(:)
            n_perms = n_perms + 1
        else
            do i = 1, k
                call cshift_permute(a, k - 1)
                a(1:k) = cshift(a(1:k), 1)
            end do
        end if
    end subroutine cshift_permute

    subroutine swap(a, b)
        integer, intent(inout) :: a, b
        integer :: tmp
        tmp = a; a = b; b = tmp
    end subroutine swap

    recursive subroutine swap_permute(a, k)
        integer, intent(inout) :: a(:)
        integer, intent(in) :: k
        integer :: i
        if (k == size(a)) then
            print '(*(i1))', a(:)
            n_perms = n_perms + 1
        else
            do i = k, size(a)
                call swap(a(k), a(i))
                call swap_permute(a, k + 1)
                call swap(a(k), a(i))
            end do
        end if
    end subroutine swap_permute
end program number_permutation


module f_module
  use iso_c_binding, only: c_int, c_double
  implicit none

  contains

  real(c_double) &
  function f_sum(n, a) bind(c)
  integer(c_int), intent(in) :: n ! without n didn't work
  real(c_double), intent(in) :: a(n)
  f_sum = sum(a)
  end function

end module f_module


! 4670 Numberical Analysis Homework One
! Determine the largest integer that your system can represent and report the results.
! There should be no variables of type real and no numbers with decimal points.

implicit none
integer i, big
big = 1

do i = 1, 50
     big = big * 2
     print*, big
end do

stop
end