SUBROUTINE SetupInitialConditions
  ! By Allan P. Engsig-Karup.
  USE GlobalVariables
  IMPLICIT NONE
  INTEGER :: i, j, k, Nx, Ny, Nz
  REAL(KIND=long) :: kh, kw, HH, kh_deep, kh_shallow, h_deep, h_shallow, kx, ky, y0
  REAL(KIND=long) :: tmpx(FineGrid%Nx+2*GhostGridX), tmpy(FineGrid%Ny+2*GhostGridY)
  EXTERNAL BeachGen3Dver2, BuildLinearSystem
  ! TEMPORARY POINTERS/VARIABLES
  Nx = FineGrid%Nx
  Ny = FineGrid%Ny
  Nz = FineGrid%Nz
  DetermineBottomGradients = 0
  print*,'IC chosen is case ',IC
  write(fileop(1),*)'IC chosen is case ',IC
  SELECT CASE (IC)

  CASE (-1, 0) ! Initial condition determined by PressureTermOnOff and funPressureTerm.f90 or read from the init file 'OceanWave3D.init'.
     IF (IC==-1)THEN
        print *, 'Reading the initial conditions. ** Not implemented curvilinear! **'
        write(fileop(1),*) 'Reading the initial conditions. ** Not implemented curvilinear! **'

        DO j=1+GhostGridY,FineGrid%Ny+GhostGridY
           Do i=1+GhostGridX,FineGrid%Nx+GhostGridX
              read(fileip(3),*)WaveField%E(i,j),WaveField%P(i,j)
           END Do
        END DO

     ELSE
        IF(PressureTermOnOff==0)THEN
           print*, 'Initial condition is still water.'
           write(fileop(1),*) 'Initial condition is still water.'
        ELSEIF(PressureTermOnOff==1)THEN
           print *, 'Initial condition determined by PressureTermOnOff is a 2D stationary Gaussian hump'
           write(fileop(1),*) 'Initial condition determined by PressureTermOnOff is a 2D stationary Gaussian hump'
        ELSEIF(PressureTermOnOff==2)THEN
           print *, 'Initial condition determined by PressureTermOnOff is a 3D moving Gaussian hump'
           write(fileop(1),*) 'Initial condition determined by PressureTermOnOff is a 3D moving Gaussian hump'
        END IF
        Call funInitialFreeSurfaceElevation(g,FineGrid%Nx+2*GhostGridX,&
             FineGrid%Ny+2*GhostGridY,FineGrid,WaveField)
     END IF
     IF (Lz <= 0)THEN
        ! Read in the bottom contours from a file.
        OPEN(unit=fileip(4),file=fname_bottom,status='old')
        READ(fileip(4),'(A)')head(4)
        PRINT *, 'SetUpInitialConditions:  Reading the bottom contours from file:'
        PRINT *,fname_bottom,' with header:'
        PRINT *, head(4)
        PRINT *, ' '
        WRITE(FILEOP(1),*) 'SetUpInitialConditions:  Reading the bottom contours from file:'
        WRITE(FILEOP(1),*)fname_bottom,' with header:'
        WRITE(FILEOP(1),*) head(4)
        WRITE(FILEOP(1),*) ' '
        READ(fileip(4),*)  DetermineBottomGradients ! Read the gradient  flag

        IF(DetermineBottomGradients==1)THEN
           Print *, ' Reading h and computing derivatives of h numerically.'
           write(fileop(1),*) ' Reading h and computing derivatives of h numerically.'
           ! Read in h(x,y)
           do j=1+GhostGridY,ny+GhostGridY
              DO i=1+GhostGridX,nx+GhostGridX
                 READ(fileip(4),*) FineGrid%h(i,j)
              END DO
           END do
        ELSEIF(DetermineBottomGradients == 0) THEN
           ! Read h(x,y),h_x,h_xx,h_y,h_yy
           Print *, ' Reading h,h_x,h_xx,h_y,h_yy.'
           print *, ' '
           write(fileop(1),*) ' Reading h,h_x,h_xx,h_y,h_yy.'
           write(fileop(1),*) ' '
           !
           Do j=1+GhostGridY,ny+GhostGridY
              DO i=1+GhostGridX,nx+GhostGridX
                 READ(fileip(4),*) FineGrid%h(i,j), FineGrid%hx(i,j), FineGrid%hxx(i,j), &
                      FineGrid%hy(i,j), FineGrid%hyy(i,j)
              END DO
           END Do
        END IF
        !
        ! Extend the bathymetry to the ghost points by copying the domain endpoint values.
        !
        FineGrid%h(1,:)=FineGrid%h(1+GhostGridX,:); FineGrid%h(:,1)=FineGrid%h(:,1+GhostGridY);
        FineGrid%h(nx+2*GhostGridX,:)=FineGrid%h(nx+GhostGridX,:);
        FineGrid%h(:,ny+2*GhostGridY)=FineGrid%h(:,ny+GhostGridY)
        FineGrid%hx(1,:)=FineGrid%hx(1+GhostGridX,:); FineGrid%hx(:,1)=FineGrid%hx(:,1+GhostGridY);
        FineGrid%hx(nx+2*GhostGridX,:)=FineGrid%hx(nx+GhostGridX,:);
        FineGrid%hx(:,ny+2*GhostGridY)=FineGrid%hx(:,ny+GhostGridY)
        FineGrid%hxx(1,:)=FineGrid%hxx(1+GhostGridX,:);
        FineGrid%hxx(:,1)=FineGrid%hxx(:,1+GhostGridY);
        FineGrid%hxx(nx+2*GhostGridX,:)=FineGrid%hxx(nx+GhostGridX,:);
        FineGrid%hxx(:,ny+2*GhostGridY)=FineGrid%hxx(:,ny+GhostGridY)
        FineGrid%hy(1,:)=FineGrid%hy(1+GhostGridX,:); FineGrid%hy(:,1)=FineGrid%hy(:,1+GhostGridY);
        FineGrid%hy(nx+2*GhostGridX,:)=FineGrid%hy(nx+GhostGridX,:);
        FineGrid%hy(:,ny+2*GhostGridY)=FineGrid%hy(:,ny+GhostGridY)
        FineGrid%hyy(1,:)=FineGrid%hyy(1+GhostGridX,:);
        FineGrid%hyy(:,1)=FineGrid%hyy(:,1+GhostGridY);
        FineGrid%hyy(nx+2*GhostGridX,:)=FineGrid%hyy(nx+GhostGridX,:);
        FineGrid%hyy(:,ny+2*GhostGridY)=FineGrid%hyy(:,ny+GhostGridY)
        !
        ! Re-set Lz to be max h(1,1)
        !
        Lz=FineGrid%h(1,1)
     ELSE
        FineGrid%h = Lz; FineGrid%hx=zero; FineGrid%hxx=zero; FineGrid%hy=zero; FineGrid%hyy=zero;
     END IF

  CASE (1) ! Mildly nonlinear standing wave, deep water (Agnon & Glozman (1996))
     print *, 'Mildly nonlinear standing wave (deep water) in a rectangular domain.'
     write(fileop(1),*) 'Mildly nonlinear standing wave (deep water) in a rectangular domain.'
     IF (Nx>1) THEN
        FineGrid%h = two; FineGrid%hx=zero; FineGrid%hxx=zero
        CALL nonlinearstandingwave1D(pi,FineGrid%h(1,1),FineGrid%x,tmp2D,Wavefield%W,Wavefield%E, &
             Wavefield%Ex,Wavefield%Exx,&
             (Nx+2*GhostGridX)*(Ny+2*GhostGridY))
     ELSE IF (Ny>1) THEN
        FineGrid%h = two; FineGrid%hy=zero; FineGrid%hyy=zero
        CALL nonlinearstandingwave1D(pi,FineGrid%h(1,1),FineGrid%y,tmp2D,Wavefield%W,Wavefield%E, &
             Wavefield%Ey,Wavefield%Eyy,&
             (Nx+2*GhostGridX)*(Ny+2*GhostGridY))
     ENDIF
     !GD: test in a curvilinear rotated domain...
     IF (curvilinearONOFF == 1) THEN
        !Rotate the physical grid with a given angle...
        tmp2D = FineGrid%x
        FineGrid%x = tmp2D*COS(20*PI/180)-FineGrid%y*SIN(20*PI/180)
        FineGrid%y = tmp2D*SIN(20*PI/180)+FineGrid%y*COS(20*PI/180)
     ENDIF
     !
     !
  CASE (2) ! Shallow water to Deep water (3D)
     kh_deep    = pi
     kh_shallow = half
     kx         = two*pi/Lx
     ky         = two*pi/Ly
     kw         = SQRT(kx**2 + ky**2)
     h_deep     = kh_deep/kw
     h_shallow  = kh_shallow/kw
     CALL BeachGen3Dver2(FineGrid%h,h_deep,h_shallow,Lx,Ly,FineGrid%x,FineGrid%y,Nx,Ny)
     HH   = 0.4_long*h_shallow
     Wavefield%E   =  HH*COS(kx*FineGrid%x)*COS(ky*FineGrid%y);
     Wavefield%Ex  = -HH*(kx)*SIN(kx*FineGrid%x)*COS(ky*FineGrid%y);
     Wavefield%Exx = -HH*(kx)**2*COS(kx*FineGrid%x)*COS(ky*FineGrid%y);
     Wavefield%Ey  = -HH*(ky)*COS(kx*FineGrid%x)*SIN(ky*FineGrid%y);
     Wavefield%Eyy = -HH*(ky)**2*COS(kx*FineGrid%x)*COS(ky*FineGrid%y);
     DetermineBottomGradients = 1
  CASE (3) ! Whalin (3D)
     IF (FineGrid%Nx>FineGrid%Ny) THEN
        y0 = (FineGrid%y(1,2)-FineGrid%y(1,1))/two ! FIXME: x-index
     ELSE
        y0 = (FineGrid%x(2,1)-FineGrid%x(1,1))/two ! FIXME: y-index
     ENDIF
     ! Define bottom
     CALL BottomWhalin(FineGrid,y0,GhostGridX, GhostGridY)
     !
     IF(swenseONOFF==1)THEN
        IF (LinearONOFF==0) THEN
           print*,'it should be a nonlinear case!'
           STOP
           ! Linear incident wavefield
           CALL incident_linear_wf_finite(swenseDir, Wavefield, & !ramp_type,&
                Nx+2*GhostGridX,FineGrid%x,Ny+2*GhostGridY,FineGrid%y,Nz+GhostGridz,FineGrid%z,FineGrid%h,zero,&
                SFsol%k,g,SFsol%HH,SFsol%h)
        ELSE
           ! Nonlinear incident wavefield
           ! Initialize stream function coefficients
           CALL stream_func_set_up(g,SFsol%h,SFsol%T,SFsol%i_wavel_or_per,SFsol%L,  &
                SFsol%k,SFsol%HH,SFsol%i_euler_or_stokes,SFsol%e_or_s_vel,SFsol%i_deep_or_finite,  &
                SFsol%n_h_steps,SFsol%n_four_modes,SFsol%nwrk,SFsol%yy,SFsol%zz)
           CALL incident_wf_finite(swenseDir, Wavefield, &
                Nx+2*GhostGridX,FineGrid%x,Ny+2*GhostGridY,FineGrid%y,Nz+GhostGridz,FineGrid%z,FineGrid%h,zero, &
                SFsol%k,g,SFsol%n_four_modes,SFsol%zz,SFsol%yy)
        ENDIF
     ENDIF
  CASE (4) ! Deep water, flat bottom, linear standing wave
     IF (Nx>0) THEN
        FineGrid%hx    = zero
        FineGrid%hxx   = zero
     ENDIF
     IF (Ny>0) THEN
        FineGrid%hy    = zero
        FineGrid%hyy   = zero
     ENDIF
     IF (Nx>1) THEN
        kh = two*pi
        kw = two*pi/Lx
        FineGrid%h  = kh/kw
        HH = Lx/ten ! initial wave height
        Wavefield%E   = HH/two*COS(kw*FineGrid%x)
        Wavefield%Ex  = -kw*HH/two*SIN(kw*FineGrid%x)
        Wavefield%Exx = -kw**two*HH/two*COS(kw*FineGrid%x)
     ELSE
        kh = two*pi
        kw = two*pi/Ly
        FineGrid%h  = kh/kw
        HH = Ly/ten ! initial wave height
        Wavefield%E   = HH/two*COS(kw*FineGrid%y)
        Wavefield%Ey  = -kw*HH/two*SIN(kw*FineGrid%y)
        Wavefield%Eyy = -kw**two*HH/two*COS(kw*FineGrid%y)
     ENDIF
  CASE (5) ! Shallow water, flat bottom
     IF (Nx>1) THEN
        FineGrid%hx    = zero
        FineGrid%hxx   = zero
     ENDIF
     IF (Ny>1) THEN
        FineGrid%hy    = zero
        FineGrid%hyy   = zero
     ENDIF
     IF (Nx>1) THEN
        kh = half
        kw = two*pi/Lx
        FineGrid%h  = kh/kw
        HH = FineGrid%h(1,1)*0.75_long ! initial wave height
        Wavefield%E   = HH/two*COS(kw*FineGrid%x)
        Wavefield%Ex  = -kw*HH/two*SIN(kw*FineGrid%x)
        Wavefield%Exx = -kw**two*HH/two*COS(kw*FineGrid%x)
     ELSE
        kh = half
        kw = two*pi/Ly
        FineGrid%h  = kh/kw
        HH = FineGrid%h(1,1)*0.75_long ! initial wave height
        Wavefield%E   = HH/two*COS(kw*FineGrid%y)
        Wavefield%Ey  = -kw*HH/two*SIN(kw*FineGrid%y)
        Wavefield%Eyy = -kw**2*HH/two*COS(kw*FineGrid%y)
     ENDIF
  CASE (6) ! Shallow to Deep Water
     !$$$$$$         kh_deep    = pi
     !$$$$$$         kh_shallow = half
     !$$$$$$         kw         = two*pi/Lx
     !$$$$$$         h_deep     = kh_deep/kw
     !$$$$$$         h_shallow  = kh_shallow/kw
     !$$$$$$         HH   = 0.75_long*h_shallow
     !$$$$$$         IF (Nx>1) THEN
     !$$$$$$                 CALL BeachGen2(h_deep,h_shallow,Lx,FineGrid%x,FineGrid%h,FineGrid%hx,FineGrid%hxx,FineGrid%Nx)
     !$$$$$$                 Wavefield%E   = HH/two*COS(kw*FineGrid%x)
     !$$$$$$                 Wavefield%Ex  = -kw*HH/two*SIN(kw*FineGrid%x)
     !$$$$$$                 Wavefield%Exx = -kw**2*HH/two*COS(kw*FineGrid%x)
     !$$$$$$         ELSE
     !$$$$$$                 CALL BeachGen2(h_deep,h_shallow,Lx,FineGrid%y,FineGrid%h,FineGrid%hy,FineGrid%hyy,FineGrid%Ny)
     !$$$$$$                 Wavefield%E   = HH/two*COS(kw*FineGrid%y)
     !$$$$$$                 Wavefield%Ey  = -kw*HH/two*SIN(kw*FineGrid%y)
     !$$$$$$                 Wavefield%Eyy = -kw**2*HH/two*COS(kw*FineGrid%y)
     !$$$$$$         ENDIF
     ! GD: one has to define wave generation and absorption for this test case ?
     kh_deep    = pi
     !kh_shallow = half
     kh_shallow = pi/20.d0
     !kw         = two*pi/Lx
     kw         = two*pi/SFsol%L
     h_deep     = kh_deep/kw
     h_shallow  = kh_shallow/kw
     IF (SFsol%HH.GT.0.75_long*h_shallow) THEN
        print*, 'reduce amplitude of incident wave...'
        stop
     ENDIF
     HH   = SFsol%HH !0.75_long*h_shallow
     IF (Nx>1) THEN
        ! use relaxation indexes to define correctly ...
        ! First zone: generation on the left
        !RelaxZones(1)%idx(1) !beginnning first zone (will be first point in this case)
        !RelaxZones(1)%idx(2) !end first zone (beginning of the slope then)
        !Second zone:absorption on the right
        !RelaxZones(2)%idx(1) !beginnning first zone (end of the slope)
        !RelaxZones(2)%idx(2) !end first zone (last point)
        !
        CALL BeachGen2_bis(h_deep,h_shallow,RelaxZones(1)%idx(2),RelaxZones(2)%idx(1),FineGrid%x,  &
             FineGrid%h,FineGrid%hx,FineGrid%hxx,FineGrid%Nx+2*GhostGridX)
        ! No intialisation one generates wave
        !Wavefield%E   = HH/two*COS(kw*FineGrid%x)
        !Wavefield%Ex  = -kw*HH/two*SIN(kw*FineGrid%x)
        !Wavefield%Exx = -kw**2*HH/two*COS(kw*FineGrid%x)
     ELSE
        ! use relaxation indexes to define correctly ...
        ! First zone: generation on the left
        !RelaxZones(1)%idx(3) !beginnning first zone (will be first point in this case)
        !RelaxZones(1)%idx(4) !end first zone (beginning of the slope then)
        !Second zone:absorption on the right
        !RelaxZones(2)%idx(3) !beginnning first zone (end of the slope)
        !RelaxZones(2)%idx(4) !end first zone (last point)
        CALL BeachGen2_bis(h_deep,h_shallow,RelaxZones(1)%idx(4),RelaxZones(2)%idx(3),FineGrid%y,  &
             FineGrid%h,FineGrid%hy,FineGrid%hyy,FineGrid%Ny+2*GhostGridZ)
        ! No intialisation one generates wave
        !Wavefield%E   = HH/two*COS(kw*FineGrid%y)
        !Wavefield%Ey  = -kw*HH/two*SIN(kw*FineGrid%y)
        !Wavefield%Eyy = -kw**2*HH/two*COS(kw*FineGrid%y)
     ENDIF
     ! Relaxation
     IF (relaxONOFF==1) THEN
        CALL RelaxationModule(Wavefield%E,Wavefield%P,0.d0)
     ENDIF
     print *, 'initialisation of Linear Shoaling'
     write(fileop(1),*) 'initialisation of Linear Shoaling'

  CASE (7) ! Flat bottom, depth defined from SF-wave
     IF (Nx>1) THEN
        FineGrid%hx    = zero
        FineGrid%hxx   = zero
     ENDIF
     IF (Ny>1) THEN
        FineGrid%hy    = zero
        FineGrid%hyy   = zero
     ENDIF
     FineGrid%h         = SFsol%h
     !
     IF (curvilinearONOFF==1) THEN ! curvilinear coordinates... FIXME for make it work whatever transformation
        ! In the curvilinear case, BBox have to be the indexes of the corresponding relaxation zones
        ! FIXME: use Lx and Ly? Depends how x and y are defined...
        DO j=1,FineGrid%Nx+2*GhostGridX
           tmpx(j) = REAL(j-2,long)*(FineGrid%y(2,1)-FineGrid%y(1,1)) !/REAL((FineGrid%Nx+2*GhostGridX-1),long)*(8+PI)*Lx; !FIXME find a way to define in all situation...
        ENDDO
        DO j=1,FineGrid%Ny+2*GhostGridY
           tmpy(j) = -REAL(j-2,long)*(FineGrid%x(1,2)-FineGrid%x(1,1)) !/REAL((FineGrid%Ny+2*GhostGridY-1),long)*(Ly-Lx); !FIXME find a way to define in all situation...
        ENDDO
     ELSE
        tmpx(:) = FineGrid%x(:,1)
        tmpy(:) = FineGrid%y(1,:)
     ENDIF
     IF (relaxONOFF==1) THEN
        IF (relaxXorY=='X' .OR. relaxXorY=='x') THEN
           IF (relaxDegrees==zero) THEN
              CALL stream_func_wave_finite(FineGrid%Nx+2*GhostGridX,tmpx,time,SFsol%n_four_modes,SFsol%zz,SFsol%yy,&
                   SFsol%k,g,Wavefield%E(:,1),Wavefield%P(:,1))
              DO j=1,FineGrid%Ny+2*GhostGridY
                 Wavefield%E(:,j) = Wavefield%E(:,1)
                 Wavefield%P(:,j) = Wavefield%P(:,1)
              END DO
           ELSE
              DO j=1,FineGrid%Ny+2*GhostGridY
                 CALL stream_func_wave_finite(FineGrid%Nx+2*GhostGridX,tmpx*COS(relaxDegrees/180.0_long*pi)+&
                      tmpy(j)*SIN(relaxDegrees/180.0_long*pi),time,SFsol%n_four_modes,SFsol%zz,&
                      SFsol%yy,SFsol%k,g,Wavefield%E(:,1),Wavefield%P(:,1))
                 Wavefield%E(:,j) = Wavefield%E(:,1)
                 Wavefield%P(:,j) = Wavefield%P(:,1)
              END DO
           ENDIF
        ELSE
           IF (relaxDegrees==zero) THEN
              CALL stream_func_wave_finite(FineGrid%Ny+2*GhostGridY,tmpy,time,SFsol%n_four_modes,SFsol%zz,SFsol%yy,&
                   SFsol%k,g,Wavefield%E(1,:),Wavefield%P(1,:))
              DO j=1,FineGrid%Nx+2*GhostGridX
                 Wavefield%E(j,:) = Wavefield%E(1,:)
                 Wavefield%P(j,:) = Wavefield%P(1,:)
              END DO
           ELSE
              DO j=1,FineGrid%Nx+2*GhostGridX
                 CALL stream_func_wave_finite(FineGrid%Ny+2*GhostGridY,-tmpy*SIN(relaxDegrees/180.0_long*pi)+&
                      tmpx(j)*COS(relaxDegrees/180.0_long*pi),time,SFsol%n_four_modes,SFsol%zz,&
                      SFsol%yy,SFsol%k,g,Wavefield%E(1,:),Wavefield%P(1,:))
                 Wavefield%E(j,:) = Wavefield%E(1,:)
                 Wavefield%P(j,:) = Wavefield%P(1,:)
              END DO
           ENDIF
        ENDIF
        ! Relax initial condition three times for full absorption
        CALL RelaxationModule(Wavefield%E,Wavefield%P,time)
        CALL RelaxationModule(Wavefield%E,Wavefield%P,time)
        CALL RelaxationModule(Wavefield%E,Wavefield%P,time)
     ENDIF
     IF(curvilinearONOFF==1) THEN
        ! FIXME: to add
     ELSE
        CALL PreProcessDiffStencils(FineGrid,FineGrid%DiffStencils,GhostGridX,GhostGridY,GhostGridZ,  &
             alpha,beta,gamma,fileop(1))
        IF (FineGrid%Nx>1) THEN
           CALL DiffXEven(Wavefield%E,Wavefield%Ex,1,FineGrid%Nx,FineGrid%Ny,1,FineGrid%DiffStencils,alpha)
           CALL DiffXEven(Wavefield%E,Wavefield%Exx,2,FineGrid%Nx,FineGrid%Ny,1,FineGrid%DiffStencils,alpha)
           CALL DiffXEven(Wavefield%P,Wavefield%Px,1,FineGrid%Nx,FineGrid%Ny,1,FineGrid%DiffStencils,alpha)
        END IF
        IF (FineGrid%Ny>1) THEN
           CALL DiffYEven(Wavefield%E,Wavefield%Ey,1,FineGrid%Nx,FineGrid%Ny,1,FineGrid%DiffStencils,beta)
           CALL DiffYEven(Wavefield%E,Wavefield%Eyy,2,FineGrid%Nx,FineGrid%Ny,1,FineGrid%DiffStencils, &
                beta)
           CALL DiffYEven(Wavefield%P,Wavefield%Py,1,FineGrid%Nx,FineGrid%Ny,1,FineGrid%DiffStencils, &
                beta)
        END IF
     ENDIF
  CASE (8) ! Linear standing wave (2D) + in curvilinear space rotation with an angle
     FineGrid%h = SFsol%h
     IF (Nx>1) THEN
        FineGrid%hx=zero; FineGrid%hxx=zero
     ENDIF
     IF (Ny>1) THEN
        FineGrid%hy=zero; FineGrid%hyy=zero
     ENDIF
     ! FIXME: Does not work for problems with only one spatial dimension in the horizontal /APEK
     CALL linearstandingwave2D(g,zero,zero,SFsol,SFsol%L,SFsol%L,FineGrid%h(1,1),FineGrid%x,FineGrid%y&
          ,Wavefield%P,tmp2D,tmp2D,Wavefield%W,Wavefield%E,Wavefield%Ex,Wavefield%Exx,Wavefield%Ey, &
          Wavefield%Eyy,(Nx+2*GhostGridX)*(Ny+2*GhostGridY))
     IF (curvilinearONOFF == 1) THEN
        !Rotate the physical grid with a given angle...
        tmp2D = FineGrid%x
        FineGrid%x = tmp2D*COS(20*PI/180)-FineGrid%y*SIN(20*PI/180)
        FineGrid%y = tmp2D*SIN(20*PI/180)+FineGrid%y*COS(20*PI/180)
     ENDIF
     print*,'  Linear standing wave parameters:'
     print*,'      kh = ',SFsol%k*SFsol%h
     print*,'      T  = ',SFsol%T
     print*,'      c  = ',SFsol%c
     print*,'      h  = ',SFsol%h
     IF (FineGrid%Nx>1) THEN
        dxmin = dx
     ELSE
        dxmin = two*dy
     ENDIF
     IF (FineGrid%Ny>1) THEN
        dymin = dy
     ELSE
        dymin = two*dx
     ENDIF
     PRINT *,'      dt = ',dt
     PRINT *,'      Cr = ',SFsol%c*dt/MIN(dxmin,dymin)
     WRITE(FILEOP(1),*)'      dt = ',dt
     WRITE(FILEOP(1),*)'      Cr = ',SFsol%c*dt/MIN(dxmin,dymin)
  CASE (9) ! Berkhoff (3D)
     CALL BottomBerkoff(FineGrid,GhostGridX,GhostGridY)
     DetermineBottomGradients = 1
  CASE (10) ! GD: SWENSE, Flat bottom, depth defined from SF-wave
     IF (curvilinearONOFF == 1) THEN
        !Rotate the physical grid with a given angle...
        tmp2D = FineGrid%x
        FineGrid%x = tmp2D*COS(20.d0*PI/180.d0)-FineGrid%y*SIN(20.d0*PI/180.d0)
        FineGrid%y = tmp2D*SIN(20.d0*PI/180.d0)+FineGrid%y*COS(20.d0*PI/180.d0)
        swenseDir = 20.d0
     ENDIF
     IF (Nx>1) THEN
        FineGrid%hx    = zero
        FineGrid%hxx   = zero
     ENDIF
     IF (Ny>1) THEN
        FineGrid%hy    = zero
        FineGrid%hyy   = zero
     ENDIF
     FineGrid%h         = SFsol%h
     ! E,P and their derivatives are zero
     !
     ! Initialization of incident wavefield
     PRINT*,'Beginning of SWENSE Initialization'
     IF(swenseONOFF==0)THEN
        PRINT*,'We should use SWENSE... put swenseONOFF=1 !'
        !STOP
     ELSE
        IF (LinearONOFF==0) THEN
           ! Linear incident wavefield
           CALL incident_linear_wf_finite(swenseDir, Wavefield, & !ramp_type,&
                Nx+2*GhostGridX,FineGrid%x,Ny+2*GhostGridY,FineGrid%y,Nz+GhostGridz,FineGrid%z,  &
                FineGrid%h,zero,SFsol%k,g,SFsol%HH,SFsol%h)
        ELSE
           ! Nonlinear incident wavefield
           print*,' this case is not available already... several checks to make...'
           ! Initialize stream function coefficients
           CALL stream_func_set_up(g,SFsol%h,SFsol%T,SFsol%i_wavel_or_per,SFsol%L,  &
                SFsol%k,SFsol%HH,SFsol%i_euler_or_stokes,SFsol%e_or_s_vel,SFsol%i_deep_or_finite,  &
                SFsol%n_h_steps,SFsol%n_four_modes,SFsol%nwrk,SFsol%yy,SFsol%zz)
           CALL incident_wf_finite(swenseDir, Wavefield, &
                Nx+2*GhostGridX,FineGrid%x,Ny+2*GhostGridY,FineGrid%y,Nz+GhostGridz,FineGrid%z,  &
                FineGrid%h,zero, &
                SFsol%k,g,SFsol%n_four_modes,SFsol%zz,SFsol%yy)
        ENDIF
        PRINT*,'End of SWENSE Initialization'
     ENDIF
  CASE (11) ! Flat bottom, depth defined from SF-wave for semi circular channel...
     IF (Nx>1) THEN
        FineGrid%hx    = zero
        FineGrid%hxx   = zero
     ENDIF
     IF (Ny>1) THEN
        FineGrid%hy    = zero
        FineGrid%hyy   = zero
     ENDIF
     FineGrid%h         = SFsol%h
     !
     IF (curvilinearONOFF==1) THEN ! curvilinear coordinates... FIXME for make it work whatever transformation
        ! In the curvilinear case, BBox have to be the indexes of the corresponding relaxation zones
        ! FIXME: use Lx and Ly? Depends how x and y are defined...  save e and n directly ?
        DO j=1,FineGrid%Nx+2*GhostGridX
           tmpx(j) = REAL(j-2,long)*(FineGrid%y(2,1)-FineGrid%y(1,1)) !/REAL((FineGrid%Nx+2*GhostGridX-1),long)*(8+PI)*Lx; !FIXME find a way to define in all situation...
        ENDDO
        DO j=1,FineGrid%Ny+2*GhostGridY
           tmpy(j) = -REAL(j-2,long)*(FineGrid%x(1,2)-FineGrid%x(1,1)) !/REAL((FineGrid%Ny+2*GhostGridY-1),long)*(Ly-Lx); !FIXME find a way to define in all situation...
        ENDDO
     ELSE
        tmpx(:) = FineGrid%x(:,1)
        tmpy(:) = FineGrid%y(1,:)
     ENDIF
     IF (relaxONOFF==1) THEN
        ! Relax initial condition
        CALL RelaxationModule(Wavefield%E,Wavefield%P,time)
        CALL RelaxationModule(Wavefield%E,Wavefield%P,time)
        CALL RelaxationModule(Wavefield%E,Wavefield%P,time)
     ENDIF
     IF(swenseONOFF==0)THEN
        ! Nothing to do here
     ELSE
        IF (LinearONOFF==0) THEN
           ! Linear incident wavefield
           CALL incident_linear_wf_finite(swenseDir, Wavefield, & !ramp_type,&
                Nx+2*GhostGridX,FineGrid%x,Ny+2*GhostGridY,FineGrid%y,Nz+GhostGridz,FineGrid%z,  &
                FineGrid%h,zero,&
                SFsol%k,g,SFsol%HH,SFsol%h)
        ELSE
           ! Nonlinear incident wavefield
           print*,' this case is not available already... several checks to make...'
           ! Initialize stream function coefficients
           CALL stream_func_set_up(g,SFsol%h,SFsol%T,SFsol%i_wavel_or_per,SFsol%L,  &
                SFsol%k,SFsol%HH,SFsol%i_euler_or_stokes,SFsol%e_or_s_vel,SFsol%i_deep_or_finite,  &
                SFsol%n_h_steps,SFsol%n_four_modes,SFsol%nwrk,SFsol%yy,SFsol%zz)
           CALL incident_wf_finite(swenseDir, Wavefield, &
                Nx+2*GhostGridX,FineGrid%x,Ny+2*GhostGridY,FineGrid%y,Nz+GhostGridz,FineGrid%z,  &
                FineGrid%h,zero, SFsol%k,g,SFsol%n_four_modes,SFsol%zz,SFsol%yy)
        ENDIF
        PRINT*,'End of SWENSE Initialization'
     ENDIF
  CASE (12) ! Flat bottom, depth defined from SF-wave to check convergence...
     IF (Nx>1) THEN
        FineGrid%hx    = zero
        FineGrid%hxx   = zero
     ENDIF
     IF (Ny>1) THEN
        FineGrid%hy    = zero
        FineGrid%hyy   = zero
     ENDIF
     FineGrid%h         = SFsol%h
     kw = SFsol%k
     HH = SFsol%HH ! initial wave height
     Wavefield%E   = HH/two*COS(kw*FineGrid%x)*COS(kw*FineGrid%y)
     Wavefield%Ex  = -kw*HH/two*SIN(kw*FineGrid%x)*COS(kw*FineGrid%y)
     Wavefield%Exx = -kw**two*HH/two*COS(kw*FineGrid%x)*COS(kw*FineGrid%y)
     Wavefield%Ey  = -kw*HH/two*COS(kw*FineGrid%x)*SIN(kw*FineGrid%y)
     Wavefield%Eyy = -kw**two*HH/two*COS(kw*FineGrid%x)*COS(kw*FineGrid%y)
     ! Cross derivative Exy saved in Px
     Wavefield%Px  = kw**two*HH/two*SIN(kw*FineGrid%x)*SIN(kw*FineGrid%y)
     ! Put corners to wrong value
     Wavefield%E(1,1)=1000.0_long
     Wavefield%E(Nx+2*GhostGridX,1)=1000.0_long
     Wavefield%E(1,Ny+2*GhostGridY)=1000.0_long
     Wavefield%E(Nx+2*GhostGridX,Ny+2*GhostGridY)=1000.0_long
     !
     ! Test on thecross derivatives XZ and YZ...
     DO j=1,FineGrid%Nz+GhostGridZ
        PHI(j,:,:) = HH/two*COS(kw*FineGrid%x)*COS(kw*FineGrid%y)  &
             *COSH(kw*((FineGrid%z(j)-one)*FineGrid%h+FineGrid%h))/COSH(kw)!COSH(kw*FineGrid%h)
        !DXZ
        LASTPHI(j,:,:,1) = -kw**2*HH/two*SIN(kw*FineGrid%x)*COS(kw*FineGrid%y)  &
             *SINH(kw*((FineGrid%z(j)-one)&
             *FineGrid%h+FineGrid%h))/COSH(kw)!COSH(kw*FineGrid%h)
        !DYZ
        LASTPHI(j,:,:,2) = -kw**2*HH/two*COS(kw*FineGrid%x)*SIN(kw*FineGrid%y) &
             *SINH(kw*((FineGrid%z(j)-one)*FineGrid%h+FineGrid%h))/COSH(kw)!COSH(kw*FineGrid%h)
     ENDDO
     ! Put corners to zero...
     !PHI(1,1,1) = 1000.0_long
     !PHI(FineGrid%Nz+GhostGridZ,1,1) = 1000.0_long
     !PHI(1,Nx+2*GhostGridX,1) = 1000.0_long
     !PHI(FineGrid%Nz+GhostGridZ,Nx+2*GhostGridX,1) = 1000.0_long
     !PHI(1,1,Ny+2*GhostGridY) = 1000.0_long
     !PHI(FineGrid%Nz+GhostGridZ,1,Ny+2*GhostGridY) = 1000.0_long
     !PHI(FineGrid%Nz+GhostGridZ,Nx+2*GhostGridX,Ny+2*GhostGridY) = 1000.0_long
     !PHI(1,Nx+2*GhostGridX,Ny+2*GhostGridY) = 1000.0_long
     ! This is the whole edges of the domain which are not treated OK ?
     PHI(1:FineGrid%Nz+GhostGridZ,1,1) = 1000.0_long
     PHI(1:FineGrid%Nz+GhostGridZ,Nx+2*GhostGridX,1) = 1000.0_long
     PHI(1:FineGrid%Nz+GhostGridZ,1,Ny+2*GhostGridY) = 1000.0_long
     PHI(1:FineGrid%Nz+GhostGridZ,Nx+2*GhostGridX,Ny+2*GhostGridY) = 1000.0_long
     ! Bottom
     PHI(1,1:Nx+2*GhostGridX,1) = 1000.0_long
     PHI(1,1:Nx+2*GhostGridX,Ny+2*GhostGridY) = 1000.0_long
     PHI(1,1,1:Ny+2*GhostGridY) = 1000.0_long
     PHI(1,Nx+2*GhostGridX,1:Ny+2*GhostGridY) = 1000.0_long
     ! Free surface... We can usr free surface points
     !PHI(FineGrid%Nz+GhostGridZ,1:Nx+2*GhostGridX,1) = 1000.0_long
     !PHI(FineGrid%Nz+GhostGridZ,1:Nx+2*GhostGridX,Ny+2*GhostGridY) = 1000.0_long
     !PHI(FineGrid%Nz+GhostGridZ,1,1:Ny+2*GhostGridY) = 1000.0_long
     !PHI(FineGrid%Nz+GhostGridZ,Nx+2*GhostGridX,1:Ny+2*GhostGridY) = 1000.0_long
  CASE(13) ! Linear standing wave (2D) + in curvilinear space rotation with an angle
     FineGrid%h = SFsol%h
     IF (Nx>1) THEN
        FineGrid%hx=zero; FineGrid%hxx=zero
     ENDIF
     IF (Ny>1) THEN
        FineGrid%hy=zero; FineGrid%hyy=zero
     ENDIF
     IF(swenseONOFF==0)THEN
        CALL linearstandingwave2D(g,zero,zero,SFsol,SFsol%L,SFsol%L,FineGrid%h(1,1),FineGrid%x, &
             FineGrid%y&
             ,Wavefield%P,tmp2D,tmp2D,Wavefield%W,Wavefield%E,Wavefield%Ex,Wavefield%Exx,  &
             Wavefield%Ey,Wavefield%Eyy,&
             (Nx+2*GhostGridX)*(Ny+2*GhostGridY))
        IF (curvilinearONOFF == 1) THEN
           !Rotate the physical grid with a given angle...
           tmp2D = FineGrid%x
           FineGrid%x = tmp2D*COS(20.d0*PI/180.d0)-FineGrid%y*SIN(20.d0*PI/180.d0)
           FineGrid%y = tmp2D*SIN(20.d0*PI/180.d0)+FineGrid%y*COS(20.d0*PI/180.d0)
        ENDIF
     ELSE
        IF (curvilinearONOFF == 1) THEN
           !Rotate the physical grid with a given angle...
           tmp2D = FineGrid%x
           FineGrid%x = tmp2D*COS(20.d0*PI/180.d0)-FineGrid%y*SIN(20.d0*PI/180.d0)
           FineGrid%y = tmp2D*SIN(20.d0*PI/180.d0)+FineGrid%y*COS(20.d0*PI/180.d0)
        ENDIF
        IF (LinearONOFF==0) THEN
           ! Linear incident wavefield
           CALL incident_linear_wf_finite_standing(swenseDir, Wavefield, & !ramp_type,&
                Nx+2*GhostGridX,FineGrid%x,Ny+2*GhostGridY,FineGrid%y,Nz+GhostGridz,FineGrid%z, &
                FineGrid%h,zero,&
                SFsol%k,g,SFsol%HH,SFsol%h)
        ELSE
           ! Nonlinear incident wavefield
           print*,' this case is not available already... several checks to make...'
           stop
        ENDIF
        PRINT*,'End of SWENSE Initialization'
     ENDIF
     print*,'  Linear standing wave parameters:'
     print*,'      kh = ',SFsol%k*SFsol%h
     print*,'      T  = ',SFsol%T
     print*,'      c  = ',SFsol%c
     print*,'      h  = ',SFsol%h
     write(fileop(1),*)'  Linear standing wave parameters:'
     write(fileop(1),*)'      kh = ',SFsol%k*SFsol%h
     write(fileop(1),*)'      T  = ',SFsol%T
     write(fileop(1),*)'      c  = ',SFsol%c
     write(fileop(1),*)'      h  = ',SFsol%h
     IF (FineGrid%Nx>1) THEN
        dxmin = dx
     ELSE
        dxmin = two*dy
     ENDIF
     IF (FineGrid%Ny>1) THEN
        dymin = dy
     ELSE
        dymin = two*dx
     ENDIF
     PRINT*,'      dt = ',dt
     PRINT*,'      Cr = ',SFsol%c*dt/MIN(dxmin,dymin)
     WRITE(FILEOP(1),*)'      dt = ',dt
     WRITE(FILEOP(1),*)'      Cr = ',SFsol%c*dt/MIN(dxmin,dymin)
  CASE (14) ! Mildly nonlinear standing wave, deep water (Agnon & Glozman (1996)) with SWENSE
     IF (Nx>1) THEN
        FineGrid%h = two; FineGrid%hx=zero; FineGrid%hxx=zero
     ELSE IF (Ny>1) THEN
        FineGrid%h = two; FineGrid%hy=zero; FineGrid%hyy=zero
     ENDIF
     SFsol%h = FineGrid%h(1,1)
     IF(swenseONOFF==0)THEN
        IF (Nx>1) THEN
           CALL nonlinearstandingwave1D(pi,FineGrid%h(1,1),FineGrid%x,tmp2D,Wavefield%W,Wavefield%E, &
                Wavefield%Ex,Wavefield%Exx,&
                (Nx+2*GhostGridX)*(Ny+2*GhostGridY))
        ELSE IF (Ny>1) THEN
           CALL nonlinearstandingwave1D(pi,FineGrid%h(1,1),FineGrid%y,tmp2D,Wavefield%W,Wavefield%E, &
                Wavefield%Ey,Wavefield%Eyy,&
                (Nx+2*GhostGridX)*(Ny+2*GhostGridY))
        ENDIF
     ENDIF
     !GD: test in a curvilinear rotated domain...
     IF (curvilinearONOFF == 1) THEN
        !Rotate the physical grid with a given angle...
        tmp2D = FineGrid%x
        FineGrid%x = tmp2D*COS(20*PI/180)-FineGrid%y*SIN(20*PI/180)
        FineGrid%y = tmp2D*SIN(20*PI/180)+FineGrid%y*COS(20*PI/180)
     ENDIF
     IF (LinearONOFF==1) THEN
        ! Non-Linear incident wavefield
        CALL incident_nonlinear_wf_finite_standing(swenseDir, Wavefield, & !ramp_type,&
             Nx+2*GhostGridX,FineGrid%x,Ny+2*GhostGridY,FineGrid%y,Nz+GhostGridz,FineGrid%z,  &
             FineGrid%h,zero,&
             SFsol%k,g,SFsol%HH,SFsol%h)
     ELSE
        ! Linear incident wavefield
        print*,' this case is not available... for linear case 13'
        stop
     ENDIF
  CASE(15) !2D submerged bar test
     IF (Ny>1) THEN
        print*,'Only 2D case along x for now'
        STOP
     ENDIF
     ! Determine size of left relaxation zones... (assumed that this is defined in the 1st
     ! relaxation zone)
     y0 = FineGrid%x(RelaxZones(1)%idx(2),1)
     ! Define bottom
     IF (Lz>0) THEN
        CALL SubmergedBar_2D(FineGrid,y0,GhostGridX)
     ELSE
      !-------------------------------------------------------------------------
      ! Read in the bottom contours from a file:
      !-------------------------------------------------------------------------
      OPEN(unit=fileip(4),file=fname_bottom,status='old')
      READ(fileip(4),'(A)')head(4)
      PRINT *, 'SetUpInitialConditions:  Reading the bottom contours from file:'
      PRINT *,fname_bottom,' with header:'
      PRINT *, head(4)
      PRINT *, ' '
      WRITE(FILEOP(1),*) 'SetUpInitialConditions:  Reading the bottom contours from file:'
      WRITE(FILEOP(1),*)fname_bottom,' with header:'
      WRITE(FILEOP(1),*) head(4)
      WRITE(FILEOP(1),*) ' '
      READ(fileip(4),*)  DetermineBottomGradients ! Read the gradient flag

      !-------------------------------------------------------------------------
      ! Read h(x,y),h_x,h_xx,h_y,h_yy
      !-------------------------------------------------------------------------
      Print *, ' Reading h,h_x,h_xx,h_y,h_yy.'
      print *, ' '
      write(fileop(1),*) ' Reading h,h_x,h_xx,h_y,h_yy.'
      write(fileop(1),*) ' '
      Do j=1+GhostGridY,ny+GhostGridY
        DO i=1+GhostGridX,nx+GhostGridX
          READ(fileip(4),*) FineGrid%h(i,j),    &
                            FineGrid%hx(i,j),   &
                            FineGrid%hxx(i,j),  &
                            FineGrid%hy(i,j),   &
                            FineGrid%hyy(i,j)
        END DO
      END DO

      !-------------------------------------------------------------------------
      ! Extend the bathymetry to the ghost points by copying the domain
      ! endpoint values.
      !-------------------------------------------------------------------------
      FineGrid%h(1,:)                   = FineGrid%h(1+GhostGridX,:);
      FineGrid%h(:,1)                   = FineGrid%h(:,1+GhostGridY);
      FineGrid%h(nx+2*GhostGridX,:)     = FineGrid%h(nx+GhostGridX,:);
      FineGrid%h(:,ny+2*GhostGridY)     = FineGrid%h(:,ny+GhostGridY)
      FineGrid%hx(1,:)                  = FineGrid%hx(1+GhostGridX,:);
      FineGrid%hx(:,1)                  = FineGrid%hx(:,1+GhostGridY);
      FineGrid%hx(nx+2*GhostGridX,:)    = FineGrid%hx(nx+GhostGridX,:);
      FineGrid%hx(:,ny+2*GhostGridY)    = FineGrid%hx(:,ny+GhostGridY)
      FineGrid%hxx(1,:)                 = FineGrid%hxx(1+GhostGridX,:);
      FineGrid%hxx(:,1)                 = FineGrid%hxx(:,1+GhostGridY);
      FineGrid%hxx(nx+2*GhostGridX,:)   = FineGrid%hxx(nx+GhostGridX,:);
      FineGrid%hxx(:,ny+2*GhostGridY)   = FineGrid%hxx(:,ny+GhostGridY)
      FineGrid%hy(1,:)                  = FineGrid%hy(1+GhostGridX,:);
      FineGrid%hy(:,1)                  = FineGrid%hy(:,1+GhostGridY);
      FineGrid%hy(nx+2*GhostGridX,:)    = FineGrid%hy(nx+GhostGridX,:);
      FineGrid%hy(:,ny+2*GhostGridY)    = FineGrid%hy(:,ny+GhostGridY)
      FineGrid%hyy(1,:)                 = FineGrid%hyy(1+GhostGridX,:);
      FineGrid%hyy(:,1)                 = FineGrid%hyy(:,1+GhostGridY);
      FineGrid%hyy(nx+2*GhostGridX,:)   = FineGrid%hyy(nx+GhostGridX,:);
      FineGrid%hyy(:,ny+2*GhostGridY)   = FineGrid%hyy(:,ny+GhostGridY)

     END IF
     !
     IF(swenseONOFF==1)THEN
        IF (LinearONOFF==0) THEN
           print*,'it should be a nonlinear case!'
           STOP
           ! Linear incident wavefield
           CALL incident_linear_wf_finite(swenseDir, Wavefield, & !ramp_type,&
                Nx+2*GhostGridX,FineGrid%x,Ny+2*GhostGridY,FineGrid%y,Nz+GhostGridz,FineGrid%z,  &
                FineGrid%h,zero,&
                SFsol%k,g,SFsol%HH,SFsol%h)
        ELSE
           ! Nonlinear incident wavefield
           ! Initialize stream function coefficients
           CALL stream_func_set_up(g,SFsol%h,SFsol%T,SFsol%i_wavel_or_per,SFsol%L,  &
                SFsol%k,SFsol%HH,SFsol%i_euler_or_stokes,SFsol%e_or_s_vel,SFsol%i_deep_or_finite,  &
                SFsol%n_h_steps,SFsol%n_four_modes,SFsol%nwrk,SFsol%yy,SFsol%zz)
           CALL incident_wf_finite(swenseDir, Wavefield, &
                Nx+2*GhostGridX,FineGrid%x,Ny+2*GhostGridY,FineGrid%y,Nz+GhostGridz,FineGrid%z,  &
                FineGrid%h,zero, &
                SFsol%k,g,SFsol%n_four_modes,SFsol%zz,SFsol%yy)
        ENDIF
     ENDIF
   CASE(16)

     !--------------------------------------------------------------------------
     ! Henrik Bredmose 2009 JFM paper setup.
     !--------------------------------------------------------------------------

     IF (Lz <= 0) THEN

      !-------------------------------------------------------------------------
      ! Read in the bottom contours from a file:
      !-------------------------------------------------------------------------
      OPEN(unit=fileip(4),file=fname_bottom,status='old')
      READ(fileip(4),'(A)')head(4)
      PRINT *, 'SetUpInitialConditions:  Reading the bottom contours from file:'
      PRINT *,fname_bottom,' with header:'
      PRINT *, head(4)
      PRINT *, ' '
      WRITE(FILEOP(1),*) 'SetUpInitialConditions:  Reading the bottom contours from file:'
      WRITE(FILEOP(1),*)fname_bottom,' with header:'
      WRITE(FILEOP(1),*) head(4)
      WRITE(FILEOP(1),*) ' '
      READ(fileip(4),*)  DetermineBottomGradients ! Read the gradient flag

      !-------------------------------------------------------------------------
      ! Read h(x,y),h_x,h_xx,h_y,h_yy
      !-------------------------------------------------------------------------
      Print *, ' Reading h,h_x,h_xx,h_y,h_yy.'
      print *, ' '
      write(fileop(1),*) ' Reading h,h_x,h_xx,h_y,h_yy.'
      write(fileop(1),*) ' '
      Do j=1+GhostGridY,ny+GhostGridY
        DO i=1+GhostGridX,nx+GhostGridX
          READ(fileip(4),*) FineGrid%h(i,j),    &
                            FineGrid%hx(i,j),   &
                            FineGrid%hxx(i,j),  &
                            FineGrid%hy(i,j),   &
                            FineGrid%hyy(i,j)
        END DO
      END DO

      !-------------------------------------------------------------------------
      ! Extend the bathymetry to the ghost points by copying the domain
      ! endpoint values.
      !-------------------------------------------------------------------------
      FineGrid%h(1,:)                   = FineGrid%h(1+GhostGridX,:);
      FineGrid%h(:,1)                   = FineGrid%h(:,1+GhostGridY);
      FineGrid%h(nx+2*GhostGridX,:)     = FineGrid%h(nx+GhostGridX,:);
      FineGrid%h(:,ny+2*GhostGridY)     = FineGrid%h(:,ny+GhostGridY)
      FineGrid%hx(1,:)                  = FineGrid%hx(1+GhostGridX,:);
      FineGrid%hx(:,1)                  = FineGrid%hx(:,1+GhostGridY);
      FineGrid%hx(nx+2*GhostGridX,:)    = FineGrid%hx(nx+GhostGridX,:);
      FineGrid%hx(:,ny+2*GhostGridY)    = FineGrid%hx(:,ny+GhostGridY)
      FineGrid%hxx(1,:)                 = FineGrid%hxx(1+GhostGridX,:);
      FineGrid%hxx(:,1)                 = FineGrid%hxx(:,1+GhostGridY);
      FineGrid%hxx(nx+2*GhostGridX,:)   = FineGrid%hxx(nx+GhostGridX,:);
      FineGrid%hxx(:,ny+2*GhostGridY)   = FineGrid%hxx(:,ny+GhostGridY)
      FineGrid%hy(1,:)                  = FineGrid%hy(1+GhostGridX,:);
      FineGrid%hy(:,1)                  = FineGrid%hy(:,1+GhostGridY);
      FineGrid%hy(nx+2*GhostGridX,:)    = FineGrid%hy(nx+GhostGridX,:);
      FineGrid%hy(:,ny+2*GhostGridY)    = FineGrid%hy(:,ny+GhostGridY)
      FineGrid%hyy(1,:)                 = FineGrid%hyy(1+GhostGridX,:);
      FineGrid%hyy(:,1)                 = FineGrid%hyy(:,1+GhostGridY);
      FineGrid%hyy(nx+2*GhostGridX,:)   = FineGrid%hyy(nx+GhostGridX,:);
      FineGrid%hyy(:,ny+2*GhostGridY)   = FineGrid%hyy(:,ny+GhostGridY)

      !-------------------------------------------------------------------------
      ! Re-set Lz to be max h(1,1)
      !-------------------------------------------------------------------------
      Lz=FineGrid%h(1,1)

    ELSE

      FineGrid%h      =   Lz;
      FineGrid%hx     =   zero;
      FineGrid%hxx    =   zero;
      FineGrid%hy     =   zero;
      FineGrid%hyy    =   zero;

    END IF

    !---------------------------------------------------------------------------
    ! Set initial surface elevation and free surface potential:
    !---------------------------------------------------------------------------
    CALL stream_func_set_up(g,SFsol%h,SFsol%T,SFsol%i_wavel_or_per,SFsol%L, &
                            SFsol%k,SFsol%HH,SFsol%i_euler_or_stokes,       &
                            SFsol%e_or_s_vel,SFsol%i_deep_or_finite,        &
                            SFsol%n_h_steps,SFsol%n_four_modes,SFsol%nwrk,  &
                            SFsol%yy,SFsol%zz)

    CALL incident_wf_finite(swenseDir, Wavefield,               &
                            Nx+2*GhostGridX,FineGrid%x,         &
                            Ny+2*GhostGridY,FineGrid%y,         &
                            Nz+GhostGridz  ,FineGrid%z,         &
                            FineGrid%h,zero,SFsol%k,g,          &
                            SFsol%n_four_modes,SFsol%zz,SFsol%yy)

    !---------------------------------------------------------------------------
    ! Modify the free surface elevation and the free surface potential by the
    ! envelope function sech(kx(x-x0)/4) = 1/cosh(kx(x-x0)/4):
    !---------------------------------------------------------------------------
    Wavefield%E = 1.0/COSH(SFsol%k*(FineGrid%x - 200.0)/4.0)*Wavefield%E_I
    Wavefield%P = 1.0/COSH(SFsol%k*(FineGrid%x - 200.0)/4.0)*Wavefield%P_I_s

    !---------------------------------------------------------------------------
    ! Calculate the derivatives of the initial condition numerically:
    !---------------------------------------------------------------------------
    CALL PreProcessDiffStencils(FineGrid,FineGrid%DiffStencils,GhostGridX,  &
    GhostGridY,GhostGridZ,alpha,beta,gamma,fileop(1))
    CALL DiffXEven(Wavefield%E,Wavefield%Ex,1,FineGrid%Nx,FineGrid%Ny,1,    &
    FineGrid%DiffStencils,alpha)
    CALL DiffXEven(Wavefield%E,Wavefield%Exx,2,                             &
    FineGrid%Nx,FineGrid%Ny,1,FineGrid%DiffStencils,alpha)
    CALL DiffXEven(Wavefield%P,Wavefield%Px,1,FineGrid%Nx,FineGrid%Ny,1,    &
    FineGrid%DiffStencils,alpha)
  !
  CASE (17) ! Vincent and Briggs(3D)
     CALL BottomVincent(FineGrid,GhostGridX,GhostGridY)
     DetermineBottomGradients = 1
  CASE DEFAULT
    PRINT * ,'Error: Specified initial conditions are not valid.'
    STOP
  END SELECT

  END SUBROUTINE SetupInitialConditions


      DOUBLE PRECISION FUNCTION DT_XMLMD(Ecm)

C***********************************************************************
C Diffractive mass in high mass single/double diffractive events.      *
C This version dated 11.02.95 is written by S. Roesler                 *
C***********************************************************************

      IMPLICIT NONE
      DOUBLE PRECISION a , amax , amo , amu , DT_RNDM , Ecm , r , sam
      SAVE

      INCLUDE 'inc/dtflka'

C minimum Pomeron-x for low-mass diffraction
C     AMO = 1.5D0
      amo = 2.0D0
C maximum Pomeron-x for low-mass diffraction
C (adjusted to get a smooth transition between HM and LM component)
      r = DT_RNDM(amo)
      sam = 1.0D0
      IF ( Ecm.LE.300.0D0 ) sam = 1.0D0 - EXP(-((Ecm/200.0D0)**4))
      r = DT_RNDM(amo)*sam
      amax = (1.0D0-sam)*SQRT(0.1D0*Ecm**2) + sam*SQRT(400.0D0)
      amu = r*SQRT(100.0D0) + (1.0D0-r)*amax

C selection of diffractive mass
C (adjusted to get a smooth transition between HM and LM component)
      r = DT_RNDM(amu)
      IF ( Ecm.LE.50.0D0 ) THEN
         DT_XMLMD = amo*(amu/amo)**r
      ELSE
         a = 0.7D0
         IF ( Ecm.LE.300.0D0 ) a = 0.7D0*(1.0D0-EXP(-((Ecm/100.0D0)**2))
     &        )
         DT_XMLMD = 1.0D0/((r/(amu**a)+(1.0D0-r)/(amo**a))**(1.0D0/a))
      END IF

      END FUNCTION


      subroutine flood(zslice, wet, dry, x, y, dmax,
     &                 flooded_zslice, im, jm, nbwet, nbdry)

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

      implicit none

!-----------------------------------------------------------------------
!
!     input arrays
!
!-----------------------------------------------------------------------

      integer, dimension(nbwet, 2), intent(in) :: wet

      integer, dimension(nbdry, 2), intent(in) :: dry

      real*8, dimension(im, jm), intent(in) :: zslice, x, y

!-----------------------------------------------------------------------
!
!     output variables
!
!-----------------------------------------------------------------------

      real*8, dimension(im, jm), intent(out) :: flooded_zslice

!-----------------------------------------------------------------------
!
!     local variables
!
!-----------------------------------------------------------------------

      integer :: im, jm, nbwet, nbdry, n, m, dmax
      integer :: idry, jdry, iwet, jwet, dmin_idx, iclose, jclose

      real*8, dimension(nbwet) :: d

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

      flooded_zslice = zslice

      ! loop over the dry point that need to be flooded
      do n=1,nbdry
        idry = dry(n,1)
        jdry = dry(n,2)
        ! compute wet point distance
        do m=1,nbwet
          iwet = wet(m,1)
          jwet = wet(m,2)
          d(m) = sqrt( (x(idry,jdry) - x(iwet,jwet)) *
     &                 (x(idry,jdry) - x(iwet,jwet))
     &               + (y(idry,jdry) - y(iwet,jwet)) *
     &                 (y(idry,jdry) - y(iwet,jwet)) )
        enddo
        dmin_idx = minloc(d,1)
        if (dmax .eq. 0) then
          iclose = wet(dmin_idx,1)
          jclose = wet(dmin_idx,2)
          flooded_zslice(idry,jdry) = zslice(iclose,jclose)
        else
          if (d(dmin_idx) < dmax) then
            iclose = wet(dmin_idx,1)
            jclose = wet(dmin_idx,2)
            flooded_zslice(idry,jdry) = zslice(iclose,jclose)
          endif
        endif

      enddo

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

      end subroutine flood

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


      SUBROUTINE IIRFIL(Y,DX,NPTS,IFL)

      INTEGER NPTS, IFL(5), IP, IPLTMP, I
      REAL DX, Y(NPTS)

!************************************************************************
!* Programmable, n-th order, Butterworth, low-pass, recursive,
!*  infinite impulse response, bidirectional digital filter.
!*  IIRFIL determines which filters (1-,2-,3-, or 4-pole) to
!*  call in order to produce the desired n-pole filter.
!*
!* Arguments:
!*  Y      = Data from channel
!*  DX     = Sampling period  (DELTAt)
!*  NPTS   = Number of data points
!*  IFL(1) = Cutoff frequency (3-dB down point)
!*  IFL(2) = Attenuation (dB) at stop band frequency
!*  IFL(3) = Direction of filtering:[1=Forward, 2=Backward,
!*           3=Phaseless (forward and backward)]
!*  IFL(4) = Stop band frequency (Fsb)
!*  IFL(5) = (not used)
!*
!* Restrictions:  (none)
!*
!* Language: Fortran
!*
!* Author: B. Stevens - Jul-1980
!*
!* Modification History:
!*   Ver/Ed    Date      Modification
!*   ------- ---------  ------------------------------------------------
!*    BMS01  19-Dec-80  Redefined IFILTR for stopband & attenuation
!*    BMS02  02-Feb-81  Rewritten for command driven program
!*    MRN01  23-Apr-85  Added display of filter coefficients
!*
!* Date: 1999/08/20
!************************************************************************
!
      DOUBLE PRECISION C, PI
!-----------------------------------------------------------------------
! These physical constants are defined with sufficient accuracy so
! that they may be declared DOUBLE PRECISION in the user program.
!
      PARAMETER (PI=3.141592653589793)
!  PARAMETER (E=2.718281828459045) !Base of natural log
!  PARAMETER (RTOD=57.2957795131)  !Radians to degrees
!  PARAMETER (G=32.1725)           !Gravity  (ft/sec**2)
!  PARAMETER (GSI=9.80665)         !Gravity  (m/sec**2)
!-----------------------------------------------------------------------
!  CHARACTER IMESG(3)*9
!  SAVE IMESG
!  DATA IMESG / 'FORWARD', 'BACKWARD', 'PHASELESS' /
!
!#######################################################################
!
! Convert from Fsb and attenuation to # of poles
!
      IP = INT( -IFL(2)/(20.0*LOG10(FLOAT(IFL(4))/IFL(1))) + 0.5 )
!
! Check for odd order & phaseless
!
      IF (IFL(3).EQ.3) IP = (IP+1)/2
      IF (IP.LE.0) THEN
        WRITE(*,35) 'Invalid number of poles',IP
   35   FORMAT(1X,10X,A,' : ',I2)
      ENDIF
!
! Now begin filtering
!
      C = DCOS(PI*IFL(1)*DX)/DSIN(PI*IFL(1)*DX)
      GOTO (10,20,30,40,50,60,70,80,90,100,110,120) IP
      GOTO 130

   10 CALL LP1(Y,C,NPTS,IFL)
      GOTO 150
   20 CALL LP2(Y,C,NPTS,IFL)
      GOTO 150
   30 CALL LP3(Y,C,NPTS,IFL)
      GOTO 150
   40 CALL LP4(Y,C,NPTS,IFL)
      GOTO 150
   50 CALL LP3(Y,C,NPTS,IFL)
      GOTO 20
   60 CALL LP3(Y,C,NPTS,IFL)
      GOTO 30
   70 CALL LP4(Y,C,NPTS,IFL)
      GOTO 30
   80 CALL LP4(Y,C,NPTS,IFL)
      GOTO 40
   90 CALL LP3(Y,C,NPTS,IFL)
      GOTO 60
  100 CALL LP4(Y,C,NPTS,IFL)
      GOTO 60
  110 CALL LP4(Y,C,NPTS,IFL)
      GOTO 70
  120 CALL LP4(Y,C,NPTS,IFL)
      GOTO 80
!
! Find # of 4-poles needed to implement specified filter
!
  130 IPLTMP = (IP-13)/4+1 ! IP > 12
      DO 140 I = 1, IPLTMP
        CALL LP4( Y, C, NPTS, IFL )
  140 CONTINUE
!
! Add the basic 9, 10, 11, or 12 pole filter
!
      IPLTMP = (IP-IPLTMP*4)-8
      GOTO (90,100,110,120) IPLTMP
!
! Print filter message and return
!
  150 IF (IFL(3).EQ.3)  IP = IP*2
!  WRITE(*,9000) IFL(1),IP,IMESG(IFL(3)),IFL(4),IFL(2)
!9000 FORMAT(' >Data filtered to'I5' Hz with a'I3' pole, '
!    &     A' filter' / '    Fsb ='I6', Att ='I4' dB')

      RETURN
      END

      SUBROUTINE LP1(Y,C,NPTS,IFL)

      INTEGER NPTS, IFL(5), I
      REAL Y(NPTS)
      DOUBLE PRECISION C

!*----------------------------------------------------------------------
!* 1st order Butterworth filter routine
!* Recursive,low-pass,IIR filter
!*
!* Normalized filter: 1/(1+p)
!*
!*----------------------------------------------------------------------

      DOUBLE PRECISION D,A0,A1,B1,X0,X1,Y0,Y1
!
!************************************************************************
!
   10 D = 1.0/(1.0+C)
      A0 = 1.0*D
      A1 = 1.0*D
      B1 = (1.0-C)*D
      !
      ! Backward filtering only?
      !
      IF (IFL(3).EQ.2)  GOTO 40
      !
      ! Forward filtering
      !
   20 X0 = Y(1)
      Y0 = Y(1)
      DO 30 I = 2, NPTS
        Y1 = Y0
        Y0 = Y(I)
        X1 = X0
        X0 = Y0
        Y0 = A0*X0+A1*X1-B1*Y1
        Y(I) = REAL( Y0 )
   30 CONTINUE
      !
      ! Forward filtering only?
      !
      IF (IFL(3).EQ.1)  RETURN
      !
      ! Backward filtering
      !
   40 X0 = Y(NPTS)
      Y0 = Y(NPTS)
      DO 50 I = (NPTS-1), 1, -1
        Y1 = Y0
        Y0 = Y(I)
        X1 = X0
        X0 = Y0
        Y0 = A0*X0+A1*X1-B1*Y1
        Y(I) = REAL( Y0 )
   50 CONTINUE

      RETURN
      END

      SUBROUTINE LP2(Y,C,NPTS,IFL)

      INTEGER NPTS, IFL(5), I
      REAL Y(NPTS)
      DOUBLE PRECISION C

!*----------------------------------------------------------------------
!* 2nd order Butterworth filter routine
!* Recursive,low-pass,IIR filter
!*
!* Normalized filter: 1/(1+SQRT(2)p+p**2)
!*
!*----------------------------------------------------------------------

      DOUBLE PRECISION D,A0,A1,A2,B1,B2
      DOUBLE PRECISION X0,X1,X2,Y0,Y1,Y2
!
!************************************************************************
!
   10 D = 1.0/(1.0+SQRT(2.0D0)*C+C**2)
      A0 = 1.0*D
      A1 = 2.0*D
      A2 = 1.0*D
      B1 = (2.0-2.0*C**2)*D
      B2 = (1.0D0-SQRT(2.0D0)*C+C**2)*D
      !
      ! Backward filtering only?
      !
      IF (IFL(3).EQ.2)  GOTO 40
      !
      ! Forward filtering
      !
   20 X1 = Y(1)
      X0 = Y(2)
      Y1 = Y(1)
      Y0 = Y(2)
      DO 30 I = 3, NPTS
        Y2 = Y1
        Y1 = Y0
        Y0 = Y(I)
        X2 = X1
        X1 = X0
        X0 = Y0
        Y0 = A0*X0+A1*X1+A2*X2-B1*Y1-B2*Y2
        Y(I) = REAL( Y0 )
   30 CONTINUE
      !
      ! Forward filtering only?
      !
      IF (IFL(3).EQ.1)  RETURN
      !
      ! Backward filtering
      !
   40 X1 = Y(NPTS)
      X0 = Y(NPTS-1)
      Y1 = Y(NPTS)
      Y0 = Y(NPTS-1)
      DO 50 I = (NPTS-2), 1, -1
        Y2 = Y1
        Y1 = Y0
        Y0 = Y(I)
        X2 = X1
        X1 = X0
        X0 = Y0
        Y0 = A0*X0+A1*X1+A2*X2-B1*Y1-B2*Y2
        Y(I) = REAL( Y0 )
   50 CONTINUE

      RETURN
      END

      SUBROUTINE LP3(Y,C,NPTS,IFL)

      INTEGER NPTS, IFL(5), I
      REAL Y(NPTS)
      DOUBLE PRECISION C

!*----------------------------------------------------------------------
!* 3rd order Butterworth filter routine
!* Recursive,low-pass,IIR filter
!*
!* Normalized filter: 1/(1+2p+2p**2+p**3)
!*
!*----------------------------------------------------------------------

      DOUBLE PRECISION D,A0,A1,A2,A3,B1,B2,B3
      DOUBLE PRECISION X0,X1,X2,X3,Y0,Y1,Y2,Y3
!
!************************************************************************
!
   10 D = 1.0/(1.0+2.0*C+2.0*C**2+C**3)
      A0 = 1.0*D
      A1 = 3.0*D
      A2 = 3.0*D
      A3 = 1.0*D
      B1 = (3.0+2.0*C-2.0*C**2-3.0*C**3)*D
      B2 = (3.0-2.0*C-2.0*C**2+3.0*C**3)*D
      B3 = (1.0-2.0*C+2.0*C**2-C**3)*D
      !
      ! Backward filtering only?
      !
      IF (IFL(3).EQ.2)  GOTO 40
      !
      ! Forward filtering
      !
   20 X2 = Y(1)
      X1 = Y(2)
      X0 = Y(3)
      Y2 = Y(1)
      Y1 = Y(2)
      Y0 = Y(3)
      DO 30 I = 4, NPTS
        Y3 = Y2
        Y2 = Y1
        Y1 = Y0
        Y0 = Y(I)
        X3 = X2
        X2 = X1
        X1 = X0
        X0 = Y0
        Y0 = A0*X0+A1*X1+A2*X2+A3*X3-B1*Y1-B2*Y2-B3*Y3
        Y(I) = REAL( Y0 )
   30 CONTINUE
      !
      ! Forward filtering only?
      !
      IF (IFL(3).EQ.1)  RETURN
      !
      ! Backward filtering
      !
   40 X2 = Y(NPTS)
      X1 = Y(NPTS-1)
      X0 = Y(NPTS-2)
      Y2 = Y(NPTS)
      Y1 = Y(NPTS-1)
      Y0 = Y(NPTS-2)
      DO 50 I = (NPTS-3), 1, -1
        Y3 = Y2
        Y2 = Y1
        Y1 = Y0
        Y0 = Y(I)
        X3 = X2
        X2 = X1
        X1 = X0
        X0 = Y0
        Y0 = A0*X0+A1*X1+A2*X2+A3*X3-B1*Y1-B2*Y2-B3*Y3
        Y(I) = REAL( Y0 )
   50 CONTINUE

      RETURN
      END

      SUBROUTINE LP4(Y,C,NPTS,IFL)

      INTEGER NPTS, IFL(5), I
      REAL Y(NPTS)
      DOUBLE PRECISION C

!*----------------------------------------------------------------------
!* 4th order Butterworth filter routine
!* Recursive,low-pass,IIR filter
!*
!* Normalized filter: 1/(1+2.6p+3.4p**2+2.6p**3+p**4)
!*
!*----------------------------------------------------------------------

      DOUBLE PRECISION E1,E2,D,A0,A1,A2,A3,A4
      DOUBLE PRECISION B1,B2,B3,B4,X4,X3,X2,X1,X0
      DOUBLE PRECISION Y0,Y1,Y2,Y3,Y4
!
!************************************************************************
!
   10 E1 = 2.6131259D0
      E2 = 3.4142136D0
      D = 1.0/(1.0+E1*C+E2*C**2+E1*C**3+C**4)
      A0 = 1.0*D
      A1 = 4.0*D
      A2 = 6.0*D
      A3 = 4.0*D
      A4 = 1.0*D
      B1 = (4.0+2.0*E1*C-2.0*E1*C**3-4.0*C**4)*D
      B2 = (6.0-2.0*E2*C**2+6.*C**4)*D
      B3 = (4.0-2.0*E1*C+2.0*E1*C**3-4.0*C**4)*D
      B4 = (1.0-E1*C+E2*C**2-E1*C**3+C**4)*D
      !
      ! Backward filtering only?
      !
      IF (IFL(3).EQ.2)  GOTO 40
      !
      ! Forward filtering
      !
   20 X3 = Y(1)
      X2 = Y(2)
      X1 = Y(3)
      X0 = Y(4)
      Y3 = Y(1)
      Y2 = Y(2)
      Y1 = Y(3)
      Y0 = Y(4)
      DO 30 I = 5, NPTS
        Y4 = Y3
        Y3 = Y2
        Y2 = Y1
        Y1 = Y0
        Y0 = Y(I)
        X4 = X3
        X3 = X2
        X2 = X1
        X1 = X0
        X0 = Y0
        Y0 = A0*X0+A1*X1+A2*X2+A3*X3+A4*X4-B1*Y1-B2*Y2-B3*Y3-B4*Y4
        Y(I) = REAL( Y0 )
   30 CONTINUE
      !
      ! Forward filtering only?
      !
      IF (IFL(3).EQ.1)  RETURN
      !
      ! Backward filtering
      !
   40 X3 = Y(NPTS)
      X2 = Y(NPTS-1)
      X1 = Y(NPTS-2)
      X0 = Y(NPTS-3)
      Y3 = Y(NPTS)
      Y2 = Y(NPTS-1)
      Y1 = Y(NPTS-2)
      Y0 = Y(NPTS-3)
      DO 50 I = (NPTS-4), 1, -1
        Y4 = Y3
        Y3 = Y2
        Y2 = Y1
        Y1 = Y0
        Y0 = Y(I)
        X4 = X3
        X3 = X2
        X2 = X1
        X1 = X0
        X0 = Y0
        Y0 = A0*X0+A1*X1+A2*X2+A3*X3+A4*X4-B1*Y1-B2*Y2-B3*Y3-B4*Y4
        Y(I) = REAL( Y0 )
   50 CONTINUE

      RETURN
      END


C   IMSL ROUTINE NAME   - VBLA=SNRM2                                    VBSH0010
C                                                                       VBSH0020
C-----------------------------------------------------------------------VBSH0030
C                                                                       VBSH0040
C   COMPUTER            - VAX/SINGLE                                    VBSH0050
C                                                                       VBSH0060
C   LATEST REVISION     - JANUARY 1, 1978                               VBSH0070
C                                                                       VBSH0080
C   PURPOSE             - COMPUTE THE EUCLIDEAN LENGTH OR L2 NORM       VBSH0090
C                           OF A SINGLE PRECISION VECTOR                VBSH0100
C                                                                       VBSH0110
C   USAGE               - FUNCTION SNRM2 (N,SX,INCX)                    VBSH0120
C                                                                       VBSH0130
C   ARGUMENTS    SNRM2  - SQUARE ROOT OF THE SUM FROM I=1 TO N OF       VBSH0140
C                           X(I)**2. (OUTPUT)                           VBSH0150
C                           X(I) REFERS TO A SPECIFIC ELEMENT OF SX.    VBSH0160
C                           SEE INCX ARGUMENT DESCRIPTION.              VBSH0170
C                N      - LENGTH OF VECTOR X. (INPUT)                   VBSH0180
C                SX     - REAL VECTOR OF LENGTH N*INCX. (INPUT)         VBSH0190
C                INCX   - DISPLACEMENT BETWEEN ELEMENTS OF SX. (INPUT)  VBSH0200
C                           X(I) IS DEFINED TO BE SX(1+(I-1)*INCX).     VBSH0210
C                           INCX MUST BE GREATER THAN ZERO.             VBSH0220
C                                                                       VBSH0230
C   PRECISION/HARDWARE  - SINGLE/ALL                                    VBSH0240
C                                                                       VBSH0250
C   REQD. IMSL ROUTINES - NONE REQUIRED                                 VBSH0260
C                                                                       VBSH0270
C   NOTATION            - INFORMATION ON SPECIAL NOTATION AND           VBSH0280
C                           CONVENTIONS IS AVAILABLE IN THE MANUAL      VBSH0290
C                           INTRODUCTION OR THROUGH IMSL ROUTINE UHELP  VBSH0300
C                                                                       VBSH0310
C   COPYRIGHT           - 1978 BY IMSL, INC. ALL RIGHTS RESERVED.       VBSH0320
C                                                                       VBSH0330
C   WARRANTY            - IMSL WARRANTS ONLY THAT IMSL TESTING HAS BEEN VBSH0340
C                           APPLIED TO THIS CODE. NO OTHER WARRANTY,    VBSH0350
C                           EXPRESSED OR IMPLIED, IS APPLICABLE.        VBSH0360
C                                                                       VBSH0370
C-----------------------------------------------------------------------VBSH0380
C                                                                       VBSH0390
      REAL FUNCTION SNRM2 (N,SX,INCX)                                   VBSH0400
C                                  SPECIFICATIONS FOR ARGUMENTS         VBSH0410
      INTEGER            N,INCX                                         VBSH0420
      REAL               SX(1)                                          VBSH0430
C                                  SPECIFICATIONS FOR LOCAL VARIABLES   VBSH0440
      INTEGER            I,J,NEXT,NN                                    VBSH0450
      REAL               CUTLO,CUTHI,HITEST,SUM,XMAX,ZERO,ONE           VBSH0460
      DATA               ZERO, ONE /0.0E0, 1.0E0/                       VBSH0470
      DATA               CUTLO, CUTHI / 4.441E-16,  1.304E19/           VBSH0480
C                                  FIRST EXECUTABLE STATEMENT           VBSH0490
C                                                                       VBSH0500
      IF (N.GT.0) GO TO 5                                               VBSH0510
      SNRM2 = ZERO                                                      VBSH0520
      GO TO 70                                                          VBSH0530
C                                                                       VBSH0540
    5 ASSIGN 15 TO NEXT                                                 VBSH0550
      SUM = ZERO                                                        VBSH0560
      NN = N*INCX                                                       VBSH0570
C                                  BEGIN MAIN LOOP                      VBSH0580
      I = 1                                                             VBSH0590
   10 GO TO NEXT, (15,20,35,40)                                         VBSH0600
   15 IF (ABS(SX(I)).GT.CUTLO) GO TO 55                                 VBSH0610
      ASSIGN 20 TO NEXT                                                 VBSH0620
      XMAX = ZERO                                                       VBSH0630
C                                  PHASE 1. SUM IS ZERO                 VBSH0640
   20 IF (SX(I).EQ.ZERO) GO TO 65                                       VBSH0650
      IF (ABS(SX(I)).GT.CUTLO) GO TO 55                                 VBSH0660
C                                  PREPARE FOR PHASE 2.                 VBSH0670
      ASSIGN 35 TO NEXT                                                 VBSH0680
      GO TO 30                                                          VBSH0690
C                                  PREPARE FOR PHASE 4.                 VBSH0700
   25 I = J                                                             VBSH0710
      ASSIGN 40 TO NEXT                                                 VBSH0720
      SUM = (SUM/SX(I))/SX(I)                                           VBSH0730
   30 XMAX = ABS(SX(I))                                                 VBSH0740
      GO TO 45                                                          VBSH0750
C                                  PHASE 2. SUM IS SMALL. SCALE TO      VBSH0760
C                                    AVOID DESTRUCTIVE UNDERFLOW.       VBSH0770
   35 IF (ABS(SX(I)).GT.CUTLO) GO TO 50                                 VBSH0780
C                                  COMMON CODE FOR PHASES 2 AND 4. IN   VBSH0790
C                                    PHASE 4 SUM IS LARGE. SCALE TO     VBSH0800
C                                    AVOID OVERFLOW.                    VBSH0810
   40 IF (ABS(SX(I)).LE.XMAX) GO TO 45                                  VBSH0820
      SUM = ONE+SUM*(XMAX/SX(I))**2                                     VBSH0830
      XMAX = ABS(SX(I))                                                 VBSH0840
      GO TO 65                                                          VBSH0850
C                                                                       VBSH0860
   45 SUM = SUM+(SX(I)/XMAX)**2                                         VBSH0870
      GO TO 65                                                          VBSH0880
C                                  PREPARE FOR PHASE 3.                 VBSH0890
   50 SUM = (SUM*XMAX)*XMAX                                             VBSH0900
C                                  FOR REAL OR D.P. SET HITEST =        VBSH0910
C                                    CUTHI/N FOR COMPLEX SET HITEST =   VBSH0920
C                                    CUTHI/(2*N)                        VBSH0930
   55 HITEST = CUTHI/FLOAT(N)                                           VBSH0940
C                                  PHASE 3. SUM IS MID-RANGE. NO        VBSH0950
C                                    SCALING.                           VBSH0960
      DO 60 J=I,NN,INCX                                                 VBSH0970
         IF (ABS(SX(J)).GE.HITEST) GO TO 25                             VBSH0980
   60 SUM = SUM+SX(J)**2                                                VBSH0990
      SNRM2 = SQRT(SUM)                                                 VBSH1000
      GO TO 70                                                          VBSH1010
C                                                                       VBSH1020
   65 CONTINUE                                                          VBSH1030
      I = I+INCX                                                        VBSH1040
      IF (I.LE.NN) GO TO 10                                             VBSH1050
C                                  END OF MAIN LOOP. COMPUTE SQUARE     VBSH1060
C                                    ROOT AND ADJUST FOR SCALING.       VBSH1070
      SNRM2 = XMAX*SQRT(SUM)                                            VBSH1080
   70 CONTINUE                                                          VBSH1090
      RETURN                                                            VBSH1100
      END                                                               VBSH1110


PROGRAM RUN_LANCELOT_simple

!-----------------------------------------------------------------------------
!                                                                            !
!    This programs provides a simple (naive) way to run LANCELOT B on an     !
!    optimization problem without interaction with CUTEr and using a simple  !
!    representation of the problem where the objective function and          !
!    constraints comprise each a single group with a single nonlinear        !
!    element.                                                                !
!                                                                            !
!    The use of this program and the accompanying script lanb_simple         !
!    requires that the GALAHAD package has prealably be installed.           !
!                                                                            !
!    Ph. L. Toint, November 2007.                                            !
!    Copyright reserved, Gould/Orban/Toint, for GALAHAD productions          !
!                                                                            !
!-----------------------------------------------------------------------------
!
    USE LANCELOT_simple_double
!
    IMPLICIT NONE
    INTEGER, PARAMETER :: wp = KIND( 1.0D+0 ) ! set precision
    REAL ( KIND = wp ), PARAMETER :: infinity = 10.0_wp ** 20
    INTEGER :: n, neq, nin, iters, maxit, print_level, exit_code
    REAL ( KIND = wp ) :: gradtol, feastol, fx
    CHARACTER ( LEN = 10 ), ALLOCATABLE, DIMENSION(:) :: VNAMES, CNAMES
    REAL ( KIND = wp ),     ALLOCATABLE, DIMENSION(:) :: BL, BU, X, CX, Y
    EXTERNAL :: FUN, GRAD, HESS
!
! THE TEST PROBLEM DIMENSIONS (user defined)
!
    n   = 2  ! number of variables
    neq = 1  ! number of equality constraints, excluding fixed variables
    nin = 1  ! number of inequality (<= 0) constraints, excluding bounds
!
! allocate space for problem defining vectors
!
    ALLOCATE( X( n  ), BL( n ), BU( n ), CX( neq+nin ), Y( neq+nin ) )
    ALLOCATE( VNAMES( n  ),CNAMES( neq+nin ) )
!
! starting point
!
    X(1) = -1.2_wp                 ! starting point (componentwise)
    X(2) =  1.0_wp
!
! bounds on the variables
!
    BL(1) =  0.0_wp                ! lower bounds (componentwise)
    BL(2) = -infinity
    BU(1) =  infinity              ! upper bounds (componentwise)
    BU(2) =  3.0_wp
!
! names
!
    VNAMES(1) = 'x1'               ! variables
    VNAMES(2) = 'x2'
    CNAMES(1) = 'Equality'         ! equality constraints
    CNAMES(2) = 'Inequality'       ! inequality constraints
!
! algorithmic parameters
!
    maxit       = 100
    gradtol     = 0.00001_wp       ! identical to default
    feastol     = 0.00001_wp       ! identical to default
    print_level = 1                ! identical to default
!
! solve by calling LANCELOT B
!
    CALL LANCELOT_simple( n,  X, fx, exit_code,                          &
                          MY_FUN = FUN, MY_GRAD = GRAD , MY_HESS = HESS, &
                          BL = BL, BU = BU, VNAMES   =  VNAMES,          &
                          CNAMES =  CNAMES, neq = neq, nin = nin,        &
                          CX = CX, Y = Y, ITERS  = iters, MAXIT = maxit, &
                          GRADTOL = gradtol, FEASTOL = feastol,          &
                          PRINT_LEVEL = print_level )
!
! clean up
!
    DEALLOCATE( X, BL, BU, CX, Y )
    DEALLOCATE( VNAMES, CNAMES )
    STOP
!
END PROGRAM RUN_LANCELOT_simple
!
!.............................................................................
    SUBROUTINE FUN ( X, F, i )
!.............................................................................
    INTEGER, PARAMETER :: wp = KIND( 1.0D+0 ) ! set precision
    REAL( KIND = wp ), INTENT( IN )   :: X( : )
    REAL( KIND = wp ), INTENT( OUT )  :: F
    INTEGER, INTENT( IN ), OPTIONAL   :: i
    IF ( .NOT. PRESENT( i ) ) THEN
!       the objective function value (user defined)
!==============================================================================
        F = 100.0_wp*(X(2)-X(1)**2)**2 +(1.0_wp-X(1))**2                      !
!==============================================================================
     ELSE
        SELECT CASE ( i )
            CASE ( 1 )
!               the equality constraint value (user defined)
!==============================================================================
                F = X(1)+3.0_wp*X(2)-3.0_wp                                   !
!==============================================================================
            CASE ( 2 )
!               the inequality constraint value (user defined)
!==============================================================================
                F = X(1)**2+X(2)**2-4.0_wp                                    !
!==============================================================================
        END SELECT
     END IF
     RETURN
    END SUBROUTINE FUN
!
!.............................................................................
    SUBROUTINE GRAD( X, G, i )
!.............................................................................
    INTEGER, PARAMETER :: wp = KIND( 1.0D+0 ) ! set precision
    REAL( KIND = wp ), INTENT( IN )  :: X( : )
    REAL( KIND = wp ), INTENT( OUT ) :: G( : )
    INTEGER, INTENT( IN ), OPTIONAL  :: i
    IF ( .NOT. PRESENT( i ) ) THEN
!       the objective functions's gradient components (user defined)
!==============================================================================
        G( 1 ) = -400.0_wp*(X(2)-X(1)**2)*X(1)-2.0_wp*(1.0_wp-X(1))           !
        G( 2 ) =  200.0_wp*(X(2)-X(1)**2)                                     !
!==============================================================================
    ELSE
        SELECT CASE ( i )
            CASE ( 1 )
!               the equality constraint's gradient components (user defined)
!==============================================================================
                G( 1 ) =  1.0_wp                                              !
                G( 2 ) =  3.0_wp                                              !
!==============================================================================
            CASE ( 2 )
!               the inequality constraint's gradient components (user defined)
!==============================================================================
                G( 1 ) =  2.0_wp*X(1)                                         !
                G( 2 ) =  2.0_wp*X(2)                                         !
!==============================================================================
        END SELECT
    END IF
    RETURN
    END SUBROUTINE GRAD
!
!.............................................................................
    SUBROUTINE HESS( X, H, i )
!.............................................................................
    INTEGER, PARAMETER :: wp = KIND( 1.0D+0 ) ! set precision
    REAL( KIND = wp ), INTENT( IN )  :: X( : )
    REAL( KIND = wp ), INTENT( OUT ) :: H( : )
    INTEGER, INTENT( IN ), OPTIONAL  :: i
    IF ( .NOT. PRESENT( i ) ) THEN
!       the entries of the upper triangle of the objective function's
!       Hessian  matrix,  stored by columns  (user defined)
!==============================================================================
        H( 1 ) = -400.0_wp*(X(2)-3.0_wp*X(1)**2)+2.0_wp                       !
        H( 2 ) = -400.0_wp*X(1)                                               !
        H( 3 ) =  200.0_wp                                                    !
!==============================================================================
    ELSE
        SELECT CASE ( i )
            CASE ( 1 )
!               the entries of the upper triangle of the equality
!               constraint's Hessian matrix, stored by columns (user defined)
!==============================================================================
                H( 1 ) = 0.0_wp                                               !
                H( 2 ) = 0.0_wp                                               !
                H( 3 ) = 0.0_wp                                               !
!==============================================================================
            CASE ( 2 )
!               the entries of the upper triangle of the inequality
!               constraint's Hessian matrix, stored by columns (user defined)
!==============================================================================
                H( 1 ) = 2.0_wp                                               !
                H( 2 ) = 0.0_wp                                               !
                H( 3 ) = 2.0_wp                                               !
!==============================================================================
        END SELECT
    END IF
    RETURN
    END SUBROUTINE HESS
!
!.............................................................................


      program testMVM

      parameter (n = 2)
      double precision :: A(n,n)
      double precision :: x(n)
      double precision :: y(n)
      double precision :: alpha, beta

      open (unit=1, file='A.data', form='unformatted',
     $      access='direct', recl=n*n*8)
      read (1, rec=1) A
      close (1)

      open (unit=1, file='x.data', form='unformatted',
     $      access='direct', recl=n*8)
      read (1, rec=1) x
      close (1)

      do i = 1,n
         y(i) = 0.0D0
      end do

      call MVM(A, x, y, n)

      print *, "y"
      print *, y(1)
      print *, y(2)

      end program


c=======================================================================
c=======================================================================
c     SUBROUTINES FOR HIDDEN MARKOV MODELS
c
c      Alejandro Jara
c      Department of Statistics
c      Facultad de Matematicas
c      Pontificia Universidad Catolica de Chile
c      Casilla 306, Correo 22
c      Santiago
c      Chile
c      Voice: +56-2-3544506  URL  : http://www.mat.puc.cl/~ajara
c      Fax  : +56-2-3547729  Email: atjara@uc.cl
c
c=======================================================================
c=======================================================================

c=======================================================================
      subroutine hmm_sim1(maxm,n,maxnsi,alpha,linf,lsup,u,v,w,workv,
     &                    theta,y)
c=======================================================================
c     Subroutine to gererate n samples from a DP(alpha U(linf,lsup)
c     prior in a Semiparametric HMM.
c
c     A.J.V. 2008
c=======================================================================
      implicit none

c+++++Input
      integer maxm,n,maxnsi
      real*8 alpha,linf,lsup

c+++++External working space
      real*8 theta(maxm)
      real*8 v(maxm),w(maxm),workv(maxm+1)
      real*8 u(maxnsi)

c+++++Output
      real*8 y(maxnsi)

c+++++Internal working space
      integer i,i1,mrand,ok
      real*8 mass,maxu
      real*8 tmp1,tmp2
      real runif

      if(lsup.le.linf)then
         call rexit("Errors in limits in 'hmm_sim1'")
      end if

      mass=alpha*(lsup-linf)

      maxu=0.d0
      do i=1,n
         u(i)=dble(runif())
         if(u(i).gt.maxu)maxu=u(i)
      end do

      tmp1=0.d0
      tmp2=0.d0

      mrand=10
      call hmm_dpsim(0,maxm,mrand,mass,workv,w,v,tmp2,tmp1)

      do while(maxu.ge.tmp2.and.mrand.lt.maxm)
         mrand=mrand+1
         if(mrand.gt.maxm)then
            call rexit("Increase maxn in 'DPhmm.f'")
         end if
         call hmm_dpsim(mrand-1,maxm,mrand,mass,workv,w,v,tmp2,tmp1)
      end do

      do i=1,mrand
         theta(i)=linf+(lsup-linf)*dble(runif())
      end do

      do i=1,n
         i1=0
         tmp1=0.d0
         ok=1
         do while(ok.eq.1.and.i1.lt.mrand)
            i1=i1+1
            tmp1=tmp1+w(i1)
            if(u(i).lt.tmp1)then
               ok=0
            end if
         end do
         y(i)=theta(i1)
      end do

      return
      end

c=======================================================================
      subroutine hmm_sim2(maxm,n,nso,maxnsi,alpha,linf,lsup,u,v,w,workv,
     &                    theta,yo,y)
c=======================================================================
c     Subroutine to gererate n samples from a DP(alpha U(linf,lsup)
c     prior in a Semiparametric HMM.
c
c     A.J.V. 2008
c=======================================================================
      implicit none

c+++++Input
      integer maxm,n,nso,maxnsi
      real*8 alpha,linf,lsup

c+++++External working space
      real*8 theta(maxm)
      real*8 v(maxm),w(maxm),workv(maxm+1)
      real*8 u(maxnsi)
      real*8 yo(maxnsi)

c+++++Output
      real*8 y(maxnsi)

c+++++Internal working space
      integer i,i1,mrand,ok
      real*8 mass,mass2,maxu
      real*8 tmp1,tmp2
      real runif

      if(lsup.le.linf)then
         call rexit("Errors in limits in 'hmm_sim1'")
      end if

      mass=(alpha+dble(nso))*(lsup-linf)
      mass2=(alpha+dble(nso))

      maxu=0.d0
      do i=1,n
         u(i)=dble(runif())
         if(u(i).gt.maxu)maxu=u(i)
      end do

      tmp1=0.d0
      tmp2=0.d0

      mrand=10
      call hmm_dpsim(0,maxm,mrand,mass,workv,w,v,tmp2,tmp1)

      do while(maxu.ge.tmp2)
         mrand=mrand+1
         if(mrand.gt.maxm)then
            call rexit("Increase maxn in 'DPhmm.f'")
         end if
         call hmm_dpsim(mrand-1,maxm,mrand,mass,workv,w,v,tmp2,tmp1)
      end do

      do i=1,mrand
         if(dble(runif()).le.(1.d0-(alpha/mass2)))then
            call rdisc(1,nso,i1)
            theta(i)=yo(i1)
           else
            theta(i)=linf+(lsup-linf)*dble(runif())
         end if
      end do

      do i=1,n
         i1=0
         tmp1=0.d0
         ok=1
         do while(ok.eq.1.and.i1.lt.mrand)
            i1=i1+1
            tmp1=tmp1+w(i1)
            if(u(i).lt.tmp1)then
               ok=0
            end if
         end do
         y(i)=theta(i1)
      end do

      return
      end

c=======================================================================
      subroutine hmm_dpsim(indi,nr,n,alpha,workv,w,v,accsum,accsumw)
c=======================================================================
c     Subroutine to compute the stick breaking weights up to
c     finite level n.
c
c     A.J.V. 2007
c=======================================================================
      implicit none

c+++++Input
      integer indi,nr,n
      real*8 alpha

c+++++Output
      real*8 accsum,accsumw
      real*8 v(nr),w(nr),workv(nr+1)

c+++++Internal working space
      integer i
      real*8 rbeta
      real*8 tmp1

c+++++Algorihtm

      workv(1)=0.d0
      do i=(indi+1),n
         v(i)=rbeta(1.0d0,alpha)
         tmp1=1.d0-v(i)
         accsumw=accsumw-dlog(tmp1)
         workv(i+1)=accsumw
      end do
      workv(n+1)=1.0D300

      do i=(indi+1),n
         if(i.lt.n)then
            w(i)=dexp(-workv(i))-dexp(-workv(i+1))
          else
            w(i)=dexp(-workv(i)+dlog(v(n)))-dexp(-workv(i+1))
         end if
         accsum=accsum+w(i)
      end do
      workv(n+1)=accsumw

      return
      end

c=======================================================================
      subroutine hmm_zassign(nrec,z,maxint,npoints,endp,countv1,countv2,
     &                       countm1,countm2,kk,kkc,zindi,maxkk,probbig,
     &                       maxnsi,countiv,countim)
c=======================================================================
c     Subroutine to the z's to the corresponding intervals and does the
c     counting in a Semiparametric HMM.
c
c     A.J.V. 2008
c=======================================================================
      implicit none

c+++++Input
      integer nrec,maxint,maxkk,maxnsi,npoints
      integer kk,kkc
      integer countv1(maxkk),countv2(maxkk)
      integer countm1(maxkk,maxint),countm2(maxkk,maxint)
      integer countiv(maxkk*maxint),countim(maxkk*maxint,maxnsi)
      real*8 endp(maxint),z(nrec)

c+++++Output
      integer zindi(nrec)
      real*8 probbig(maxkk,maxint)

c+++++Internal working space
      integer i,iceil,j,k,l,ll,ok
      integer k1,k2

c+++++Body

      l=0
      do i=1,nrec
         zindi(i)=0
         if(kk.gt.kkc)then
            j=iceil(z(i)*kk)
            k=1
            ok=0
            do while(k.le.countv1(j).and.ok.eq.0)
               ll=countm1(j,k)
               if(z(i).le.endp(ll))then
                  ok=1
                  l=ll
               end if
               k=k+1
            end do
            zindi(i)=l

          else

            j=iceil(z(i)*kkc)
            k=1
            ok=0
            do while(k.le.countv2(j).and.ok.eq.0)
               ll=countm2(j,k)
               if(z(i).le.endp(ll))then
                  ok=1
                  l=ll
               end if
               k=k+1
            end do
            zindi(i)=l

         end if

         if(zindi(i).gt.(npoints+1).or.zindi(i).lt.1)then
            call intpr("zindi(i)",-1,zindi(i),1)
            call rexit("Error in interval assignment")
         end if

         if(i.gt.1)then
            k1=iceil(z(i-1)*kk)
            k2=zindi(i)

            probbig(k1,k2)=probbig(k1,k2)+1.d0

            k=(k1-1)*maxint+k2

            if(k.gt.(maxint*maxkk).or.k.lt.1)then
               call intpr("k",-1,k,1)
               call rexit("Error in interval assignment")
            end if

            countiv(k)=countiv(k)+1

            if(countiv(k).gt.maxnsi)then
               call intpr("maxnsi",-1,maxnsi,1)
               call intpr("countiv(k)",-1,countiv(k),1)
               call rexit("Increase maxnsi in 'dphmm.f'")
            end if
            countim(k,countiv(k))=i
         end if

      end do
      return
      end

c=======================================================================
      subroutine hmm_part(kk,kkc,maxkk,maxint,countv1,countv2,
     &                    countm1,countm2,npoints,endp,intprob)
c=======================================================================
c     Subroutine to the partition intervals in a Semiparametric HMM.
c
c     A.J.V. 2008
c=======================================================================
      implicit none

c+++++Input
      integer kk,kkc

c+++++External working space
      integer maxkk,maxint

c+++++Output
      integer npoints
      real*8 endp(maxint)
      integer countv1(maxkk),countv2(maxkk)
      integer countm1(maxkk,maxint),countm2(maxkk,maxint)
      integer intprob(maxint,2)

c+++++Internal working space
      integer count,count1,count2,countc
      integer i,j,ok,okc
      integer iceil
      real*8 tmp1,tmp2

c+++++Body

      do i=1,maxkk
         countv1(i)=0
         countv2(i)=0
      end do

      do i=1,maxint
         endp(i)=0.d0
      end do

      count=0
      count1=1
      count2=1
      tmp1=0.d0
      tmp2=0.d0
      ok=0

      if(mod(kk,kkc).eq.0)then

         if(maxint.lt.kk)then
            call rexit("Error in the maximum number of intervals")
         end if

         do i=1,kk
            endp(i)=i/dble(kk)

            j=iceil(endp(i)*kk)
            intprob(i,1)=j
            countv1(j)=countv1(j)+1
            countm1(j,countv1(j))=i

            j=iceil(endp(i)*kkc)
            intprob(i,2)=j
            countv2(j)=countv2(j)+1
            countm2(j,countv2(j))=i

         end do
         npoints=kk-1

       else if(mod(kkc,kk).eq.0)then

         if(maxint.lt.kkc)then
            call rexit("Error in the maximum number of intervals")
         end if

         do i=1,kkc
            endp(i)=i/dble(kkc)

            j=iceil(endp(i)*kk)
            intprob(i,1)=j
            countv1(j)=countv1(j)+1
            countm1(j,countv1(j))=i

            j=iceil(endp(i)*kkc)
            intprob(i,2)=j
            countv2(j)=countv2(j)+1
            countm2(j,countv2(j))=i

         end do
         npoints=kkc-1
       else
         do while(ok.eq.0)
            tmp1=count1/dble(kk)
            tmp2=count2/dble(kkc)

            if(tmp2.lt.tmp1)then
               count=count+1
               if(maxint.lt.(count+1))then
                 call rexit("Error in the maximum number of intervals")
               end if

               endp(count)=tmp2

               j=iceil(endp(count)*kk)
               intprob(count,1)=j
               countv1(j)=countv1(j)+1
               countm1(j,countv1(j))=count

               j=iceil(endp(count)*kkc)
               intprob(count,2)=j
               countv2(j)=countv2(j)+1
               countm2(j,countv2(j))=count

               okc=0
               countc=count2
               do while(okc.eq.0)
                  countc=countc+1
                  tmp2=countc/dble(kkc)
                  if(tmp2.lt.tmp1)then
                     count2=count2+1
                     count=count+1
                     if(maxint.lt.(count+1))then
                       call rexit("Error maximum number of intervals")
                     end if

                     endp(count)=tmp2

                     j=iceil(endp(count)*kk)
                     intprob(count,1)=j
                     countv1(j)=countv1(j)+1
                     countm1(j,countv1(j))=count

                     j=iceil(endp(count)*kkc)
                     intprob(count,2)=j
                     countv2(j)=countv2(j)+1
                     countm2(j,countv2(j))=count

                   else
                     okc=1
                     count=count+1
                     if(maxint.lt.(count+1))then
                       call rexit("Error maximum number of intervals")
                     end if

                     endp(count)=tmp1

                     j=iceil(endp(count)*kk)
                     intprob(count,1)=j
                     countv1(j)=countv1(j)+1
                     countm1(j,countv1(j))=count

                     j=iceil(endp(count)*kkc)
                     intprob(count,2)=j
                     countv2(j)=countv2(j)+1
                     countm2(j,countv2(j))=count

                     count1=count1+1
                     count2=countc
                  end if
               end do
             else if(tmp1.lt.tmp2)then

               count=count+1
               if(maxint.lt.(count+1))then
                  call rexit("Error maximum number of intervals")
               end if

               endp(count)=tmp1

               j=iceil(endp(count)*kk)
               intprob(count,1)=j
               countv1(j)=countv1(j)+1
               countm1(j,countv1(j))=count

               j=iceil(endp(count)*kkc)
               intprob(count,2)=j
               countv2(j)=countv2(j)+1
               countm2(j,countv2(j))=count

               okc=0
               countc=count1
               do while(okc.eq.0)
                  countc=countc+1
                  tmp1=countc/dble(kk)
                  if(tmp1.lt.tmp2)then
                     count1=count1+1
                     count=count+1
                     if(maxint.lt.(count+1))then
                       call rexit("Error maximum number of intervals")
                     end if

                     endp(count)=tmp1

                     j=iceil(endp(count)*kk)
                     intprob(count,1)=j
                     countv1(j)=countv1(j)+1
                     countm1(j,countv1(j))=count

                     j=iceil(endp(count)*kkc)
                     intprob(count,2)=j
                     countv2(j)=countv2(j)+1
                     countm2(j,countv2(j))=count

                   else

                     okc=1
                     count=count+1
                     if(maxint.lt.(count+1))then
                       call rexit("Error maximum number of intervals")
                     end if

                     endp(count)=tmp2

                     j=iceil(endp(count)*kk)
                     intprob(count,1)=j
                     countv1(j)=countv1(j)+1
                     countm1(j,countv1(j))=count

                     j=iceil(endp(count)*kkc)
                     intprob(count,2)=j
                     countv2(j)=countv2(j)+1
                     countm2(j,countv2(j))=count

                     count2=count2+1
                     count1=countc
                  end if
               end do
            end if

            if(count1.ge.kk.and.count2.ge.kkc)ok=1
         end do
         npoints=count-1

      end if

      return
      end


    ! program demo_lbound
    module m_bounds
    implicit none
     contains
        subroutine msub(arr)
           !!integer,intent(in) :: arr(*)  ! cannot be assumed-size array
           integer,intent(in) :: arr(:)
           write(*,*)'MSUB: LOWER=',lbound(arr), &
           & 'UPPER=',ubound(arr), &
           & 'SIZE=',size(arr)
        end subroutine msub
     end module m_bounds

     use m_bounds, only : msub
     implicit none
     interface
        subroutine esub(arr)
        integer,intent(in) :: arr(:)
        end subroutine esub
     end interface
     integer :: arr(-10:10)
        write(*,*)'MAIN: LOWER=',lbound(arr), &
        & 'UPPER=',ubound(arr), &
        & 'SIZE=',size(arr)
        call csub()
        call msub(arr)
        call esub(arr)
     contains
    subroutine csub
       write(*,*)'CSUB: LOWER=',lbound(arr), &
       & 'UPPER=',ubound(arr), &
       & 'SIZE=',size(arr)
    end subroutine csub
    end

     subroutine esub(arr)
     implicit none
     integer,intent(in) :: arr(:)
        ! WARNING: IF CALLED WITHOUT AN EXPLICIT INTERFACE
        ! THIS WILL GIVE UNDEFINED ANSWERS (like 0,0,0)
        write(*,*)'ESUB: LOWER=',lbound(arr), &
        & 'UPPER=',ubound(arr), &
        & 'SIZE=',size(arr)
     end subroutine esub

    !end program demo_lbound


module IO

use parameters
use constants
implicit none

private calculate_covariant_metric, calculate_contravariant_metric, zamo
public ToFile

contains

subroutine ToFile(array,n,alpha,beta,nu_obs,c, plot_status)
real(kind=dp), dimension(Nrows, Ncols),intent(in) :: array
real(kind=dp), dimension(4),intent(in) :: c
integer(kind=dp), intent(in) :: n
integer(kind=4) :: plot_status
real(kind=dp), intent(in) :: alpha,beta,nu_obs
character(len=200) :: Fname, aStr, bStr, ID, nuStr,TimingFile
integer(kind=dp) :: i
real(kind=dp) :: xC, yC,zC, mm,Lz
real(kind=dp) :: r,theta, pr,ptheta,phi,t
real(kind=dp) :: g_orbit, g_zamo
real(kind=dp),dimension(4) :: pvector,zamo_vector
real(kind=dp),dimension(4,4) :: metric

!Define savefile
write(aStr,'(F16.10)') alpha
write(bStr,'(F16.10)') beta
write(nuStr,'(F10.2)') nu_obs

ID = 'RT_alpha='//trim(adjustl(aStr))//'_beta='//trim(adjustl(bstr))//'_nu='//trim(adjustl(nuStr))//'.txt'
Fname = trim(adjustl(IOpath)) // trim(adjustl(ID))

!Write
open(unit=10, file = Fname, status = 'replace',form = 'formatted')

do i=1,n

r = array(1,i) ; theta = array(2,i); phi = array(3,i) ; t = array(4,i)
pr = array(5,i) ; ptheta = array(6,i)

!Define the general momentum vector - p0 has been normalised, so here we 'unnormalise'
pvector(1) = -Eobs_global
pvector(2) = pr * Eobs_global
pvector(3) = ptheta * Eobs_global
pvector(4) = c(1) * Eobs_global

!Calculate the frequency shift as measured by the orbit
call gamma_shift(pvector,uvector,g_orbit)

!and as measured by a cofalling ZAMO
!Create a zamo at r,theta
call zamo(r,theta,zamo_vector)
call gamma_shift(pvector,zamo_vector,g_zamo)

!On the last step calculate the total energy shift
!if (i .eq. n) then
!call calculate_covariant_metric(r,theta,metric)
!g = -1.0 / ( pvector(1)*uvector(1) + pvector(2)*uvector(2) + pvector(3)*uvector(3) + pvector(4)*uvector(4))
!endif

mm = sqrt(array(1,i)**2 + a**2)
xC = mm * sin(array(2,i))*cos(array(3,i))
yC = mm * sin(array(2,i))*sin(array(3,i))
zC = mm * cos(array(2,i))

!write(10,*) xC, yC ,zC,&
 !           phiTarget, t, g, plot_status, Eobs_global, tauTarget,r,theta,phi

!IO order modified

write(10,*) xC, yC, zC, & !Cartesian
            r,theta,phi, & !Boyer Lindquist
            g_orbit, g_zamo,Eobs_global !Energy shifts with respect to a 4-velocity observer

enddo
close(10)

end subroutine ToFile

subroutine calculate_contravariant_metric(r,theta,metric)
!Arguments
real(kind=dp), intent(IN) :: r, theta
real(kind=dp), intent(out), dimension(4,4) :: metric

!Internals
real(kind=dp) :: sigma, delta

sigma = r**2.0_dp + a**2*cos(theta)**2
delta = r**2.0_dp - 2.0_dp*r + a**2

metric(1,1) = - ((r**2.0_dp + a**2) + 2.0_dp*r*a**2*sin(theta)**2.0_dp/sigma)/delta
metric(2,2) = delta/sigma
metric(3,3) = 1.0_dp/sigma
metric(4,4) = (1.0_dp-2.0_dp*r/sigma)/(delta*sin(theta)**2.0_dp)

metric(1,4) = -2.0_dp*r*a/(sigma*delta)
metric(4,1) = metric(1,4)

!All other terms are zero
metric(1,2) = 0.0_dp
metric(1,3) = 0.0_dp

metric(2,1) = 0.0_dp
metric(2,3) = 0.0_dp
metric(2,4) = 0.0_dp

metric(3,1) = 0.0_dp
metric(3,2) = 0.0_dp
metric(3,4) = 0.0_dp

metric(4,2) = 0.0_dp
metric(4,3) = 0.0_dp

end subroutine calculate_contravariant_metric

subroutine calculate_covariant_metric(r,theta,metric)
!Arguments
real(kind=dp), intent(IN) :: r, theta
real(kind=dp), intent(out), dimension(4,4) :: metric

!Internals
real(kind=dp) :: sigma, delta

sigma = r**2.0_dp + a**2*cos(theta)**2
delta = r**2.0_dp - 2.0_dp*r + a**2

metric(1,1) = -(1.0_dp-2.0_dp*r/sigma)
metric(2,2) = sigma/delta
metric(3,3) = sigma
metric(4,4) = (r**2.0_dp + a**2 + 2.0_dp*r*a**2*sin(theta)**2.0_dp/sigma)*sin(theta)**2.0_dp

metric(1,4) = -2.0_dp*r*a*sin(theta)**2.0_dp/sigma
metric(4,1) = metric(1,4)

!All other terms are zero
metric(1,2) = 0.0_dp
metric(1,3) = 0.0_dp

metric(2,1) = 0.0_dp
metric(2,3) = 0.0_dp
metric(2,4) = 0.0_dp

metric(3,1) = 0.0_dp
metric(3,2) = 0.0_dp
metric(3,4) = 0.0_dp

metric(4,2) = 0.0_dp
metric(4,3) = 0.0_dp

end subroutine calculate_covariant_metric

subroutine zamo(r,theta,u)
!Create zamo at 4-position x
!Outputs contravariant 4-velocity u
real(kind=dp), intent(in) :: r, theta
real(kind=dp), intent(out),dimension(4) :: u

!Other
real(kind=dp),dimension(4,4) :: metric
real(kind=dp) :: omega, norm,delta

!Calculate the covariant metric
call calculate_covariant_metric(r,theta,metric)

!Construct the zamo
omega = -metric(1,4) / metric(4,4)
delta = r**2 -2.0_dp*r + a**2
norm = sqrt(metric(4,4)/ (delta*sin(theta)**2))

u(1) = 1.0_dp ; u(2) = 0.0_dp ; u(3) = 0.0_dp ; u(4) = omega

u = u*norm

end subroutine

subroutine energy_shift(r,theta,Lz,freq)
!Arguments
real(kind=dp), intent(in) :: r,theta,Lz
real(kind=dp), intent(out) :: freq
!Other
real(kind=dp) :: sigma, delta,gphph, AA, omega

sigma = r**2 +a**2*cos(theta)**2
delta = r**2 -2.0_dp*r + a**2
gphph = sin(theta)**2*((r**2 +a**2)**2 - delta*a**2*sin(theta)**2)/sigma
AA = sqrt(gphph / (delta*sin(theta)**2))
omega = 2.0_dp*a*r / ((r**2+a**2)**2 - delta*a**2*sin(theta)**2)
freq = -1.0_dp*AA + omega*AA*Lz
end subroutine energy_shift

subroutine gamma_shift(p,u,g)

!arguments
real(kind=dp),dimension(4),intent(in) :: p,u
real(kind=dp), intent(out) :: g

g = p(1)*u(1) + p(2)*u(2) + p(3)*u(3) + p(4)*u(4)

end subroutine gamma_shift

end module IO


MODULE KPP_ROOT_Integrator

  USE KPP_ROOT_Parameters, ONLY : NVAR, NFIX, NREACT
  USE KPP_ROOT_Global, ONLY : TIME, RCONST, Volume
  USE KPP_ROOT_Stoichiom
  USE KPP_ROOT_Stochastic
  USE KPP_ROOT_Rates
  IMPLICIT NONE

CONTAINS

!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  SUBROUTINE Gillespie(Nevents, T, SCT, NmlcV, NmlcF)
!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
!
!   Gillespie stochastic integration
!   INPUT:
!       Nevents = no. of individual reaction events to be simulated
!       SCT     = stochastic rate constants
!       T       = time
!       NmlcV, NmlcF = no. of molecules for variable and fixed species
!   OUTPUT:
!       T       = updated time (after Nevents reactions)
!       NmlcV   = updated no. of molecules for variable species
!
!
!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
      IMPLICIT NONE
      KPP_REAL:: T
      INTEGER :: Nevents
      INTEGER :: NmlcV(NVAR), NmlcF(NFIX)
      INTEGER :: i, m, issa
      REAL   :: r1, r2
      KPP_REAL :: A(NREACT), SCT(NREACT), x

      DO issa = 1, Nevents

          ! Uniformly distributed random numbers
          CALL RANDOM_NUMBER(r1)
          CALL RANDOM_NUMBER(r2)
          ! Avoid log of zero
          r2 = MAX(r2,1.e-14)

          ! Propensity vector
          CALL  Propensity ( NmlcV, NmlcF, SCT, A )
          ! Cumulative sum of propensities
          DO i = 2, NREACT
            A(i) = A(i-1)+A(i);
          END DO

          ! Index of next reaction
          x = r1*A(NREACT)
          DO i = 1, NREACT
            IF (A(i)>=x) THEN
              m = i;
              EXIT
            END IF
          END DO

          ! Update time with time to next reaction
          T = T - LOG(r2)/A(NREACT);

          ! Update state vector
          CALL MoleculeChange( m, NmlcV )

     END DO

  CONTAINS

    SUBROUTINE PropensityTemplate( T, NmlcV, NmlcF, Prop )
      KPP_REAL, INTENT(IN)  :: T
      INTEGER, INTENT(IN)   :: NmlcV(NVAR), NmlcF(NFIX)
      KPP_REAL, INTENT(OUT) :: Prop(NREACT)
      KPP_REAL :: Tsave, SCT(NREACT)
    ! Update the stochastic reaction rates, which may be time dependent
      Tsave = TIME
      TIME = T
      CALL Update_RCONST()
      CALL StochasticRates( RCONST, Volume, SCT )
      CALL Propensity ( NmlcV, NmlcF, SCT, Prop )
      TIME = Tsave
    END SUBROUTINE PropensityTemplate

  END SUBROUTINE Gillespie

END MODULE KPP_ROOT_Integrator


program test_dimension
implicit none
real, dimension(3,4) :: x,y,z(5,6)
! Line above is legal but confusing. It should be written
! real, dimension(3,4) :: x,y
! real :: z(5,6)
character (len=*), parameter :: fmt = "(2(1x,i0))"
print fmt,shape(x),shape(y),shape(z)
end program test_dimension
! output
! 3 4
! 3 4
! 5 6