!> IMPACT
!! \author Rolf Henniger, Institute of Fluid Dynamics, ETH Zurich (henniger@ifd.mavt.ethz.ch)
!! \date Mai 2005 - Dec 2011

!> \brief module providing functions to initiliaze and apply RestrictionOp
module cmod_RestrictionOp

  use iso_c_binding

  use mpi

  implicit none

contains

  subroutine MG_getCRVS( &
      iimax,            &
      BC_L,             &
      BC_U,             &
      dd,               &
      Nf,               &
      bL,               &
      bU,               &
      xf,               &
      cR ) bind( c, name='MG_getCRVS' )

    implicit none

    integer(c_int), intent(in)  :: iimax
    integer(c_int), intent(in)  :: BC_L
    integer(c_int), intent(in)  :: BC_U

    integer(c_int), intent(in)  :: dd

    integer(c_int), intent(in)  :: Nf

    integer(c_int), intent(in)  :: bL, bU

    real(c_double), intent(in)  :: xf( bL:(Nf+bU) )

    real(c_double), intent(out) :: cR(-1:1,1:iimax)

    real(c_double)              :: h(1:2)
    integer(c_int)              :: i, ii

    cR = 0.

    !====================================================================================
    !=== Restriktion, linienweise, 1d ===================================================
    !====================================================================================

    do i = 1, iimax
      if( 1==dd ) then
        cR(-1,i) = 0.
        cR( 0,i) = 1.
        cR( 1,i) = 0.
      else
        ii = dd*(i-1)+1
        h( 1 ) = xf(ii  ) - xf(ii-1)
        h( 2 ) = xf(ii+1) - xf(ii  )
        cR(-1,i) = h(2)/( h(1) + h(2) )/2. ! 1./4. for equi
        cR( 0,i) = 1./2.
        cR( 1,i) = h(1)/( h(1) + h(2) )/2. ! 1./4/ for equi
      end if
    end do

    if( BC_L > 0 ) then
      cR(-1,1) = 0.
      cR( 0,1) = 1.
      cR( 1,1) = 0.
    end if
    if (BC_L == -2) then
      cR( 1,1) = cR( 1,1) + cR(-1,1)
      cR(-1,1) = 0.
    end if

    if (BC_U > 0) then
      cR(-1,iimax) = 0.
      cR( 0,iimax) = 1.
      cR( 1,iimax) = 0.
    end if

    if (BC_U == -2) then
      cR(-1,iimax) = cR( 1,iimax) + cR(-1,iimax)
      cR( 1,iimax) = 0.
    end if

  end subroutine MG_getCRVS

  subroutine MG_getCRS( &
      iimax,            &
      BC_L,             &
      BC_U,             &
      dd,               &
      Nf,               &
      bL,               &
      bU,               &
      xf,               &
      cR ) bind( c, name='MG_getCRS' )

    implicit none

    integer(c_int), intent(in)  :: iimax
    integer(c_int), intent(in)  :: BC_L
    integer(c_int), intent(in)  :: BC_U

    integer(c_int), intent(in)  :: dd

    integer(c_int), intent(in)  :: Nf

    integer(c_int), intent(in)  :: bL, bU

    real(c_double), intent(in)  :: xf( bL:(Nf+bU) )

    real(c_double), intent(out) :: cR(-1:1,1:iimax)

    real(c_double)              :: h(1:2)
    integer(c_int)              :: i, ii

    cR = 0.

    !====================================================================================
    !=== Restriktion, linienweise, 1d ===================================================
    !====================================================================================

    do i = 1, iimax
      if( 1==dd ) then
        cR(-1,i) = 0.
        cR( 0,i) = 1.
        cR( 1,i) = 0.
      else
        ii = dd*(i-1)+1
        h( 1 ) = xf(ii  ) - xf(ii-1)
        h( 2 ) = xf(ii+1) - xf(ii  )
        cR(-1,i) = h(2)/( h(1) + h(2) )/2. ! 1./4. for equi
        cR( 0,i) = 1./2.
        cR( 1,i) = h(1)/( h(1) + h(2) )/2. ! 1./4/ for equi
      end if
    end do

    if( BC_L > 0 ) then
      !cR( 1,1) = cR(1,1) + cR(-1,1) ! equivalent to 0.5 0.5
      cR(-1,1) = 0.
      cR( 0,1) = 0.5
      cR( 1,1) = 0.5
    end if
    if (BC_L == -2) then
      cR( 1,1) = cR( 1,1) + cR(-1,1)
      cR(-1,1) = 0.
    end if

    if (BC_U > 0) then
      cR(-1,iimax) = 0.5
      cR( 0,iimax) = 0.5
      cR( 1,iimax) = 0.
    end if

    if (BC_U == -2) then
      cR(-1,iimax) = cR( 1,iimax) + cR(-1,iimax)
      cR( 1,iimax) = 0.
    end if
    !! this has proven very good for generated rhs + random init

    !! for testing
    if( BC_L > 0 ) then
      cR(-1,1) = 0.
      cR( 0,1) = 1.
      cR( 1,1) = 0.
    end if
    if (BC_L == -2) then
      cR( 1,1) = cR( 1,1) + cR(-1,1)
      cR(-1,1) = 0.
    end if

    if (BC_U > 0) then
      cR(-1,iimax) = 0.
      cR( 0,iimax) = 1.
      cR( 1,iimax) = 0.
    end if

    if (BC_U == -2) then
      cR(-1,iimax) = cR( 1,iimax) + cR(-1,iimax)
      cR( 1,iimax) = 0.
    end if
  end subroutine MG_getCRS

  !> \brief ugly corner handling
  !! \deprecated
  subroutine MG_RestrictCorners(  &
      Nc,                         &
      bLc,bUc,                    &
      BCL, BCU,                   &
      phif ) bind( c, name='MG_RestrictCorners' )

    implicit none

    integer(c_int), intent(in)     :: Nc(3)

    integer(c_int), intent(in)     :: bLc(3)
    integer(c_int), intent(in)     :: bUc(3)

    integer(c_int), intent(in)     :: BCL(3)
    integer(c_int), intent(in)     :: BCU(3)

    real(c_double), intent(inout)  :: phif (bLc(1):(Nc(1)+bUc(1)),bLc(2):(Nc(2)+bUc(2)),bLc(3):(Nc(3)+bUc(3)))

    !if (BC(1,1,g) > 0 .and. BC(1,2,g) > 0) fine1(  1      ,  1      ,1:NN(3,g)) = (fine1(2        ,1      ,1:NN(3,g)) + fine1(1      ,2        ,1:NN(3,g)))/2.
    !if (BC(1,1,g) > 0 .and. BC(2,2,g) > 0) fine1(  1      ,  NN(2,g),1:NN(3,g)) = (fine1(2        ,NN(2,g),1:NN(3,g)) + fine1(1      ,NN(2,g)-1,1:NN(3,g)))/2.
    !if (BC(2,1,g) > 0 .and. BC(1,2,g) > 0) fine1(  NN(1,g),  1      ,1:NN(3,g)) = (fine1(NN(1,g)-1,1      ,1:NN(3,g)) + fine1(NN(1,g),2        ,1:NN(3,g)))/2.
    !if (BC(2,1,g) > 0 .and. BC(2,2,g) > 0) fine1(  NN(1,g),  NN(2,g),1:NN(3,g)) = (fine1(NN(1,g)-1,NN(2,g),1:NN(3,g)) + fine1(NN(1,g),NN(2,g)-1,1:NN(3,g)))/2.

    if (BCL(1) > 0 .and. BCL(2) > 0) phif( 1,     1,     1:Nc(3) ) = ( phif(1+1,     1,     1:Nc(3)) + phif(1    , 1+1,     1:Nc(3)) )/2.
    if (BCL(1) > 0 .and. BCU(2) > 0) phif( 1,     Nc(2), 1:Nc(3) ) = ( phif(1+1,     Nc(2), 1:Nc(3)) + phif(1    , Nc(2)-1, 1:Nc(3)) )/2.
    if (BCU(1) > 0 .and. BCL(2) > 0) phif( Nc(1), 1,     1:Nc(3) ) = ( phif(Nc(1)-1, 1,     1:Nc(3)) + phif(Nc(1), 1+1,     1:Nc(3)) )/2.
    if (BCU(1) > 0 .and. BCU(2) > 0) phif( Nc(1), Nc(2), 1:Nc(3) ) = ( phif(Nc(1)-1, Nc(2), 1:Nc(3)) + phif(Nc(1), Nc(2)-1, 1:Nc(3)) )/2.

    !if (BC(1,1,g) > 0 .and. BC(1,3,g) > 0) fine1(  1      ,1:NN(2,g),  1      ) = (fine1(2        ,1:NN(2,g),1      ) + fine1(1      ,1:NN(2,g),2        ))/2.
    !if (BC(1,1,g) > 0 .and. BC(2,3,g) > 0) fine1(  1      ,1:NN(2,g),  NN(3,g)) = (fine1(2        ,1:NN(2,g),NN(3,g)) + fine1(1      ,1:NN(2,g),NN(3,g)-1))/2.
    !if (BC(2,1,g) > 0 .and. BC(1,3,g) > 0) fine1(  NN(1,g),1:NN(2,g),  1      ) = (fine1(NN(1,g)-1,1:NN(2,g),1      ) + fine1(NN(1,g),1:NN(2,g),2        ))/2.
    !if (BC(2,1,g) > 0 .and. BC(2,3,g) > 0) fine1(  NN(1,g),1:NN(2,g),  NN(3,g)) = (fine1(NN(1,g)-1,1:NN(2,g),NN(3,g)) + fine1(NN(1,g),1:NN(2,g),NN(3,g)-1))/2.

    if (BCL(1) > 0 .and. BCL(3) > 0) phif( 1,     1:Nc(2), 1 )     = ( phif(1+1,     1:Nc(2), 1    ) + phif(1,     1:Nc(2), 1+1)      )/2.
    if (BCL(1) > 0 .and. BCU(3) > 0) phif( 1,     1:Nc(2), Nc(3) ) = ( phif(1+1,     1:Nc(2), Nc(3)) + phif(1,     1:Nc(2), Nc(3)-1)  )/2.
    if (BCU(1) > 0 .and. BCL(3) > 0) phif( Nc(1), 1:Nc(2), 1 )     = ( phif(Nc(1)-1, 1:Nc(2), 1    ) + phif(Nc(1), 1:Nc(2), 1+1)      )/2.
    if (BCU(1) > 0 .and. BCU(3) > 0) phif( Nc(1), 1:Nc(2), Nc(3) ) = ( phif(Nc(1)-1, 1:Nc(2), Nc(3)) + phif(Nc(1), 1:Nc(2), Nc(3)-1)  )/2.

    !if (BC(1,2,g) > 0 .and. BC(1,3,g) > 0) fine1(1:NN(1,g),  1      ,  1      ) = (fine1(1:NN(1,g),2        ,1      ) + fine1(1:NN(1,g),1      ,2        ))/2.
    !if (BC(1,2,g) > 0 .and. BC(2,3,g) > 0) fine1(1:NN(1,g),  1      ,  NN(3,g)) = (fine1(1:NN(1,g),2        ,NN(3,g)) + fine1(1:NN(1,g),1      ,NN(3,g)-1))/2.
    !if (BC(2,2,g) > 0 .and. BC(1,3,g) > 0) fine1(1:NN(1,g),  NN(2,g),  1      ) = (fine1(1:NN(1,g),NN(2,g)-1,1      ) + fine1(1:NN(1,g),NN(2,g),2        ))/2.
    !if (BC(2,2,g) > 0 .and. BC(2,3,g) > 0) fine1(1:NN(1,g),  NN(2,g),  NN(3,g)) = (fine1(1:NN(1,g),NN(2,g)-1,NN(3,g)) + fine1(1:NN(1,g),NN(2,g),NN(3,g)-1))/2.

    if (BCL(2) > 0 .and. BCL(3) > 0) phif( 1:Nc(1), 1,     1     ) = ( phif(1:Nc(1), 1+1,     1    ) + phif(1:Nc(1), 1,     1+1    ) )/2.
    if (BCL(2) > 0 .and. BCU(3) > 0) phif( 1:Nc(1), 1,     Nc(3) ) = ( phif(1:Nc(1), 1+1,     Nc(3)) + phif(1:Nc(1), 1,     Nc(3)-1) )/2.
    if (BCU(2) > 0 .and. BCL(3) > 0) phif( 1:Nc(1), Nc(2), 1     ) = ( phif(1:Nc(1), Nc(2)-1, 1    ) + phif(1:Nc(1), Nc(2), 1+1    ) )/2.
    if (BCU(2) > 0 .and. BCU(3) > 0) phif( 1:Nc(1), Nc(2), Nc(3) ) = ( phif(1:Nc(1), Nc(2)-1, Nc(3)) + phif(1:Nc(1), Nc(2), Nc(3)-1) )/2.

  end subroutine MG_RestrictCorners

  !> \note: - für allgemeine di, dj, dk geeignet
  !!        - überlappende Schicht in Blöcken wird (der Einfachheit
  !!          halber) ebenfalls ausgetauscht, ist aber im Prinzip
  !!          redundant (genauer: phiC(S1R:N1R,S2R:N2R,S3R:N3R) = ...).
  !!        - Motivation für diese kurze Routine ist die Möglichkeit,
  !!          auch Varianten wie Full-Weighting etc. ggf. einzubauen,
  !!          ansonsten könnte sie auch eingespaart werden.
  !!        - Die Block-überlappenden Stirnflächen werden ebenfalls
  !!          mitverarbeitet, aber eigentlich nicht gebraucht
  !!          (erleichtert die Programmierung), so dass eine
  !!          Initialisierung notwendig ist. Dies wiederum bedingt die
  !!          INTENT(inout)-Deklaration.
  subroutine MG_restrictHW( &
      dimens,             &
      Nf,                 &
      bLf,bUf,            &
      Nc,                 &
      bLc,bUc,            &
      iimax,              &
      dd,                 &
      cR1,cR2,cR3,        &
      phif,               &
      phic ) bind(c,name='MG_restrictHW')

    implicit none

    integer(c_int), intent(in)     :: dimens

    integer(c_int), intent(in)     :: Nf(3)

    integer(c_int), intent(in)     :: bLf(3)
    integer(c_int), intent(in)     :: bUf(3)

    integer(c_int), intent(in)     :: Nc(3)

    integer(c_int), intent(in)     :: bLc(3)
    integer(c_int), intent(in)     :: bUc(3)

    integer(c_int), intent(in)     :: iimax(3)

    integer(c_int), intent(in)     :: dd(3)

    real(c_double),  intent(in)    :: cR1 ( -1:1, 1:iimax(1) )
    real(c_double),  intent(in)    :: cR2 ( -1:1, 1:iimax(2) )
    real(c_double),  intent(in)    :: cR3 ( -1:1, 1:iimax(3) )

    real(c_double),  intent(in)    :: phif (bLf(1):(Nf(1)+bUf(1)),bLf(2):(Nf(2)+bUf(2)),bLf(3):(Nf(3)+bUf(3)))

    real(c_double),  intent(out)   :: phic (bLc(1):(Nc(1)+bUc(1)),bLc(2):(Nc(2)+bUc(2)),bLc(3):(Nc(3)+bUc(3)))

    integer(c_int)                ::  i, ii
    integer(c_int)                ::  j, jj
    integer(c_int)                ::  k, kk

    if (dimens == 3) then
      do kk = 1, iimax(3)
        k = dd(3)*(kk-1)+1
        do jj = 1, iimax(2)
          j = dd(2)*(jj-1)+1
          do ii = 1, iimax(1)
            i = dd(1)*(ii-1)+1
            phic(ii,jj,kk) = ((cR1( 0,ii)+cR2( 0,jj)+cR3( 0,kk))*phif(i  ,j  ,k  ) +  &
              &              cR1(-1,ii)                       *phif(i-1,j  ,k  ) +  &
              &              cR1( 1,ii)                       *phif(i+1,j  ,k  ) +  &
              &                         cR2(-1,jj)            *phif(i  ,j-1,k  ) +  &
              &                         cR2( 1,jj)            *phif(i  ,j+1,k  ) +  &
              &                                     cR3(-1,kk)*phif(i  ,j  ,k-1) +  &
              &                                     cR3( 1,kk)*phif(i  ,j  ,k+1)) / 3.
          end do
        end do
      end do
    else
      k  = 1
      kk = 1
      do jj = 1, iimax(2)
        j = dd(2)*(jj-1)+1
        do ii = 1, iimax(1)
          i = dd(1)*(ii-1)+1
          phic(ii,jj,kk) = ((cR1( 0,ii)+cR2(0,jj))*phif(i  ,j  ,k) +  &
            &              cR1(-1,ii)           *phif(i-1,j  ,k) +  &
            &              cR1( 1,ii)           *phif(i+1,j  ,k) +  &
            &                         cR2(-1,jj)*phif(i  ,j-1,k) +  &
            &                         cR2( 1,jj)*phif(i  ,j+1,k)) / 2.
        end do
      end do
    end if

  end subroutine MG_restrictHW

  subroutine MG_RestrictGather( &
      Nc,                       &
      bLc,bUc,                  &
      bCL_loc,                  &
      bCL_glo,                  &
      iimax,                    &
      n_gather,                 &
      participate_yes,          &
      rankc2,                   &
      comm2,                    &
      recvR,                    &
      dispR,                    &
      sizsR,                    &
      offsR,                    &
      phic ) bind(c,name='MG_RestrictGather')

    implicit none

    integer(c_int), intent(in)     :: Nc(3)

    integer(c_int), intent(in)     :: bLc(3)
    integer(c_int), intent(in)     :: bUc(3)

    integer(c_int), intent(in)     :: bCL_loc(3)
    integer(c_int), intent(in)     :: bCL_glo(3)

    integer(c_int), intent(in)     :: iimax(3)

    integer(c_int), intent(in)     :: n_gather(3)

    logical(c_bool), intent(in)    :: participate_yes

    integer(c_int), intent(in)     :: rankc2

    integer(c_int), intent(in)     :: comm2

    integer(c_int), intent(in)     :: recvR(     1:n_gather(1)*n_gather(2)*n_gather(3) )
    integer(c_int), intent(in)     :: dispR(     1:n_gather(1)*n_gather(2)*n_gather(3) )
    integer(c_int), intent(in)     :: sizsR(1:3, 1:n_gather(1)*n_gather(2)*n_gather(3) )
    integer(c_int), intent(in)     :: offsR(1:3, 1:n_gather(1)*n_gather(2)*n_gather(3) )

    real(c_double),intent(inout)   :: phic (bLc(1):(Nc(1)+bUc(1)),bLc(2):(Nc(2)+bUc(2)),bLc(3):(Nc(3)+bUc(3)))

    integer(c_int)                ::  i, ii
    integer(c_int)                ::  j, jj
    integer(c_int)                ::  k, kk

    integer(c_int)                ::  merror
    real(c_double), allocatable   ::  sendbuf(:,:,:)
    integer(c_int)                ::  sizsg(1:3), offsg(1:3), dispg
    real(c_double)                ::  recvbuf( 1:( Nc(1)*Nc(2)*Nc(3)*3 ) )
    integer(c_int)                ::  SS(3)

    !if (n_gather(1)*n_gather(2)*n_gather(3) > 1) then
    SS(:) = 1

    if( 0<BCL_loc(1) ) SS(1) = 0
    if( 0<BCL_loc(2) ) SS(2) = 0
    if( 0<BCL_loc(3) ) SS(3) = 0

    ! Anmerkung: Besser nicht fest allocieren um Speicherplatz zu sparen, ODER
    ! gleich "phic" verwenden!
    allocate(sendbuf(SS(1):iimax(1),SS(2):iimax(2),SS(3):iimax(3)))

    do kk = SS(3), iimax(3)
      do jj = SS(2), iimax(2)
        do ii = SS(1), iimax(1)
          sendbuf(ii,jj,kk) = phic(ii,jj,kk)
        end do
      end do
    end do

    call MPI_GATHERv(   &
      sendbuf,          & ! starting address of send buffer (choice)
      (iimax(1)-SS(1)+1)*(iimax(2)-SS(2)+1)*(iimax(3)-SS(3)+1), & ! of elements in send buffer
      MPI_REAL8,        & ! data type of send buffer elements
      recvbuf,          & ! address of receive buffer
      recvR,            & ! non-negative integer array (of length group size) containing the number of elements that are received from each process
      dispR,            & ! integer array (of length group size). Entry i specifies the displacement (relative to recvbuf) at which to place the incoming data from process i
      MPI_REAL8,        & ! data type of receive buffer elements (handle)
      rankc2,           & ! rank of receiving process
      comm2,            & ! communicator
      merror)

    deallocate(sendbuf)

    if( participate_yes ) then
      do k = 1, n_gather(3)
        do j = 1, n_gather(2)
          do i = 1, n_gather(1)

            sizsg(1:3) = sizsR(1:3,i+(j-1)*n_gather(1)+(k-1)*n_gather(1)*n_gather(2))
            offsg(1:3) = offsR(1:3,i+(j-1)*n_gather(1)+(k-1)*n_gather(1)*n_gather(2))
            dispg      = dispR(    i+(j-1)*n_gather(1)+(k-1)*n_gather(1)*n_gather(2))

            if( 1==i .and. 0<BCL_glo(1) ) offsg(1) = -1
            if( 1==j .and. 0<BCL_glo(2) ) offsg(2) = -1
            if( 1==k .and. 0<BCL_glo(3) ) offsg(3) = -1

            do kk = 1, sizsg(3)
              do jj = 1, sizsg(2)
                do ii = 1, sizsg(1)
                  phic(ii+offsg(1),jj+offsg(2),kk+offsg(3)) = recvbuf(dispg+ii+(jj-1)*sizsg(1)+(kk-1)*sizsg(1)*sizsg(2))
                end do
              end do
            end do

          end do
        end do
      end do
    end if

  end subroutine MG_RestrictGather

  !> restriction
  !! \note - für allgemeine di, dj, dk geeignet!
  !!       - überlappende Schicht in Blöcken wird (der Einfachheit halber) ebenfalls ausgetauscht, ist
  !!         aber im Prinzip redundant (genauer: phiC(S1R:N1R,S2R:N2R,S3R:N3R) = ...).
  !!       - Motivation für diese kurze Routine ist die Möglichkeit, auch Varianten wie Full-Weighting
  !!         etc. ggf. einzubauen, ansonsten könnte sie auch eingespaart werden.
  !!       - Die Block-überlappenden Stirnflächen werden ebenfalls mitverarbeitet, aber eigentlich
  !!         nicht gebraucht (erleichtert die Programmierung), so dass eine Initialisierung notwendig
  !!         ist. Dies wiederum bedingt die INTENT(inout)-Deklaration.
  subroutine MG_restrictFW( &
      dimens,               &
      Nf,                   &
      bLf,bUf,              &
      Nc,                   &
      bLc,bUc,              &
      iimax,                &
      dd,                   &
      cR1,cR2,cR3,          &
      phif,                 &
      phic ) bind(c,name='MG_restrictFW')

    implicit none

    integer(c_int), intent(in)     :: dimens

    integer(c_int), intent(in)     :: Nf(3)

    integer(c_int), intent(in)     :: bLf(3)
    integer(c_int), intent(in)     :: bUf(3)

    integer(c_int), intent(in)     :: Nc(3)

    integer(c_int), intent(in)     :: bLc(3)
    integer(c_int), intent(in)     :: bUc(3)

    integer(c_int), intent(in)     :: iimax(3)

    integer(c_int), intent(in)     :: dd(3)

    real(c_double),  intent(in)    :: cR1 ( -1:1, 1:iimax(1) )
    real(c_double),  intent(in)    :: cR2 ( -1:1, 1:iimax(2) )
    real(c_double),  intent(in)    :: cR3 ( -1:1, 1:iimax(3) )

    real(c_double),  intent(in)    :: phif (bLf(1):(Nf(1)+bUf(1)),bLf(2):(Nf(2)+bUf(2)),bLf(3):(Nf(3)+bUf(3)))

    real(c_double),  intent(out)   :: phic (bLc(1):(Nc(1)+bUc(1)),bLc(2):(Nc(2)+bUc(2)),bLc(3):(Nc(3)+bUc(3)))

    integer(c_int)                ::  i, ii
    integer(c_int)                ::  j, jj
    integer(c_int)                ::  k, kk

    if( dimens == 3 ) then
      do kk = 1, iimax(3)
        k = dd(3)*(kk-1)+1
        do jj = 1, iimax(2)
          j = dd(2)*(jj-1)+1
          do ii = 1, iimax(1)
            i = dd(1)*(ii-1)+1
            phic(ii,jj,kk) =                                              &
              &   cR1(-1,ii)*cR2(-1,jj)*cR3(-1,kk)*phif(i-1,j-1,k-1) +    &
              &   cR1( 0,ii)*cR2(-1,jj)*cR3(-1,kk)*phif(i  ,j-1,k-1) +    &
              &   cR1(+1,ii)*cR2(-1,jj)*cR3(-1,kk)*phif(i+1,j-1,k-1) +    &
              !
            &     cR1(-1,ii)*cR2( 0,jj)*cR3(-1,kk)*phif(i-1,j  ,k-1) +    &
              &   cR1( 0,ii)*cR2( 0,jj)*cR3(-1,kk)*phif(i  ,j  ,k-1) +    &
              &   cR1(+1,ii)*cR2( 0,jj)*cR3(-1,kk)*phif(i+1,j  ,k-1) +    &
              !
            &     cR1(-1,ii)*cR2(+1,jj)*cR3(-1,kk)*phif(i-1,j+1,k-1) +    &
              &   cR1( 0,ii)*cR2(+1,jj)*cR3(-1,kk)*phif(i  ,j+1,k-1) +    &
              &   cR1(+1,ii)*cR2(+1,jj)*cR3(-1,kk)*phif(i+1,j+1,k-1) +    &
              !
            &     cR1(-1,ii)*cR2(-1,jj)*cR3( 0,kk)*phif(i-1,j-1,k  ) +    &
              &   cR1( 0,ii)*cR2(-1,jj)*cR3( 0,kk)*phif(i  ,j-1,k  ) +    &
              &   cR1(+1,ii)*cR2(-1,jj)*cR3( 0,kk)*phif(i+1,j-1,k  ) +    &
              !
            &     cR1(-1,ii)*cR2( 0,jj)*cR3( 0,kk)*phif(i-1,j  ,k  ) +    &
              &   cR1( 0,ii)*cR2( 0,jj)*cR3( 0,kk)*phif(i  ,j  ,k  ) +    &
              &   cR1(+1,ii)*cR2( 0,jj)*cR3( 0,kk)*phif(i+1,j  ,k  ) +    &
              !
            &     cR1(-1,ii)*cR2(+1,jj)*cR3( 0,kk)*phif(i-1,j+1,k  ) +    &
              &   cR1( 0,ii)*cR2(+1,jj)*cR3( 0,kk)*phif(i  ,j+1,k  ) +    &
              &   cR1(+1,ii)*cR2(+1,jj)*cR3( 0,kk)*phif(i+1,j+1,k  ) +    &
              !
            !
            &     cR1(-1,ii)*cR2(-1,jj)*cR3(+1,kk)*phif(i-1,j-1,k+1) +    &
              &   cR1( 0,ii)*cR2(-1,jj)*cR3(+1,kk)*phif(i  ,j-1,k+1) +    &
              &   cR1(+1,ii)*cR2(-1,jj)*cR3(+1,kk)*phif(i+1,j-1,k+1) +    &
              !
            &     cR1(-1,ii)*cR2( 0,jj)*cR3(+1,kk)*phif(i-1,j  ,k+1) +    &
              &   cR1( 0,ii)*cR2( 0,jj)*cR3(+1,kk)*phif(i  ,j  ,k+1) +    &
              &   cR1(+1,ii)*cR2( 0,jj)*cR3(+1,kk)*phif(i+1,j  ,k+1) +    &
              !
            &     cR1(-1,ii)*cR2(+1,jj)*cR3(+1,kk)*phif(i-1,j+1,k+1) +    &
              &   cR1( 0,ii)*cR2(+1,jj)*cR3(+1,kk)*phif(i  ,j+1,k+1) +    &
              &   cR1(+1,ii)*cR2(+1,jj)*cR3(+1,kk)*phif(i+1,j+1,k+1)
          end do
        end do
      end do
    else
      k  = 1
      kk = 1
      do jj = 1, iimax(2)
        j = dd(2)*(jj-1)+1
        do ii = 1, iimax(1)
          i = dd(1)*(ii-1)+1
          phic(ii,jj,kk) =    &
            &              cR1(-1,ii)*cR2(-1,jj)*phif(i-1,j-1,k) +  &
            &              cR1( 0,ii)*cR2(-1,jj)*phif(i  ,j-1,k) +  &
            &              cR1(+1,ii)*cR2(-1,jj)*phif(i+1,j-1,k) +  &
            !
          &                cR1(-1,ii)*cR2( 0,jj)*phif(i-1,j  ,k) +  &
            &              cR1( 0,ii)*cR2( 0,jj)*phif(i  ,j  ,k) +  &
            &              cR1(+1,ii)*cR2( 0,jj)*phif(i+1,j  ,k) +  &
            !
          &                cR1(-1,ii)*cR2(+1,jj)*phif(i-1,j+1,k) +  &
            &              cR1( 0,ii)*cR2(+1,jj)*phif(i  ,j+1,k) +  &
            &              cR1(+1,ii)*cR2(+1,jj)*phif(i+1,j+1,k)
        end do
      end do
    end if

  end subroutine MG_restrictFW

  !!> \note - Null-Setzen am Rand nicht notwendig!
  !!!       - Da nur in Richtung der jeweiligen Geschwindigkeitskomponente
  !!!         gemittelt wird, muss nicht die spezialisierte Helmholtz-Variante
  !!!         aufgerufen werden.
  !!!       - Austauschrichtung ist invers zu ex1, ex2, ex3. Bei mehreren Blöcken
  !!!         wird auch der jeweils redundante "überlappende" Punkt aufgrund der
  !!!         zu grossen Intervallgrenzen (1:iimax) zwar berechnet, aber aufgrund
  !!!         des Einweg-Austauschs falsch berechnet! Dieses Vorgehen wurde
  !!!         bislang aus übersichtsgründen vorgezogen, macht aber eine
  !!!         Initialisierung notwendig.
  !!!         Dabei werden Intervalle der Form 0:imax anstelle von 1:imax
  !!!         bearbeitet, da hier nur die das feinste Geschwindigkeitsgitter
  !!!         behandelt wird!
  !!!       - INTENT(inout) ist bei den feinen Gittern notwendig, da Ghost-Werte
  !!!         ausgetauscht werden müssen.
  !!!       - Zuviele Daten werden ausgetauscht; eigentlich müsste in der
  !!!         Grenzfläche nur jeder 4. Punkt behandelt werden (4x zuviel!).
  !!!         Leider etwas unschön, könnte aber durch eine spezialisierte
  !!!         Austauschroutine behandelt werden, da das übergeben von Feldern mit
  !!!         Intervallen von b1L:(iimax+b1U) nur sehr schlecht funktionieren
  !!!         würde (d.h. mit Umkopieren).
  !subroutine MG_restrictFWV(    &
      !dimens,                   &
      !dir,                      &
      !Nf,                       &
      !bLf,bUf,                  &
      !SSf,NNf,                  &
      !Nc,                       &
      !bLc,bUc,                  &
      !SSc,NNc,                  &
      !iimax,                    &
      !dd,                       &
      !cRV,                      &
      !cR1,cR2,cR3,              &
      !phif,                     &
      !phic ) bind (c,name='MG_restrictFWV')

    !implicit none

    !integer(c_int), intent(in)     :: dimens

    !integer(c_int), intent(in)     :: dir

    !integer(c_int), intent(in)     :: Nf(1:3)

    !integer(c_int), intent(in)     :: bLf(1:3)
    !integer(c_int), intent(in)     :: bUf(1:3)

    !integer(c_int), intent(in)     :: SSf(1:3)
    !integer(c_int), intent(in)     :: NNf(1:3)

    !integer(c_int), intent(in)     :: Nc(1:3)

    !integer(c_int), intent(in)     :: bLc(1:3)
    !integer(c_int), intent(in)     :: bUc(1:3)

    !integer(c_int), intent(in)     :: SSc(1:3)
    !integer(c_int), intent(in)     :: NNc(1:3)

    !integer(c_int), intent(in)     :: iimax(1:3)

    !integer(c_int), intent(in)     :: dd(1:3)

    !real(c_double),  intent(in)    :: cRV ( 1:2, 0:iimax(dir) )

    !real(c_double),  intent(in)    :: cR1 ( -1:1, 1:iimax(1) )
    !real(c_double),  intent(in)    :: cR2 ( -1:1, 1:iimax(2) )
    !real(c_double),  intent(in)    :: cR3 ( -1:1, 1:iimax(3) )

    !real(c_double),  intent(in)    :: phif (bLf(1):(Nf(1)+bUf(1)),bLf(2):(Nf(2)+bUf(2)),bLf(3):(Nf(3)+bUf(3)))

    !real(c_double),  intent(out)   :: phic (bLc(1):(Nc(1)+bUc(1)),bLc(2):(Nc(2)+bUc(2)),bLc(3):(Nc(3)+bUc(3)))

    !integer(c_int)               ::  i, ii
    !integer(c_int)               ::  j, jj
    !integer(c_int)               ::  k, kk

    !! TEST!!! Test schreiben, um n_gather(:,2) .GT. 1 hier zu vermeiden!
    !! Gleiches gilt natürlich für die Interpolation.

    !!====================================================================================
    !if( 1==dir ) then

      !if( 2==dimens ) then

        !!write(*,*)
        !!do kk = SSc(3), iimax(3)
          !!k = kk
          !!do jj = SSc(2), iimax(2)
            !!j = dd(2)*(jj-1)+1
            !!do ii = SSc(1), iimax(1)
              !!!i = max( dd(1)*(ii-1)+1, 0 )
              !!i =  dd(1)*(ii-1)+1
              !!!write(*,*) jj, j
              !!if( 1==dd(1) ) then
                !!!phic(ii,jj,kk) = &
                  !!!&  cR2( -1, jj)*phif(i,j-1,k  ) + &
                  !!!&  cR2(  0, jj)*phif(i,j  ,k  ) + &
                  !!!&  cR2( +1, jj)*phif(i,j+1,k  )
                  !!!!
              !!else
                !!!phic(ii,jj,kk) = &
                  !!!& cRV(1,ii)*cR2(-1,jj)*phif(i  ,j-1,k  ) + &
                  !!!& cRV(2,ii)*cR2(-1,jj)*phif(i+1,j-1,k  ) + &
                  !!!!
                !!!&   cRV(1,ii)*cR2( 0,jj)*phif(i  ,j  ,k  ) + &
                  !!!& cRV(2,ii)*cR2( 0,jj)*phif(i+1,j  ,k  ) + &
                  !!!!
                !!!&   cRV(1,ii)*cR2(+1,jj)*phif(i  ,j+1,k  ) + &
                  !!!& cRV(2,ii)*cR2(+1,jj)*phif(i+1,j+1,k  )
                  !!!!
              !!end if
            !!end do
          !!end do
        !!end do

      !else

        !do kk = SSc(3), iimax(3)
          !k = dd(3)*(kk-1)+1
          !do jj = SSc(2), iimax(2)
            !j = dd(2)*(jj-1)+1
            !do ii = SSc(1), iimax(1)
              !!i = max( dd(1)*(ii-1)+1, 0 )
              !i = dd(1)*(ii-1)+1
              !if( 1==dd(1) ) then
                !!phic(ii,jj,kk) = &
                  !!&  cR2( -1, jj)*cR3(-1,kk)*phif(i,j-1,k-1) + &
                  !!&  cR2(  0, jj)*cR3(-1,kk)*phif(i,j  ,k-1) + &
                  !!&  cR2( +1, jj)*cR3(-1,kk)*phif(i,j+1,k-1) + &
                  !!!
                !!&    cR2( -1, jj)*cR3( 0,kk)*phif(i,j-1,k  ) + &
                  !!&  cR2(  0, jj)*cR3( 0,kk)*phif(i,j  ,k  ) + &
                  !!&  cR2( +1, jj)*cR3( 0,kk)*phif(i,j+1,k  ) + &
                  !!!
                !!&    cR2( -1, jj)*cR3(+1,kk)*phif(i,j-1,k+1) + &
                  !!&  cR2(  0, jj)*cR3(+1,kk)*phif(i,j  ,k+1) + &
                  !!&  cR2( +1, jj)*cR3(+1,kk)*phif(i,j+1,k+1)
              !else
                !!phic(ii,jj,kk) = &
                  !!& cRV(1,ii)*cR2(-1,jj)*cR3(-1,kk)*phif(i  ,j-1,k-1) + &
                  !!& cRV(2,ii)*cR2(-1,jj)*cR3(-1,kk)*phif(i+1,j-1,k-1) + &
                  !!!
                !!&   cRV(1,ii)*cR2( 0,jj)*cR3(-1,kk)*phif(i  ,j  ,k-1) + &
                  !!& cRV(2,ii)*cR2( 0,jj)*cR3(-1,kk)*phif(i+1,j  ,k-1) + &
                  !!!
                !!&   cRV(1,ii)*cR2(+1,jj)*cR3(-1,kk)*phif(i  ,j+1,k-1) + &
                  !!& cRV(2,ii)*cR2(+1,jj)*cR3(-1,kk)*phif(i+1,j+1,k-1) + &
                  !!!
                !!&   cRV(1,ii)*cR2(-1,jj)*cR3( 0,kk)*phif(i  ,j-1,k  ) + &
                  !!& cRV(2,ii)*cR2(-1,jj)*cR3( 0,kk)*phif(i+1,j-1,k  ) + &
                  !!!
                !!&   cRV(1,ii)*cR2( 0,jj)*cR3( 0,kk)*phif(i  ,j  ,k  ) + &
                  !!& cRV(2,ii)*cR2( 0,jj)*cR3( 0,kk)*phif(i+1,j  ,k  ) + &
                  !!!
                !!&   cRV(1,ii)*cR2(+1,jj)*cR3( 0,kk)*phif(i  ,j+1,k  ) + &
                  !!& cRV(2,ii)*cR2(+1,jj)*cR3( 0,kk)*phif(i+1,j+1,k  ) + &
                  !!!
                !!&   cRV(1,ii)*cR2(-1,jj)*cR3(+1,kk)*phif(i  ,j-1,k+1) + &
                  !!& cRV(2,ii)*cR2(-1,jj)*cR3(+1,kk)*phif(i+1,j-1,k+1) + &
                  !!!
                !!&   cRV(1,ii)*cR2( 0,jj)*cR3(+1,kk)*phif(i  ,j  ,k+1) + &
                  !!& cRV(2,ii)*cR2( 0,jj)*cR3(+1,kk)*phif(i+1,j  ,k+1) + &
                  !!!
                !!&   cRV(1,ii)*cR2(+1,jj)*cR3(+1,kk)*phif(i  ,j+1,k+1) + &
                  !!& cRV(2,ii)*cR2(+1,jj)*cR3(+1,kk)*phif(i+1,j+1,k+1)
              !end if
            !end do
          !end do
        !end do

      !end if

    !end if
    !!====================================================================================
    !if( 2==dir ) then

      !!if( 2==dimens ) then

        !!do kk = SSc(3), iimax(3)
          !!k = kk
          !!do jj = SSc(2), iimax(2)
            !!!j = dd(2)*(jj-1)+1
            !!j = dd(2)*(jj-1)+1
            !!do ii = SSc(1), iimax(1)
              !!i = dd(1)*(ii-1)+1
              !!if( 1==dd(2) ) then
                !!phic(ii,jj,kk) = &
                  !!&  cR1( -1, ii)*phif(i-1,j,k  ) + &
                  !!&  cR1(  0, ii)*phif(i  ,j,k  ) + &
                  !!&  cR1( +1, ii)*phif(i+1,j,k  )
              !!else
                !!phic(ii,jj,kk) = &
                  !!& cR1(-1,ii)*cRV(1,jj)*phif(i-1,j  ,k  ) + &
                  !!& cR1( 0,ii)*cRV(1,jj)*phif(i  ,j  ,k  ) + &
                  !!& cR1(+1,ii)*cRV(1,jj)*phif(i+1,j  ,k  ) + &
                  !!!
                !!&   cR1(-1,ii)*cRV(2,jj)*phif(i-1,j+1,k  ) + &
                  !!& cR1( 0,ii)*cRV(2,jj)*phif(i  ,j+1,k  ) + &
                  !!& cR1(+1,ii)*cRV(2,jj)*phif(i+1,j+1,k  )
              !!end if
            !!end do
          !!end do
        !!end do

      !!else

        !!do kk = SSc(3), iimax(3)
          !!k = dd(3)*(kk-1)+1
          !!do jj = SSc(2), iimax(2)
            !!j = dd(2)*(jj-1)+1
            !!do ii = SSc(1), iimax(1)
              !!i = dd(1)*(ii-1)+1
              !!if( 1==dd(2) ) then
                !!phic(ii,jj,kk) = &
                  !!&  cR1( -1, ii)*cR3(-1,kk)*phif(i-1,j,k-1) + &
                  !!&  cR1(  0, ii)*cR3(-1,kk)*phif(i  ,j,k-1) + &
                  !!&  cR1( +1, ii)*cR3(-1,kk)*phif(i+1,j,k-1) + &
                  !!!
                !!&    cR1( -1, ii)*cR3( 0,kk)*phif(i-1,j,k  ) + &
                  !!&  cR1(  0, ii)*cR3( 0,kk)*phif(i  ,j,k  ) + &
                  !!&  cR1( +1, ii)*cR3( 0,kk)*phif(i+1,j,k  ) + &
                  !!!
                !!&    cR1( -1, ii)*cR3(+1,kk)*phif(i-1,j,k+1) + &
                  !!&  cR1(  0, ii)*cR3(+1,kk)*phif(i  ,j,k+1) + &
                  !!&  cR1( +1, ii)*cR3(+1,kk)*phif(i+1,j,k+1)
              !!else
                !!phic(ii,jj,kk) = &
                  !!& cR1(-1,ii)*cRV(1,jj)*cR3(-1,kk)*phif(i-1,j  ,k-1) + &
                  !!& cR1( 0,ii)*cRV(1,jj)*cR3(-1,kk)*phif(i  ,j  ,k-1) + &
                  !!& cR1(+1,ii)*cRV(1,jj)*cR3(-1,kk)*phif(i+1,j  ,k-1) + &
                  !!!
                !!&   cR1(-1,ii)*cRV(2,jj)*cR3(-1,kk)*phif(i-1,j+1,k-1) + &
                  !!& cR1( 0,ii)*cRV(2,jj)*cR3(-1,kk)*phif(i  ,j+1,k-1) + &
                  !!& cR1(+1,ii)*cRV(2,jj)*cR3(-1,kk)*phif(i+1,j+1,k-1) + &
                  !!!
                !!&   cR1(-1,ii)*cRV(1,jj)*cR3( 0,kk)*phif(i-1,j  ,k  ) + &
                  !!& cR1( 0,ii)*cRV(1,jj)*cR3( 0,kk)*phif(i  ,j  ,k  ) + &
                  !!& cR1(+1,ii)*cRV(1,jj)*cR3( 0,kk)*phif(i+1,j  ,k  ) + &
                  !!!
                !!&   cR1(-1,ii)*cRV(2,jj)*cR3( 0,kk)*phif(i-1,j+1,k  ) + &
                  !!& cR1( 0,ii)*cRV(2,jj)*cR3( 0,kk)*phif(i  ,j+1,k  ) + &
                  !!& cR1(+1,ii)*cRV(2,jj)*cR3( 0,kk)*phif(i+1,j+1,k  ) + &
                  !!!
                !!&   cR1(-1,ii)*cRV(1,jj)*cR3(+1,kk)*phif(i-1,j  ,k+1) + &
                  !!& cR1( 0,ii)*cRV(1,jj)*cR3(+1,kk)*phif(i  ,j  ,k+1) + &
                  !!& cR1(+1,ii)*cRV(1,jj)*cR3(+1,kk)*phif(i+1,j  ,k+1) + &
                  !!!
                !!&   cR1(-1,ii)*cRV(2,jj)*cR3(+1,kk)*phif(i-1,j+1,k+1) + &
                  !!& cR1( 0,ii)*cRV(2,jj)*cR3(+1,kk)*phif(i  ,j+1,k+1) + &
                  !!& cR1(+1,ii)*cRV(2,jj)*cR3(+1,kk)*phif(i+1,j+1,k+1)
              !!end if
            !!end do
          !!end do
        !!end do

      !!end if

    !end if
    !!====================================================================================
    !if( 3==dimens .and. dir==3 ) then

      !do kk = SSc(3), iimax(3)
        !k = dd(3)*(kk-1)+1
        !do jj = SSc(2), iimax(2)
          !j = dd(2)*(jj-1)+1
          !do ii = SSc(1), iimax(1)
            !i = dd(1)*(ii-1)+1
            !if( 1==dd(3) ) then
              !phic(ii,jj,kk) = &
                !& cR1(-1,ii)*cR2(-1,jj)*phif(i-1,j-1,k) + &
                !& cR1( 0,ii)*cR2(-1,jj)*phif(i  ,j-1,k) + &
                !& cR1(+1,ii)*cR2(-1,jj)*phif(i+1,j-1,k) + &
                !!
              !&   cR1(-1,ii)*cR2( 0,jj)*phif(i-1,j  ,k) + &
                !& cR1( 0,ii)*cR2( 0,jj)*phif(i  ,j  ,k) + &
                !& cR1(+1,ii)*cR2( 0,jj)*phif(i+1,j  ,k) + &
                !!
              !&   cR1(-1,ii)*cR2(+1,jj)*phif(i-1,j+1,k) + &
                !& cR1( 0,ii)*cR2(+1,jj)*phif(i  ,j+1,k) + &
                !& cR1(+1,ii)*cR2(+1,jj)*phif(i+1,j+1,k)
            !else
              !phic(ii,jj,kk) = &
                !& cR1(-1,ii)*cR2(-1,jj)*cRV(1,kk)*phif(i-1,j-1,k  ) + &
                !& cR1( 0,ii)*cR2(-1,jj)*cRV(1,kk)*phif(i  ,j-1,k  ) + &
                !& cR1(+1,ii)*cR2(-1,jj)*cRV(1,kk)*phif(i+1,j-1,k  ) + &
                !!
              !&   cR1(-1,ii)*cR2(-1,jj)*cRV(2,kk)*phif(i-1,j-1,k+1) + &
                !& cR1( 0,ii)*cR2(-1,jj)*cRV(2,kk)*phif(i  ,j-1,k+1) + &
                !& cR1(+1,ii)*cR2(-1,jj)*cRV(2,kk)*phif(i+1,j-1,k+1) + &
                !!
              !&   cR1(-1,ii)*cR2( 0,jj)*cRV(1,kk)*phif(i-1,j  ,k  ) + &
                !& cR1( 0,ii)*cR2( 0,jj)*cRV(1,kk)*phif(i  ,j  ,k  ) + &
                !& cR1(+1,ii)*cR2( 0,jj)*cRV(1,kk)*phif(i+1,j  ,k  ) + &
                !!
              !&   cR1(-1,ii)*cR2( 0,jj)*cRV(2,kk)*phif(i-1,j  ,k+1) + &
                !& cR1( 0,ii)*cR2( 0,jj)*cRV(2,kk)*phif(i  ,j  ,k+1) + &
                !& cR1(+1,ii)*cR2( 0,jj)*cRV(2,kk)*phif(i+1,j  ,k+1) + &
                !!
              !&   cR1(-1,ii)*cR2(+1,jj)*cRV(1,kk)*phif(i-1,j+1,k  ) + &
                !& cR1( 0,ii)*cR2(+1,jj)*cRV(1,kk)*phif(i  ,j+1,k  ) + &
                !& cR1(+1,ii)*cR2(+1,jj)*cRV(1,kk)*phif(i+1,j+1,k  ) + &
                !!
              !&   cR1(-1,ii)*cR2(+1,jj)*cRV(2,kk)*phif(i-1,j+1,k+1) + &
                !& cR1( 0,ii)*cR2(+1,jj)*cRV(2,kk)*phif(i  ,j+1,k+1) + &
                !& cR1(+1,ii)*cR2(+1,jj)*cRV(2,kk)*phif(i+1,j+1,k+1)
            !end if
          !end do
        !end do
      !end do

    !end if
    !!===========================================================================================

  !end subroutine MG_restrictFWV

end module cmod_RestrictionOp


program test_CIJ_symm

use anisotropy_ajn, only: CIJ_symm

implicit none

real(8) :: C(6,6) = reshape((/11, 12, 13, 14, 15, 16, &
                               0, 22, 23, 24, 25, 26, &
                               0,  0, 33, 34, 35, 36, &
                               0,  0,  0, 44, 45, 46, &
                               0,  0,  0,  0, 55, 56, &
                               0,  0,  0,  0,  0, 66/), (/6,6/))

write(*,'(a)') 'Matrix before symmetrisation:'
write(*,'(6(f4.0,1x))') C

call CIJ_symm(C)

write(*,'(/a)') 'Matrix after symmetrisation:'
write(*,'(6(f4.0,1x))') C

end program test_CIJ_symm


program bubblesort
  implicit none
  integer  :: nums(10)
  integer  :: n, t, ierr, sorted
  character(len=100)  :: ioerrmsg

! Initialize error subroutine
  interface
     subroutine errh(ierr, ioerrmsg)
       integer, intent(in)  :: ierr
       character(len=100), intent(in)  :: ioerrmsg
     end subroutine errh
  end interface

! Parse input to array
  open(12, file="nums", status="old", form="formatted", iostat=ierr, err=9, iomsg=ioerrmsg)

  do n = 1, 10
     read(12, *, iostat=ierr, iomsg=ioerrmsg) nums(n)

     if (ierr .ne. 0) then
        goto 9
     else
        continue
     endif
  enddo

  close(12)

! Sort
  sorted = 0
  do while (sorted .lt. 9)
     do n = 2, 10
        if (nums(n - 1) .gt. nums(n)) then
           t = nums(n)
           nums(n) = nums(n - 1)
           nums(n - 1) = t
           sorted = 0
        else
           sorted = sorted + 1
        endif
     enddo
  enddo

! Print sorted numbers
  do n = 1, 10
     print 68, nums(n)
68   format(I3)
  enddo

9 call errh(ierr, ioerrmsg)

end program bubblesort


function dot(a,b,n)
  ! Compute the dot product of a and b
    implicit none
    real*8 :: dot ! return  value
  !-----------------------------------------------
  ! Declare function parameters
    integer*4              , intent(in)    :: n
    real*8   , dimension(n), intent(in)    :: a,b
  !-----------------------------------------------
  ! Declare local variables
    integer*4 :: i
  !-----------------------------------------------'
    dot = 0.
    do i=1,n
        dot = dot + a(i) * b(i)
    end do
end function dot


!===============================================================================
! One of Andy Nowacki's Fortran utility modules for dealing with seismic
! anisotropy and other problems.
!
! Andy Nowacki <andy.nowacki@bristol.ac.uk>
!
! See the file LICENCE for licence details.
!===============================================================================
program midpoint
!===============================================================================
!  Compute the midpoint between two points on a sphere.  This use case is common
!  enough to warrant its own program.

   use spherical_geometry, only: azimuth, delta, step, sg_angle_180

   implicit none

   integer, parameter :: r8 = selected_real_kind(15,307)
   integer, parameter :: rs = r8
   real(rs) :: lon1,lat1,lon2,lat2,lonm,latm,a,d
   real(rs), parameter :: d_tol = 1e-8
   integer :: iostat = 0

   if (command_argument_count() > 0) call usage()

   do while (iostat == 0)
      call read_vals()
      if (iostat < 0) exit ! EOF
      d = delta(lon1,lat1,lon2,lat2,degrees=.true.)
      if (abs(180._rs - d) < d_tol) then
         write(0,'(4(a,f0.8),a)') 'midpoint: Warning: points (',lon1,',',lat1, &
            ') and (',lon2,',',lat2,') are antipodal so midpoint isarbitrary'
      endif
      a = azimuth(lon1,lat1,lon2,lat2,degrees=.true.)
      call step(lon1,lat1,a,d/2._rs,lonm,latm,degrees=.true.)
      write(*,'(f13.8,1x,f12.8)') lonm,latm
   enddo

contains
   !===============================================================================
   subroutine read_vals()
   !===============================================================================
      implicit none
      read(*,*,iostat=iostat) lon1,lat1,lon2,lat2
      lon1 = sg_angle_180(lon1)
      lon2 = sg_angle_180(lon2)
      if (iostat > 0) then
         write(0,'(a)') 'midpoint: Error: problem reading lon1,lat1,lon2,lat2 from stdin'
         stop
      endif
      if (abs(lat1) > 90._rs .or. abs(lat2) > 90._rs) then
         write(0,'(a)') 'midpoint: Error: latitude must be in range -90 to 90 degrees.'
         stop
      endif
   end subroutine read_vals
   !-------------------------------------------------------------------------------

   !===============================================================================
   subroutine usage()
   !===============================================================================
      implicit none
      write(0,'(a)') 'Usage: midpoint < [lon1] [lat1] [lon2] [lat2]',&
                     'Compute the midpoint between two points on a sphere'
      stop
   end subroutine usage
   !-------------------------------------------------------------------------------

end program midpoint
!-------------------------------------------------------------------------------


! Copyright 2017 IBM Corporation
!
! Licensed under the Apache License, Version 2.0 (the "License");
! you may not use this file except in compliance with the License.
! You may obtain a copy of the License at
!
!    http://www.apache.org/licenses/LICENSE-2.0
!
! Unless required by applicable law or agreed to in writing, software
! distributed under the License is distributed on an "AS IS" BASIS,
! WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
! See the License for the specific language governing permissions and
! limitations under the License.

      PROGRAM CMPLXD
        IMPLICIT COMPLEX(X)
        PARAMETER (PI = 3.141592653589793, XJ = (0, 1))
        DO 1, I = 0, 7
          X = EXP(XJ * I * PI / 4)
          IF (AIMAG(X).LT.0) THEN
            PRINT 2, 'e**(j*', I, '*pi/4) = ', REAL(X), ' - j',-AIMAG(X)
          ELSE
            PRINT 2, 'e**(j*', I, '*pi/4) = ', REAL(X), ' + j', AIMAG(X)
          END IF
    2     FORMAT (A, I1, A, F10.7, A, F9.7)
    1     CONTINUE
        STOP
      END


c     Program DRSPOLZ
c>> 2009-10-28 DRZPOLZ Krogh Mods to get comples used in single prec.
c>> 1996-07-09 DRZPOLZ Krogh Set for deriving single precision C vers.
c>> 1994-08-09 DRSPOLZ WVS Remove '0' in format
c>> 1992-03-06 DRSPOLZ CLL
c>> 1987-12-09 DRSPOLZ  Lawson  Initial Code.
c Conversion should only be done from "D" to "S" for processing to C.
c--S replaces "?": DR?POLZ, ?POLZ
c     Demonstration driver for SPOLZ.
c     ------------------------------------------------------------------
      real             A1(4), A2(6), H(25)

c++ CODE for .D. | .C. is inactive
C      real             Z1(2,3), Z2(2,5)
c++ CODE for .S. & ~.C. is active
      complex       Z1(3), Z2(5)
c++ END
      integer N1, N2, IERR
c++ CODE for ~.C. is active
      integer I, k
c++ CODE for .C. is inactive
c%%    long int i, k;
c++ END
c
      data A1 / 1.E0, -4.E0, 1.E0, -4.E0 /
      data A2 / 1.E0, -15.E0, 85.E0, -225.E0, 274.E0, -120.E0 /
c     ------------------------------------------------------------------
      N1 = 3
      N2 = 5
c
c++ CODE for ~.C. is active
  100 format(' ','Degree =',I2/' ', 'Coefficients =',(T20,4(F10.4,1X)))
  200 format(' ','Roots ='/(2(1X,'(',1X,F8.5,',',1X,F8.5,2X,')':2X)))
  300 format(//' ')
      print 100, N1, (A1(I),I=1,4)
c++ CODE for .C. is inactive
c%%   printf( " Degree =%2ld\n Coefficients =      ", n1 );
c%%   for (i = 0; i < 4; i++) printf( "%10.4f", a1[i] );
c++ End
      call SPOLZ(A1,N1,Z1,H,IERR)
c++ CODE for .D. & ~.C. is inactive
C      print 200, ((Z1(K,I),K=1,2),I=1,3)
c++ CODE for .S. & ~.C. is active
      print 200, (Z1(I),I=1,3)
c++ CODE for ~.C. is active
      print 300
      print 100, N2, (A2(I),I=1,6)
c++ CODE for .C. is inactive
c%%   printf( "\n Roots =\n" );
c%%   for (i = 0; i < 3; i+=2) {
c%%      printf( " ( %8.5f, %8.5f  )", z1[i][0],z1[i][1] );
c%%      if (i<2) printf( " ( %8.5f, %8.5f  )", z1[i+1][0],z1[i+1][1] );
c%%      printf( "\n" );}
c%%   printf( "\n\n \n Degree =%2ld\n Coefficients =      ", n2 );
c%%   for (i = 0; i < 6; i+=4) {
c%%      for (k = i ; k < (i < 2 ? i + 4 : 6); k++)
c%%         printf( "%10.4f", a2[k] );
c%%         if (i < 4) printf( "\n                     " );}
c++ End
      call SPOLZ(A2,N2,Z2,H,IERR)
c++ CODE for .D. & ~.C. is inactive
C      print 200,((Z2(K,I),K=1,2),I=1,5)
c++ CODE for .S. & ~.C. is active
      print 200,(Z2(I),I=1,5)
c++ CODE for .C. is inactive
c%%   printf( "\n Roots =\n" );
c%%   for (i = 0; i < 5; i+=2) {
c%%       printf( " ( %8.5f, %8.5f  )", z2[i][0],z2[i][1] );
c%%       if (i<4) printf(" ( %8.5f, %8.5f  )", z2[i+1][0],z2[i+1][1]);
c%%       printf( "\n" );}
c%%   printf( "\n" );
c++ END
      end


!
!              Example Source No.5
!
!      Author: XCell
!      Date  : 2021-09-19 00 : 57 (UTC + 09:00)
!
!      Description: example source for Runge-Kutta Method
!

program example_05
    use CottonCandy
    Real :: x, y
    x = 0
    y = 1
    call Runge_Kutta_Method(f, 1.0, 0.001, 10)
    Open(19, FILE="real_ode_result.dat", status="NEW")
    Do 14, I=0, 10000
        x = x + 0.001
        y = 2.5 * exp(-2*x) - 1.5 * exp(-4*x)
        Write(19, *) x, y
14  continue
    Close(19)
contains
    function f(t, y) result(val)
        Real :: t, y, val
        val = 3 * exp(-4 * t) - 2 * y
    end function f
end program example_05


!> Performs one of the matrix-vector operations
!>
!>    y := alpha*A*x + beta*y,   or   y := alpha*A**T*x + beta*y,
!>
!> where alpha and beta are scalars, x and y are vectors and A is an
!> m by n matrix.
module wrapped_gemv
  implicit none
  private

  public :: sp, dp, gemv

  integer, parameter :: sp = selected_real_kind(6)
  integer, parameter :: dp = selected_real_kind(15)

  interface gemv
    module procedure :: wrap_sgemv
    module procedure :: wrap_dgemv
  end interface gemv

  interface blas_gemv
    subroutine sgemv(trans, m, n, alpha, a, lda, x, incx, beta, y, incy)
      import :: sp
      real(sp), intent(in) :: a(lda, *)
      real(sp), intent(in) :: x(*)
      real(sp), intent(inout) :: y(*)
      real(sp), intent(in) :: alpha
      real(sp), intent(in) :: beta
      character(len=1), intent(in) :: trans
      integer, intent(in) :: incx
      integer, intent(in) :: incy
      integer, intent(in) :: m
      integer, intent(in) :: n
      integer, intent(in) :: lda
    end subroutine sgemv
    subroutine dgemv(trans, m, n, alpha, a, lda, x, incx, beta, y, incy)
      import :: dp
      real(dp), intent(in) :: a(lda, *)
      real(dp), intent(in) :: x(*)
      real(dp), intent(inout) :: y(*)
      real(dp), intent(in) :: alpha
      real(dp), intent(in) :: beta
      character(len=1), intent(in) :: trans
      integer, intent(in) :: incx
      integer, intent(in) :: incy
      integer, intent(in) :: m
      integer, intent(in) :: n
      integer, intent(in) :: lda
    end subroutine dgemv
  end interface blas_gemv

contains

  subroutine wrap_sgemv(amat, xvec, yvec, alpha, beta, trans)
    real(sp), intent(in) :: amat(:, :)
    real(sp), intent(in) :: xvec(:)
    real(sp), intent(inout) :: yvec(:)
    real(sp), intent(in), optional :: alpha
    real(sp), intent(in), optional :: beta
    character(len=1), intent(in), optional :: trans
    real(sp) :: a, b
    character(len=1) :: tra
    integer :: incx, incy, m, n, lda
    if (present(alpha)) then
      a = alpha
    else
      a = 1.0_sp
    end if
    if (present(beta)) then
      b = beta
    else
      b = 0
    end if
    if (present(trans)) then
      tra = trans
    else
      tra = 'n'
    end if
    incx = 1
    incy = 1
    lda = max(1, size(amat, 1))
    m = size(amat, 1)
    n = size(amat, 2)
    call blas_gemv(tra, m, n, a, amat, lda, xvec, incx, b, yvec, incy)
  end subroutine wrap_sgemv

  subroutine wrap_dgemv(amat, xvec, yvec, alpha, beta, trans)
    real(dp), intent(in) :: amat(:, :)
    real(dp), intent(in) :: xvec(:)
    real(dp), intent(inout) :: yvec(:)
    real(dp), intent(in), optional :: alpha
    real(dp), intent(in), optional :: beta
    character(len=1), intent(in), optional :: trans
    real(dp) :: a, b
    character(len=1) :: tra
    integer :: incx, incy, m, n, lda
    if (present(alpha)) then
      a = alpha
    else
      a = 1.0_dp
    end if
    if (present(beta)) then
      b = beta
    else
      b = 0
    end if
    if (present(trans)) then
      tra = trans
    else
      tra = 'n'
    end if
    incx = 1
    incy = 1
    lda = max(1, size(amat, 1))
    m = size(amat, 1)
    n = size(amat, 2)
    call blas_gemv(tra, m, n, a, amat, lda, xvec, incx, b, yvec, incy)
  end subroutine wrap_dgemv

end module wrapped_gemv


module math
implicit none
    double precision, parameter :: pi = acos(-1d0)
    complex*16, parameter :: ci = dcmplx(0.d0,1.d0)
    double precision, parameter :: sq2 = sqrt(2d0)
    double precision, parameter :: sq2pi = sqrt(2d0*pi)
    double precision, parameter :: two_sq3 = 2d0*sqrt(3d0)
    double precision, parameter :: deg = pi/180d0

    integer :: n_integration_cuts = 50
contains
    ! Help-Functions
    subroutine lognormal(x, mu, sig, lognormalval)
        double precision, intent(in) :: x, mu, sig
        double precision, intent(out) :: lognormalval
        lognormalval =&
            1d0 / (sq2pi*sig*x) * dexp(-0.5d0*(dlog(x/mu) / sig)**2)
    end subroutine lognormal

    subroutine gaussian(x, mu, sig, gaussianval)
        double precision, intent(in) :: x, mu, sig
        double precision, intent(out) :: gaussianval
        gaussianval =&
            1d0 / (sq2pi*sig) * dexp(-0.5d0*((x-mu) / sig )**2)
    end subroutine gaussian

    subroutine equipartition(x, mu, sig, equipartition_val)
        double precision, intent(in) :: x, mu, sig
        double precision, intent(out) :: equipartition_val
        equipartition_val =&
                    1d0/(sig*two_sq3)
    end subroutine equipartition

    subroutine one(x, mu, sig, oneval)
        double precision, intent(in) :: x, mu, sig
        double precision, intent(out) :: oneval
        oneval = 1d0
    end subroutine one

    subroutine integrate_prob_distribution(pmu, psig, pmin, pmax, prob_dist,&
                                           probability)
        double precision, intent(in) :: pmu, psig, pmin, pmax
        external prob_dist
        double precision, intent(out) :: probability

        double precision :: abserr
        integer :: neval, ier, last
        integer, dimension(50) :: iwork
        double precision, dimension(200) :: work

        interface
            subroutine prob_dist(x, mu, sig, y)
                double precision, intent(in) :: x, mu, sig
                double precision, intent(out) :: y
            end subroutine
        end interface

        if (psig > 0d0) then
            call dqag (probability_function, pmin, pmax, 0d0, 1d-10, 6,&
                    probability, abserr, neval, ier, n_integration_cuts,&
                    4*n_integration_cuts, last, iwork, work)
        else
            probability = 1d0
        end if

        contains
            double precision function probability_function(x)
                double precision :: x
                call prob_dist(x, pmu, psig, probability_function)
            end function probability_function

    end subroutine integrate_prob_distribution

    subroutine integrate_size_distribution(qval, p, Np, &
                pint, pmin, pmax, psig, &
                ff_function, prob_dist, ff_intensity)
        double precision, intent(in) :: qval
        double precision, dimension(Np), intent(in) :: p
        integer, intent(in) :: Np, pint
        double precision, intent(in) :: pmin, pmax, psig
        external ff_function
        external prob_dist
        double precision, intent(out) :: ff_intensity

        double precision :: abserr
        integer :: neval, ier, last
        integer, dimension(50) :: iwork
        double precision, dimension(200) :: work

        interface
            double precision function ff_function(q, p, Np)
                double precision, intent(in) :: q
                double precision, dimension(Np), intent(in) :: p
                integer, intent(in) :: Np
            end function

            subroutine prob_dist(x, mu, sig, y)
                double precision, intent(in) :: x, mu, sig
                double precision, intent(out) :: y
            end subroutine
        end interface

        if (psig > 0d0) then
            call dqag (size_dist_function, pmin, pmax, 0d0, 1d-10, 6,&
                    ff_intensity, abserr, neval, ier, n_integration_cuts,&
                    4*n_integration_cuts, last, iwork, work)
        else
            ff_intensity = ff_function(qval, p, Np)
        end if

        contains
            double precision function size_dist_function(x)
                double precision :: x
                double precision, dimension(Np) :: hp
                double precision :: prob, formfactor
                hp = p
                hp(pint) = x
                formfactor = ff_function(qval, hp, Np)
                call prob_dist(x, p(pint), psig, prob)

                size_dist_function = formfactor * prob
            end function size_dist_function
    end subroutine integrate_size_distribution

    subroutine integrate_two_size_distributions(qval, p, Np, &
                pint1, pmin1, pmax1, psig1, &
                pint2, pmin2, pmax2, psig2, &
                ff_function, prob_dist1, prob_dist2, ff_intensity)
        double precision, intent(in) :: qval
        double precision, dimension(Np), intent(in) :: p
        integer, intent(in) :: Np, pint1, pint2
        double precision, intent(in) :: pmin1, pmax1, psig1
        double precision, intent(in) :: pmin2, pmax2, psig2
        external ff_function
        external prob_dist1
        external prob_dist2
        double precision, intent(out) :: ff_intensity

        double precision :: abserr1, abserr2
        integer :: neval1, ier1, last1, neval2, ier2, last2
        integer, dimension(50) :: iwork1, iwork2
        double precision, dimension(200) :: work1, work2
        double precision, dimension(Np) :: help_params

        interface
            double precision function ff_function(q, p, Np)
                double precision, intent(in) :: q
                double precision, dimension(Np), intent(in) :: p
                integer, intent(in) :: Np
            end function

            subroutine prob_dist1(x, mu, sig, y)
                double precision, intent(in) :: x, mu, sig
                double precision, intent(out) :: y
            end subroutine

            subroutine prob_dist2(x, mu, sig, y)
                double precision, intent(in) :: x, mu, sig
                double precision, intent(out) :: y
            end subroutine
        end interface

        help_params = p
        if (psig1 > 0 .AND. psig2 > 0) then
            call dqag(integrate12, pmin1, pmax1, 0d0, 1d-10, 6,&
                    ff_intensity, abserr1, neval1, ier1, n_integration_cuts,&
                    4*n_integration_cuts, last1, iwork1, work1)

        else if (psig1 > 0) then ! means psig2 <= 0
            call dqag(integrate01, pmin1, pmax1, 0d0, 1d-10, 6,&
                    ff_intensity, abserr1, neval1, ier1, n_integration_cuts,&
                    4*n_integration_cuts, last1, iwork1, work1)

        else if (psig2 > 0) then ! means psig1 <= 0
            call dqag(integrate02, pmin2, pmax2, 0d0, 1d-10, 6,&
                    ff_intensity, abserr2, neval2, ier2, n_integration_cuts,&
                    4*n_integration_cuts, last2, iwork2, work2)

        else ! means psig1 and psig2 <= 0
            ff_intensity = ff_function(qval, p, Np)
        end if

        contains
            double precision function integrate12(x)
                double precision :: x
                double precision :: function_value, prob
                help_params(pint1) = x

                call dqag (integrate02, pmin2, pmax2, 0d0, 1d-10, 6,&
                    function_value, abserr2, neval2, ier2, n_integration_cuts,&
                    4*n_integration_cuts, last2, iwork2, work2)
                call prob_dist1(x, p(pint1), psig1, prob)

                integrate12 = function_value * prob
            end function integrate12

            double precision function integrate01(x)
                double precision :: x
                double precision :: function_value, prob
                help_params(pint1) = x

                function_value = ff_function(qval, help_params, Np)
                call prob_dist1(x, p(pint1), psig1, prob)

                integrate01 = function_value * prob
            end function integrate01

            double precision function integrate02(x)
                double precision :: x
                double precision :: function_value, prob
                help_params(pint2) = x

                function_value = ff_function(qval, help_params, Np)
                call prob_dist2(x, p(pint2), psig2, prob)

                integrate02 = function_value * prob
            end function integrate02
    end subroutine integrate_two_size_distributions

    subroutine integrate_three_size_distributions(qval, p, Np, &
                pint1, pmin1, pmax1, psig1, &
                pint2, pmin2, pmax2, psig2, &
                pint3, pmin3, pmax3, psig3, &
                ff_function, prob_dist1, prob_dist2, prob_dist3, ff_intensity)
        double precision, intent(in) :: qval
        double precision, dimension(Np), intent(in) :: p
        integer, intent(in) :: Np, pint1, pint2, pint3
        double precision, intent(in) :: pmin1, pmax1, psig1
        double precision, intent(in) :: pmin2, pmax2, psig2
        double precision, intent(in) :: pmin3, pmax3, psig3
        external ff_function
        external prob_dist1
        external prob_dist2
        external prob_dist3
        double precision, intent(out) :: ff_intensity

        double precision :: abserr1, abserr2, abserr3
        integer :: neval1, ier1, last1, neval2, ier2, last2, neval3, ier3, last3
        integer, dimension(50) :: iwork1, iwork2, iwork3
        double precision, dimension(200) :: work1, work2, work3
        double precision, dimension(Np) :: help_params

        interface
            double precision function ff_function(q, p, Np)
                double precision, intent(in) :: q
                double precision, dimension(Np), intent(in) :: p
                integer, intent(in) :: Np
            end function

            subroutine prob_dist1(x, mu, sig, y)
                double precision, intent(in) :: x, mu, sig
                double precision, intent(out) :: y
            end subroutine

            subroutine prob_dist2(x, mu, sig, y)
                double precision, intent(in) :: x, mu, sig
                double precision, intent(out) :: y
            end subroutine

            subroutine prob_dist3(x, mu, sig, y)
                double precision, intent(in) :: x, mu, sig
                double precision, intent(out) :: y
            end subroutine
        end interface

        help_params = p
        if (psig1 > 0 .AND. psig2 > 0 .AND. psig3 > 0) then
            call dqag(integrate123, pmin1, pmax1, 0d0, 1d-10, 6,&
                    ff_intensity, abserr1, neval1, ier1, n_integration_cuts,&
                    4*n_integration_cuts, last1, iwork1, work1)
        else if (psig1 > 0 .AND. psig2 > 0) then ! means psig3 <= 0
            call dqag(integrate012, pmin1, pmax1, 0d0, 1d-10, 6,&
                    ff_intensity, abserr1, neval1, ier1, n_integration_cuts,&
                    4*n_integration_cuts, last1, iwork1, work1)
        else if (psig2 > 0 .AND. psig3 > 0) then ! means psig1 <= 0
            call dqag(integrate023, pmin2, pmax2, 0d0, 1d-10, 6,&
                    ff_intensity, abserr2, neval2, ier2, n_integration_cuts,&
                    4*n_integration_cuts, last2, iwork2, work2)
        else if (psig1 > 0 .AND. psig3 > 0) then ! means psig2 <= 0
            call dqag(integrate013, pmin1, pmax1, 0d0, 1d-10, 6,&
                    ff_intensity, abserr1, neval1, ier1, n_integration_cuts,&
                    4*n_integration_cuts, last1, iwork1, work1)
        else if (psig1 > 0) then ! means psig2 <= 0 && psig3 <= 0
            call dqag(integrate001, pmin1, pmax1, 0d0, 1d-10, 6,&
                    ff_intensity, abserr1, neval1, ier1, n_integration_cuts,&
                    4*n_integration_cuts, last1, iwork1, work1)
        else if (psig2 > 0) then ! means psig1 <= 0 && psig3 <= 0
            call dqag(integrate002, pmin2, pmax2, 0d0, 1d-10, 6,&
                    ff_intensity, abserr2, neval2, ier2, n_integration_cuts,&
                    4*n_integration_cuts, last2, iwork2, work2)
        else if (psig3 > 0) then ! means psig1 <= 0 && psig2 <= 0
            call dqag(integrate003, pmin3, pmax3, 0d0, 1d-10, 6,&
                    ff_intensity, abserr3, neval3, ier3, n_integration_cuts,&
                    4*n_integration_cuts, last3, iwork3, work3)
        else ! means psig1 && psig2 && psig3 <= 0
            ff_intensity = ff_function(qval, p, Np)
        end if

        contains
            double precision function integrate123(x)
                double precision :: x
                double precision :: function_value, prob
                help_params(pint1) = x

                call dqag (integrate023, pmin2, pmax2, 0d0, 1d-10, 6,&
                    function_value, abserr2, neval2, ier2, n_integration_cuts,&
                    4*n_integration_cuts, last2, iwork2, work2)
                call prob_dist1(x, p(pint1), psig1, prob)

                integrate123 = function_value * prob
            end function integrate123

            double precision function integrate023(x)
                double precision :: x
                double precision :: function_value, prob
                help_params(pint2) = x

                call dqag (integrate003, pmin3, pmax3, 0d0, 1d-10, 6,&
                    function_value, abserr3, neval3, ier3, n_integration_cuts,&
                    4*n_integration_cuts, last3, iwork3, work3)
                call prob_dist2(x, p(pint2), psig2, prob)

                integrate023 = function_value * prob
            end function integrate023

            double precision function integrate013(x)
                double precision :: x
                double precision :: function_value, prob
                help_params(pint1) = x

                call dqag (integrate003, pmin3, pmax3, 0d0, 1d-10, 6,&
                    function_value, abserr3, neval3, ier3, n_integration_cuts,&
                    4*n_integration_cuts, last3, iwork3, work3)
                call prob_dist1(x, p(pint1), psig1, prob)

                integrate013 = function_value * prob
            end function integrate013

            double precision function integrate012(x)
                double precision :: x
                double precision :: function_value, prob
                help_params(pint1) = x

                call dqag (integrate002, pmin2, pmax2, 0d0, 1d-10, 6,&
                    function_value, abserr2, neval2, ier2, n_integration_cuts,&
                    4*n_integration_cuts, last2, iwork2, work2)
                call prob_dist1(x, p(pint1), psig1, prob)

                integrate012 = function_value * prob
            end function integrate012

            double precision function integrate001(x)
                double precision :: x
                double precision :: function_value, prob
                help_params(pint1) = x

                function_value = ff_function(qval, help_params, Np)
                call prob_dist1(x, p(pint1), psig1, prob)

                integrate001 = function_value * prob
            end function integrate001

            double precision function integrate002(x)
                double precision :: x
                double precision :: function_value, prob
                help_params(pint2) = x

                function_value = ff_function(qval, help_params, Np)
                call prob_dist2(x, p(pint2), psig2, prob)

                integrate002 = function_value * prob
            end function integrate002

            double precision function integrate003(x)
                double precision :: x
                double precision :: function_value, prob
                help_params(pint3) = x

                function_value = ff_function(qval, help_params, Np)
                call prob_dist3(x, p(pint3), psig3, prob)

                integrate003 = function_value * prob
            end function integrate003
    end subroutine integrate_three_size_distributions

    subroutine twodim_integral_variable_bounds(xmin, xmax, &
                                               ymin_func, ymax_func, &
                                               p, Np, &
                                               integrand_func, integrand_res)
        double precision, intent(in) :: xmin, xmax
        external ymin_func
        external ymax_func
        double precision, dimension(Np), intent(in) :: p
        integer, intent(in) :: Np
        external integrand_func
        double precision, intent(out) :: integrand_res

        double precision :: abserr1, abserr2
        integer :: neval1, ier1, last1, neval2, ier2, last2
        integer, dimension(50) :: iwork1, iwork2
        double precision, dimension(200) :: work1, work2
        double precision, dimension(Np+1) :: help_params

        interface
            double precision function ymin_func(x, p, Np)
                double precision, intent(in) :: x
                double precision, dimension(Np), intent(in) :: p
                integer, intent(in) :: Np
            end function

            double precision function ymax_func(x, p, Np)
                double precision, intent(in) :: x
                double precision, dimension(Np), intent(in) :: p
                integer, intent(in) :: Np
            end function

            double precision function integrand_func(x, y, p, Np)
                double precision, intent(in) :: x, y
                double precision, dimension(Np), intent(in) :: p
                integer, intent(in) :: Np
            end function
        end interface

        help_params(1:Np) = p
        help_params(Np+1) = 0d0
        call dqag(integrate12, xmin, xmax, 0d0, 1d-10, 6,&
                integrand_res, abserr1, neval1, ier1, n_integration_cuts,&
                4*n_integration_cuts, last1,&
                iwork1, work1)

        contains
            double precision function integrate12(x)
                double precision :: x
                double precision :: ymin, ymax
                ymin = ymin_func(x, p, Np)
                ymax = ymax_func(x, p, Np)
                help_params(Np+1) = x
                call dqag (integrate02, ymin, ymax, 0d0, 1d-10, 6,&
                    integrate12, abserr2, neval2, ier2, n_integration_cuts,&
                    4*n_integration_cuts, last2,&
                    iwork2, work2)
            end function integrate12

            double precision function integrate02(y)
                double precision :: y
                double precision :: x

                x = help_params(Np+1)
                integrate02 = integrand_func(x, y, p, Np)
            end function integrate02
    end subroutine twodim_integral_variable_bounds

    subroutine get_cutoff_gaussian(mu, sig, left_cutoff, right_cutoff)
        double precision, intent(in) :: mu, sig
        double precision, intent(out) :: left_cutoff, right_cutoff

        if (sig > 0d0) then
            left_cutoff = mu - 5d0*sig
            right_cutoff = mu + 5d0*sig
        else
            left_cutoff = 0d0
            right_cutoff = 0d0
        end if
    end subroutine get_cutoff_gaussian

    subroutine get_cutoff_lognormal(mu, sig, left_cutoff, right_cutoff)
        double precision, intent(in) :: mu, sig
        double precision, intent(out) :: left_cutoff, right_cutoff

        double precision :: prob_integrated

        double precision :: abserr
        integer :: neval, ier, last
        integer, dimension(50) :: iwork
        double precision, dimension(200) :: work

        if (sig > 0d0) then
            left_cutoff = mu*exp(-5*sig)
            right_cutoff = mu*exp(-sig**2) + sig*mu
            prob_integrated = 0d0
            ! Shift right cutoff of integral, until lognormal distribution
            ! integrates to 1 with 1d-6 tolerance.
            do while (abs(prob_integrated-1d0) > 1d-6)
                call dqag(lognormal_function, left_cutoff, right_cutoff, &
                          0d0, 1d-10, 6, prob_integrated, abserr, neval, &
                          ier, n_integration_cuts, 4*n_integration_cuts, last, iwork, work)
                right_cutoff = right_cutoff + sig*mu
            end do
        else
            left_cutoff = 0d0
            right_cutoff = 0d0
        end if
        contains
            double precision function lognormal_function(x)
                double precision :: x
                call lognormal(x, mu, sig, lognormal_function)
            end function lognormal_function
    end subroutine get_cutoff_lognormal

    subroutine mean(x, Nx, meanx)
        double precision, dimension(Nx), intent(in) :: x
        integer, intent(in) :: Nx
        double precision, intent(out) :: meanx

        meanx = sum(x) / Nx
    end subroutine mean

    subroutine simple_linear_fit(x, y, Nx, slope, intercept)
        double precision, dimension(Nx), intent(in) :: x, y
        integer, intent(in) :: Nx
        double precision, intent(out) :: slope, intercept

        double precision :: mean_xy, mean_x, mean_y, mean_x2

        call mean(x, Nx, mean_x)
        call mean(y, Nx, mean_y)
        call mean(x*y, Nx, mean_xy)
        call mean(x*x, Nx, mean_x2)

        slope = (mean_xy-mean_x*mean_y) / (mean_x2-mean_x**2)
        intercept = mean_y - slope*mean_x
    end subroutine simple_linear_fit

    subroutine get_interpolated_value(x, y, xval, Nx, yval)
        double precision, dimension(Nx), intent(in) :: x, y
        double precision, intent(in) :: xval
        integer, intent(in) :: Nx
        double precision, intent(out) :: yval

        integer :: ix
        double precision :: x_left, x_right, y_left, y_right

        if (xval <= x(1)) then
            yval = (y(2)-y(1))*(xval-x(1))/(x(2)-x(1)) + y(1)
            return
        end if

        if (xval >= x(Nx)) then
            yval = (y(Nx)-y(Nx-1))*(xval-x(Nx))/(x(Nx)-x(Nx-1)) + y(Nx)
            return
        end if

        do ix=1, Nx
            if (x(ix) > xval) then
                x_left = x(ix-1)
                x_right = x(ix)
                y_left = y(ix-1)
                y_right = y(ix)
                exit
            end if
        end do
        yval = (y_right-y_left)*(xval-x_right)/(x_right-x_left) + y_right
    end subroutine get_interpolated_value

    subroutine resolution_smear(q, I, sigQ, Nq, Ismear)
        double precision, dimension(Nq), intent(in) :: q, I, sigQ
        integer, intent(in) :: Nq
        double precision, dimension(Nq), intent(out) :: Ismear

        integer :: iq, jq, iq_tilde, iq_low, iq_high
        double precision :: cq, csigq, cqtilde, prob_qtilde, Itilde
        double precision :: cqtilde_before, cqtilde_next
        double precision :: sum_prob_qtilde, sum_Itilde

        double precision :: q_spacing_low, slope_low, intercept_low
        double precision :: q_spacing_high, slope_high, intercept_high
        double precision :: cqhelp
        if (Nq .eq. 1) then
            Ismear = I
            return
        end if

        q_spacing_low = q(2) - q(1)
        slope_low = (I(2) - I(1)) / q_spacing_low
        intercept_low = I(1)-slope_low*q(1)

        q_spacing_high = q(Nq) - q(Nq-1)
        slope_high = (I(Nq) - I(Nq-1)) / q_spacing_high
        intercept_high = I(Nq) - slope_high*q(Nq)

        do iq=1, Nq
            csigq = sigQ(iq)
            if (csigq <= 0d0) then
                Ismear(iq) = I(iq)
                cycle
            end if

            cq = q(iq)
            iq_low = iq
            cqhelp = cq
            do while((cqhelp > cq-3*csigq))
                iq_low = iq_low - 1
                if (iq_low >= 1) then
                    cqhelp = q(iq_low)
                else
                    cqhelp = q(1) + (iq_low-1)*q_spacing_low
                end if
            end do

            iq_high = iq
            cqhelp = cq
            do while((cqhelp < cq+3*csigq))
                iq_high = iq_high + 1
                if (iq_high <= Nq) then
                    cqhelp = q(iq_high)
                else
                    cqhelp = q(Nq) + (iq_high-Nq)*q_spacing_high
                end if
            end do

            ! Do integration from I(q_low) to I(q_high) with gaussian probability
            ! Extrapolate function linearly outside of accessible region
            if(iq_low < 1) then
                cqtilde = q(1) + (iq_low-1) * q_spacing_low
                cqtilde_next = q(1) + iq_low * q_spacing_low
                Itilde = slope_low*cqtilde + intercept_low
            else
                cqtilde = q(iq_low)
                cqtilde_next = q(iq_low+1)
                Itilde = I(iq_low)
            end if

            call gaussian(cq, cqtilde, csigq, prob_qtilde)
            sum_prob_qtilde = prob_qtilde*(cqtilde_next-cqtilde)
            sum_Itilde = prob_qtilde*Itilde*(cqtilde_next-cqtilde)

            do jq=iq_low+1, iq_high-1
                cqtilde_before = cqtilde
                cqtilde = cqtilde_next

                if(jq <= 0) then
                    cqtilde_next = q(1) + jq * q_spacing_low
                    Itilde = slope_low*cqtilde + intercept_low
                else if (jq >= Nq) then
                    cqtilde_next = q(Nq) + (jq-Nq+1) * q_spacing_high
                    Itilde = slope_high*cqtilde + intercept_high
                else
                    cqtilde_next = q(jq+1)
                    Itilde = I(jq)
                end if

                if (Itilde < 0d0) cycle
                call gaussian(cq, cqtilde, csigq, prob_qtilde)
                sum_prob_qtilde = sum_prob_qtilde + prob_qtilde*&
                                                (cqtilde_next-cqtilde_before)
                sum_Itilde = sum_Itilde + prob_qtilde*Itilde*&
                                                (cqtilde_next-cqtilde_before)
            end do

            cqtilde_before = cqtilde
            cqtilde = cqtilde_next

            if(iq_high >= Nq) then
                Itilde = slope_high*cqtilde+intercept_high
            else
                Itilde = I(iq_high)
            end if
            call gaussian(cq, cqtilde, csigq, prob_qtilde)
            sum_prob_qtilde = sum_prob_qtilde + prob_qtilde*&
                                            (cqtilde_next-cqtilde)
            sum_Itilde = sum_Itilde + prob_qtilde*Itilde*&
                                            (cqtilde_next-cqtilde)

            Ismear(iq) = sum_Itilde / sum_prob_qtilde
        end do
    end subroutine resolution_smear

    subroutine resolution_smear_interpolating(q, I, sigQ, Nq, Ismear)
        double precision, dimension(Nq), intent(in) :: q, I, sigQ
        integer, intent(in) :: Nq
        double precision, dimension(Nq), intent(out) :: Ismear

        integer :: iq, jq, iq_tilde, iq_low, iq_high
        double precision :: cq, csigq, cqtilde, prob_qtilde, Itilde
        double precision :: cqtilde_before, cqtilde_next
        double precision :: sum_prob_qtilde, sum_Itilde

        double precision :: q_spacing
        double precision :: cq_running, q_low_value, q_high_value
        double precision :: qlow_steps, qhigh_steps
        if (Nq .eq. 1) then
            Ismear = I
            return
        end if

        call mean(q(2:Nq) - q(1:Nq-1), Nq-1, q_spacing)

        do iq=1, Nq
            csigq = sigQ(iq)
            if (csigq <= 0d0) then
                Ismear(iq) = I(iq)
                cycle
            end if
            cq = q(iq)
            cq_running = cq
            iq_low = iq

            do while((cq_running > cq-3*csigq))
                iq_low = iq_low - 1
                cq_running = cq - (iq-iq_low)*q_spacing
            end do

            iq_high = iq
            cq_running = cq
            do while((cq_running < cq+3*csigq))
                iq_high = iq_high + 1
                cq_running = cq + (iq_high-iq)*q_spacing
            end do

            ! Do integration from I(q_low) to I(q_high) with gaussian probability
            ! Interpolate values from given arrays
            ! Extrapolate function linearly outside of accessible region
            cqtilde = cq - (iq-iq_low) * q_spacing
            cqtilde_next = cqtilde + q_spacing
            call get_interpolated_value(q, I, cqtilde, Nq, Itilde)
            call gaussian(cq, cqtilde, csigq, prob_qtilde)
            sum_prob_qtilde = prob_qtilde*(cqtilde_next-cqtilde)
            sum_Itilde = prob_qtilde*Itilde*(cqtilde_next-cqtilde)

            do jq=iq_low+1, iq_high-1
                cqtilde_before = cqtilde
                cqtilde = cqtilde_next
                cqtilde_next = cqtilde + q_spacing
                call get_interpolated_value(q, I, cqtilde, Nq, Itilde)
                call gaussian(cq, cqtilde, csigq, prob_qtilde)
                sum_prob_qtilde = sum_prob_qtilde + prob_qtilde*&
                                                (cqtilde_next-cqtilde_before)
                sum_Itilde = sum_Itilde + prob_qtilde*Itilde*&
                                                (cqtilde_next-cqtilde_before)
            end do

            cqtilde_before = cqtilde
            cqtilde = cqtilde_next
            call get_interpolated_value(q, I, cqtilde, Nq, Itilde)
            call gaussian(cq, cqtilde, csigq, prob_qtilde)
            sum_prob_qtilde = sum_prob_qtilde + prob_qtilde*&
                                            (cqtilde_next-cqtilde)
            sum_Itilde = sum_Itilde + prob_qtilde*Itilde*&
                                            (cqtilde_next-cqtilde)
            Ismear(iq) = sum_Itilde / sum_prob_qtilde
        end do
    end subroutine resolution_smear_interpolating

    subroutine angle_correct(q, thoffset, wavelength, Nq, qcorr)
        integer, intent(in):: Nq
        double precision, intent(in), dimension(Nq) :: q
        double precision, intent(in) :: thoffset, wavelength
        double precision, intent(out), dimension(Nq) :: qcorr

        integer :: iq
        do iq=1, Nq
            qcorr(iq) = 4d0*pi/wavelength * sin(asin(wavelength*q(iq)/4d0/pi) - &
                    thoffset*deg)
        end do
    end subroutine angle_correct

    subroutine footprint_correct(q, reflin, samplelen, beamwidth, &
            wavelength, Nq, reflcorr)
        double precision, intent(in), dimension(Nq) :: q, reflin
        double precision, intent(in) :: samplelen, beamwidth, wavelength
        integer, intent(in) :: Nq
        double precision, intent(out), dimension(Nq) :: reflcorr

        double precision :: sinth, sinthb
        integer :: iq
        sinthb = beamwidth/samplelen ! assume uniform beam profile
        do iq=1, Nq
            sinth = q(iq)*wavelength/(4d0*pi)
            if (sinth < sinthb) then
                reflcorr(iq) = reflin(iq)*sinth/sinthb
            else
                reflcorr(iq) = reflin(iq) !*erf(samplelen/beamwidth*sinth/2d0/sq2)
            end if
        end do
    end subroutine footprint_correct

    double precision function trapz_uniform(y, dx, Ny)
        implicit none
        integer, intent(in) :: Ny
        double precision, intent(in), dimension(Ny) :: y
        double precision, intent(in) :: dx
        integer :: i
        trapz_uniform = 0.5d0*(y(1) + y(Ny))
        do i=2, Ny-1
            trapz_uniform = trapz_uniform + y(i)
        end do
        trapz_uniform = dx * trapz_uniform
    end function trapz_uniform

end module math


module constants

implicit none

integer,parameter :: IIN=40
integer, parameter :: IOUT=41
integer,parameter :: MAX_STRING_LEN= 65535
integer,parameter :: MAX_KERNEL_NUM=20
integer,parameter :: MAX_FILENAME_LEN=65535
integer,parameter :: MAX_LINES=100000000
integer,parameter :: MAX_MISFIT_TYPE=10
integer, parameter :: SIZE_REAL=4
integer, parameter :: SIZE_DOUBLE=8
integer, parameter :: CUSTOM_REAL=SIZE_REAL
integer, parameter :: CUSTOM_COMPLEX=2*SIZE_REAL

!===================================================================
! filter parameters for xapiir subroutine (filter type is BP)
real(kind=CUSTOM_REAL), parameter :: TRBDNDW=0.3
real(kind=CUSTOM_REAL), parameter :: APARM=30.0
integer, parameter :: IORD=5
integer, parameter :: PASSES=2

! -------------------------------------------------------------
! array dimensions
! note that some integer arrays (iM,iL,iR) are NWINDOWS * NWINDOWS
! THESE SHOULD PROBABLY BE USER PARAMETERS, SINCE THEY WILL AFFECT
! THE SPEED OF THE PROGRAM (ALTHOUGH NOT THE OUTPUT).
!integer, parameter :: NDIM=10000
integer, parameter :: NWINDOWS=2500

! -------------------------------------------------------------
! miscellaneous - do not modify!
! -------------------------------------------------------------

! mathematical constants
real(kind=CUSTOM_REAL), parameter :: PI=3.1415926535897
real(kind=CUSTOM_REAL), parameter :: E= 2.7182818284590

! filter types
integer, parameter :: HANNING=1
integer, parameter :: HAMMING=2
integer, parameter :: COSINE= 3

! modified constants

! add by YY
! constants
real(kind=CUSTOM_REAL), parameter :: TWOPI=2.0 * PI
complex (CUSTOM_REAL), parameter :: CCI=cmplx(0.,1.)
real(kind=CUSTOM_REAL), parameter :: LARGE_VAL=huge(0.0)
real(kind=CUSTOM_REAL), parameter :: SMALL_VAL=tiny(0.0)
! phase correction control parameters, set this between (PI, 2PI),
! use a higher value for conservative phase wrapping
real(kind=CUSTOM_REAL), parameter :: PHASE_STEP=1.5 * PI
! FFT parameters
integer, parameter :: LNPT=13, NPT=2**LNPT
real(kind=CUSTOM_REAL), parameter :: FORWARD_FFT=1.0
real(kind=CUSTOM_REAL), parameter :: REVERSE_FFT=-1.0
! CUTOFF for phase unwrapping
real(kind=CUSTOM_REAL), parameter :: CUTOFF=PI
! water level for effective spectrum
real(kind=CUSTOM_REAL), parameter :: WTR=0.05
real(kind=CUSTOM_REAL), parameter ::wtr_env=0.05
! water level for mtm
real(kind=CUSTOM_REAL), parameter ::wtr_mtm=1.e-10
! multitaper
real(kind=CUSTOM_REAL), parameter :: mt_threshold=0.9! eigenvalue threshold
!integer, parameter :: MW=10 ! number of segments of uncorrelated frequency points
real(kind=CUSTOM_REAL), parameter :: NW=3
integer, parameter :: NTAPER =int(2*NW-1)
! error estimation
logical :: USE_ERROR_CC=.false.
! minimum error for dt and dlnA
real(kind=CUSTOM_REAL), parameter :: DT_SIGMA_MIN=1.0
real(kind=CUSTOM_REAL), parameter :: DLNA_SIGMA_MIN=0.5
logical :: USE_ERROR_MT=.false.
! taper power
integer :: ipwr_w=10
real(kind=CUSTOM_REAL), parameter :: ipwr_t=10 ! for time-domain cosine taper
! CG orhtogonality threshold for conscutive gradients
real(kind=CUSTOM_REAL), parameter :: CG_threshold=0.1

! WT parameters
integer, parameter :: nvm=6
character(len=MAX_STRING_LEN) :: WT_directory='./WT_basis'

! gradient rho, Vp, Vs dim
integer, parameter :: gdim_rho=3
integer, parameter :: gdim_vp=4
integer, parameter :: gdim_vs=5
! model rho, Vp, Vs dim
integer, parameter :: mdim_rho=4
integer, parameter :: mdim_vp=5
integer, parameter :: mdim_vs=6

! Display
logical :: DISPLAY_DETAILS=.false.
character(len=MAX_STRING_LEN) :: output_dir='OUTPUT_FILES'
! -------------------------------------------------------------

end module constants


!==============================================================================!
  subroutine Calculate_Cell_Centers(grid)
!------------------------------------------------------------------------------!
!   Calculate the cell centers.                                                !
!------------------------------------------------------------------------------!
!----------------------------------[Modules]-----------------------------------!
  use Grid_Mod,  only: Grid_Type
  use Sort_Mod
!------------------------------------------------------------------------------!
  implicit none
!---------------------------------[Arguments]----------------------------------!
  type(Grid_Type) :: grid
!-----------------------------------[Locals]-----------------------------------!
  integer :: c, n
!==============================================================================!

  ! (Re)initialize cell coordinates
  grid % xc(:) = 0.0
  grid % yc(:) = 0.0
  grid % zc(:) = 0.0

  ! Compute them by adding node coordinates and dividing by their number
  do c = 1, grid % n_cells
    do n = 1, grid % cells_n_nodes(c)
      grid % xc(c) = grid % xc(c) + grid % xn(grid % cells_n(n,c))  &
                   / (1.0*grid % cells_n_nodes(c))
      grid % yc(c) = grid % yc(c) + grid % yn(grid % cells_n(n,c))  &
                   / (1.0*grid % cells_n_nodes(c))
      grid % zc(c) = grid % zc(c) + grid % zn(grid % cells_n(n,c))  &
                   / (1.0*grid % cells_n_nodes(c))
    end do
  end do

  print *, '# Cell centers calculated !'

  end subroutine


      subroutine evol_betagd2(n_Lamx,n_beta,np1_Lamx,np1_beta,x,Nx,ck,ep
     &sal,ht,myzero,phys_bdy,res)
      implicit none
      integer i
      integer Nx
      real*8 ck
      real*8 epsal
      real*8 ht
      real*8 myzero
      real*8 n_Lamx(Nx)
      real*8 n_beta(Nx)
      real*8 np1_Lamx(Nx)
      real*8 np1_beta(Nx)
      real*8 x(Nx)
      integer phys_bdy(2)
      real*8 res(Nx)
      real*8 qb
      if (phys_bdy(1) .eq. 1) then
      do i=1, 1, 1
      qb = np1_beta(i) - 0.1D1 * ht * ((-0.1D1 * n_beta(i) + np1_beta(i)
     #) / ht + epsal * (-0.1D1 * n_Lamx(i) + np1_Lamx(i)) / ht + 0.50000
     #00000000000D0 * epsal * ck * np1_Lamx(i) + 0.5000000000000000D0 *
     #epsal * ck * n_Lamx(i))
      res(i)=qb
      end do
      endif
      do i=2, Nx-1, 1
      qb = np1_beta(i) - 0.1D1 * ht * ((-0.1D1 * n_beta(i) + np1_beta(i)
     #) / ht + epsal * (-0.1D1 * n_Lamx(i) + np1_Lamx(i)) / ht + 0.50000
     #00000000000D0 * epsal * ck * np1_Lamx(i) + 0.5000000000000000D0 *
     #epsal * ck * n_Lamx(i))
      res(i)=qb
      end do
      if (phys_bdy(2) .eq. 1) then
      do i=Nx, Nx, 1
      qb = -0.1D1 * myzero * x(i)
      res(i)=qb
      end do
      endif
      END


      module SUB_bicgstab2

	contains

	subroutine bicgstab2 (okprint,l, n, x, rhs, matvec, nonzero, tol,
     &      typestop,mxmv, work, ldw, info, residit, residval)
C
C Simple BiCGstab(\ell) iterative method, \ell <= 2
C By M.A.Botchev, Jan.'98
C report bugs to botchev@cwi.nl or botchev@excite.com
C
C Copyright (c) 1998 by M.A.Botchev
C Permission to copy all or part of this work is granted,
C provided that the copies are not made or distributed
C for resale, and that the copyright notice and this
C notice are retained.
C
C This is the "vanilla" version of BiCGstab(\ell) as described
C in PhD thesis of D.R.Fokkema, Chapter 3.  It includes two enhancements
C to BiCGstab(\ell) proposed by G.Sleijpen and H.van der Vorst in
C 1) G.Sleijpen and H.van der Vorst "Maintaining convergence
C    properties of BiCGstab methods in finite precision arithmetic",
C    Numerical Algorithms, 10, 1995, pp.203-223
C 2) G.Sleijpen and H.van der Vorst "Reliable updated residuals in
C    hybrid BiCG methods", Computing, 56, 1996, pp.141-163
C
C {{ This code based on:
C subroutine bistbl v1.0 1995
C
C Copyright (c) 1995 by D.R. Fokkema.
C Permission to copy all or part of this work is granted,
C provided that the copies are not made or distributed
C for resale, and that the copyright notice and this
C notice are retained.  }}
C
C okprint == (input) LOGICAL. If okprint=.true. residual norm
C            will be printed to *
C l       == (input) INTEGER BiCGstab's dimension <= 2
C            Set l=2 for highly nonsymmetric problems
C n       == (input) INTEGER size of the system to solve
C x       == (input/output) DOUBLE PRECISION array dimension n
C            initial guess on input, solution on output
C rhs     == (input) DOUBLE PRECISION array dimension n
C            right-hand side (rhs) vector
C matvec  == (input) EXTERNAL name of matrix vector subroutine
C            to deliver y:=A*x by CALL matvec(n,x,y)
C nonzero == (input) LOGICAL tells
C            BiCGstab(\ell) if initial guess in x is zero or not.
C            If nonzero is .FALSE., one MATVEC call is saved.
C tol     == (input/output) DOUBLE PRECISION tolerance for all possible
C            stopping criteria (see the 'typestop' parameter)
C            On output, if info=0 or 1, tol is actually achieved
C            residual reduction or whatever (see the 'typestop' parameter)
C typestop== (input) CHARACTER*3 stopping criterion (||.|| denotes
C            the 2-norm):
C            typestop='rel' -- relative stopping crit.: ||res|| < tol*||res0||
C            typestop='abs' -- absolute stopping crit.: ||res||<tol
C            typestop='max' -- maximum  stopping crit.: max(abs(res))<tol
C NOTE(for typestop='rel' and 'abs'): To save computational work, the value of
C            residual norm used to check the convergence inside the main iterative
C            loop is computed from
C            projections, i.e. it can be smaller than the true residual norm
C            (it may happen when e.g. the 'matrix-free' approach is used).
C            Thus, it is possible that the true residual does NOT satisfy
C            the stopping criterion ('rel' or 'abs').
C            The true residual norm (or residual reduction) is reported on
C            output in parameter TOL -- this can be changed to save 1 MATVEC
C            (see comments at the end of the subroutine)
C mxmv   ==  (input/output) INTEGER.  On input: maximum number of matrix
C            vector multiplications allowed to be done.  On output:
C            actual number of matrix vector multiplications done
C work   ==  (workspace) DOUBLE PRECISION array dimension (n,2*l+5))
C ldw    ==  (input) INTEGER size of work, i.e. ldw >= n*(2*l+5)
C info   ==  (output) INTEGER.  info = 0 in case of normal computations
C            and
C            info = -m (<0) - means paramater number m has an illegal value
C            info = 1 - means no convergence achieved (stopping criterion
C            is not fulfilled)
C            info = 2 - means breakdown of the algorithm (try to enlarge
C            parameter l=\ell to get rid of this)
C ----------------------------------------------------------
      implicit none
      external matvec
      integer l, n, mxmv, ldw, info
      double precision  x(n), rhs(n), tol
      logical   okprint,nonzero
      character(len=3)   typestop
      double precision  work(n,5+2*l)
	integer, optional :: residit(mxmv)
	double precision, optional :: residval(mxmv)
C     -----------------------------------------
      integer   lmax
      parameter(lmax=2)
      double precision rwork(lmax+1,3+2*(lmax+1))

      logical GoOn, rcmp, xpdt
      integer ii, i1, jj, kk, nmv, ppp
      double precision alpha,beta,hatgamma,kappa0, kappal,maxval1,
     &     mxnrmr,mxnrmx,omega,rho0,rho1,rnrm0,rnrm,rnrmMax,
     &     sigma,sum1,varrho
      integer z, zz, y0, yl, y
      integer rr, r, u, xp, bp

      double precision    zero, one, delta
      parameter(zero=0d0,one=1d0,delta=1d-2)

      info = 0
      ![waw]
	ppp=0 ![waw]

      if (l.gt.lmax .or. l.lt.1) info = -2
      if (tol.le.zero) info = -8
      if (mxmv.lt.0) info = -10

      rr = 1
      r = rr+1
      u = r+(l+1)
      xp = u+(l+1)
      bp = xp+1
      if (bp*n.gt.ldw) info = -12

      z = 1
      zz = z+(l+1)
      y0 = zz+(l+1)
      yl = y0+1
      y = yl+1

      if (info.ne.0) return

C      Initialize first residual
      if (nonzero) then
         call matvec (n, x, work(1,r) )
         do ii=1,n
            work(ii,r) = rhs(ii) - work(ii,r)
         enddo
         nmv = 1
      else
         do ii=1,n
            work(ii,r) = rhs(ii)
         enddo
         nmv = 0
      endif

C     Initialize iteration loop
      sum1 = zero
      do ii=1,n
         work(ii,rr) = work(ii,r)
         work(ii,bp) = work(ii,r)
         work(ii,xp) = x(ii)
         x(ii) = zero
         sum1=sum1+ work(ii,r)**2
      enddo

      rnrm0 = sqrt( sum1 )
      rnrm = rnrm0
      if (typestop.eq.'max') then
         maxval1=zero
         do ii=1,n
            maxval1=max( maxval1, abs( work(ii,r) ) )
         enddo
         rnrmMax = maxval1
      endif

      mxnrmx = rnrm0
      mxnrmr = rnrm0
      rcmp = .false.
      xpdt = .false.

      alpha = zero
      omega = one
      sigma = one
      rho0 =  one

C     Iterate
      if(typestop.eq.'rel')then
         GoOn = rnrm.ge.tol*rnrm0 .and. nmv.lt.mxmv
      else if(typestop.eq.'abs')then
         GoOn = rnrm.ge.tol       .and. nmv.lt.mxmv
      else if(typestop.eq.'max')then
         GoOn = rnrmMax.ge.tol    .and. nmv.lt.mxmv
      else
         info = -9
         return
      end if

      do while (GoOn)
C     =====================
C     --- The BiCG part ---
C     =====================
      	 rho0 = -omega*rho0
      	 do kk=1,l
            sum1 = zero
            do ii=1,n
               sum1=sum1+ work(ii,rr)*work(ii,r+kk-1)
            enddo
            rho1 = sum1

      	    if (rho0.eq.zero) then
      	       info = 2
      	       return
      	    endif
      	    beta = alpha*(rho1/rho0)
      	    rho0 = rho1
      	    do jj=0,kk-1
               do ii=1,n
                  work(ii,u+jj) = work(ii,r+jj) - beta*work(ii,u+jj)
               enddo
      	    enddo

            call matvec(n, work(1,u+kk-1), work(1,u+kk))
      	    nmv = nmv+1

            sum1 = zero
            do ii=1,n
               sum1=sum1+ work(ii,rr)*work(ii,u+kk)
            enddo
            sigma = sum1

      	    if (sigma.eq.zero) then
      	       info = 2
      	       return
      	    endif

      	    alpha = rho1/sigma
            do ii=1,n
               x(ii) = alpha*work(ii,u) + x(ii)
            enddo

      	    do jj=0,kk-1
               do ii=1,n
                  work(ii,r+jj) = -alpha*work(ii,u+jj+1) + work(ii,r+jj)
               enddo
      	    enddo

	    call matvec (n, work(1,r+kk-1), work(1,r+kk))
      	    nmv = nmv+1

            sum1 = zero
            do ii=1,n
               sum1=sum1+ work(ii,r)**2
            enddo
            rnrm = sqrt( sum1 )
            if (typestop.eq.'max') then
               maxval1=zero
               do ii=1,n
                  maxval1=max( maxval1, abs( work(ii,r) ) )
               enddo
               rnrmMax = maxval1
            endif
      	    mxnrmx = max (mxnrmx, rnrm)
      	    mxnrmr = max (mxnrmr, rnrm)
      	 enddo

C     ==================================
C     --- The convex polynomial part ---
C     ==================================

C        Z = R'R
      	 do i1=1,l+1
            do jj=i1-1,l
               sum1 = zero
               do ii=1,n
                  sum1=sum1+ work(ii,r+jj)*work(ii,r+i1-1)
               enddo
               rwork(jj+1,z+i1-1) = sum1
               rwork(z+i1-1,jj+1) = rwork(jj+1,z+i1-1)
            enddo
      	 enddo

         do i1=zz,zz+l
            do ii=1,l+1
               rwork(ii,i1)   = rwork(ii,i1+(z-zz))
            enddo
         enddo
C        tilde r0 and tilde rl (small vectors)

       	 rwork(1,y0) = -one
         rwork(2,y0) = rwork(2,z) / rwork(2,zz+1)
      	 rwork(l+1,y0) = zero

      	 rwork(1,yl) = zero
         rwork(2,yl) = rwork(2,z+l) / rwork(2,zz+1)
      	 rwork(l+1,yl) = -one

C        Convex combination
         do ii=1,l+1
            rwork(ii,y) = zero
         enddo
         do jj=1,l+1
            do ii=1,l+1
               rwork(ii,y) = rwork(ii,y) + rwork(jj,yl)*
     &              rwork(ii,z+jj-1)
            enddo
         enddo
         sum1 = zero
         do ii=1,l+1
            sum1=sum1+ rwork(ii,yl)*rwork(ii,y)
         enddo
         kappal = sqrt( sum1 )

         do ii=1,l+1
            rwork(ii,y) = zero
         enddo
         do jj=1,l+1
            do ii=1,l+1
               rwork(ii,y) = rwork(ii,y) + rwork(jj,y0)*
     &              rwork(ii,z+jj-1)
            enddo
         enddo
         sum1 = zero
         do ii=1,l+1
            sum1=sum1+ rwork(ii,y0)*rwork(ii,y)
         enddo
         kappa0 = sqrt( sum1 )

         sum1 = zero
         do ii=1,l+1
            sum1=sum1+ rwork(ii,yl)*rwork(ii,y)
         enddo
         varrho = sum1
         varrho = varrho / (kappa0*kappal)

      	 hatgamma = sign(1d0,varrho)*max(abs(varrho),7d-1) *
     &        (kappa0/kappal)

         do ii=1,l+1
            rwork(ii,y0) = -hatgamma*rwork(ii,yl) +      rwork(ii,y0)
         enddo

C        Update
      	 omega = rwork(l+1,y0)
         do jj=1,l
            do ii=1,n
               work(ii,u) = work(ii,u) - rwork(1+jj,y0)*work(ii,u+jj)
               x(ii)      = x(ii)      + rwork(1+jj,y0)*work(ii,r+jj-1)
               work(ii,r) = work(ii,r) - rwork(1+jj,y0)*work(ii,r+jj)
            enddo
         enddo

         do ii=1,l+1
            rwork(ii,y) = zero
         enddo
         do jj=1,l+1
            do ii=1,l+1
               rwork(ii,y) = rwork(ii,y) + rwork(jj,y0)*
     &              rwork(ii,z+jj-1)
            enddo
         enddo

         sum1 = zero
         do ii=1,l+1
            sum1=sum1+ rwork(ii,y0)*rwork(ii,y)
         enddo
         rnrm = sqrt( sum1 )

C     ================================
C     --- The reliable update part ---
C     ================================
      	 mxnrmx = max (mxnrmx, rnrm)
      	 mxnrmr = max (mxnrmr, rnrm)
      	 xpdt = (rnrm.lt.delta*rnrm0.and.rnrm0.lt.mxnrmx)
      	 rcmp = ((rnrm.lt.delta*mxnrmr.and.rnrm0.lt.mxnrmr) .or.xpdt)
      	 if (rcmp) then
      	    call matvec (n, x, work(1,r) )
            nmv = nmv + 1
            do ii=1,n
               work(ii,r) = work(ii,bp) - work(ii,r)
            enddo
      	    mxnrmr = rnrm
      	    if (xpdt) then
               do ii=1,n
                  work(ii,xp) = x(ii) + work(ii,xp)
                  x(ii) = zero
                  work(ii,bp) = work(ii,r)
               enddo
      	       mxnrmx = rnrm
      	    endif
      	 endif

         if(typestop.eq.'rel')then
            GoOn = rnrm.ge.tol*rnrm0 .and. nmv.lt.mxmv
            if(okprint) print *, nmv,' ',rnrm/rnrm0

		  ![waw] set the iteration numbers and residuals
		  if( present(residit) .AND. present(residval) )then
		     ppp = ppp+1
		     residit (ppp) = nmv
			 residval(ppp) = rnrm/rnrm0
	      end if ![waw]

         else if(typestop.eq.'abs')then
            GoOn = rnrm.ge.tol       .and. nmv.lt.mxmv
            if(okprint) print *, nmv,' ',rnrm

		  ![waw] output relative residuals
		  if( present(residit) .AND. present(residval) )then
		     ppp = ppp+1
		     residit (ppp) = nmv
			 residval(ppp) = rnrm
	      end if ![waw]

         else if(typestop.eq.'max')then
            maxval1=zero
            do ii=1,n
               maxval1=max(maxval1, abs( work(ii,r) ) )
            enddo
            rnrmMax = maxval1
            GoOn = rnrmMax.ge.tol    .and. nmv.lt.mxmv
            if(okprint) print *, nmv,' ',rnrmMax

		  ![waw] output max residuals
		  if( present(residit) .AND. present(residval) )then
		     ppp = ppp+1
		     residit (ppp) = nmv
			 residval(ppp) = rnrmMax
	      end if ![waw]
         end if

      enddo

C     =========================
C     --- End of iterations ---
C     =========================

      do ii=1,n
         x(ii) = work(ii,xp) + x(ii)
      enddo

C --------------------- One matvec can be saved by commenting out this:
C                       (this is to compute the true residual)
      call matvec (n, x, work(1,r) )
      do ii=1,n
         work(ii,r) = rhs(ii) - work(ii,r)
      enddo

      sum1 = zero
      do ii=1,n
         sum1=sum1+ work(ii,r)**2
      enddo
      rnrm = sqrt( sum1 )
C --------------------- One matvec can be saved by commenting out this^

      if(typestop.eq.'rel')then
         if (rnrm.gt.tol*rnrm0) info = 1
         tol = rnrm/rnrm0
      else if(typestop.eq.'abs')then
         if (rnrm.gt.tol) info = 1
         tol = rnrm
      else if(typestop.eq.'max')then
         if (rnrmMax.gt.tol) info = 1
         tol = rnrmMax
      end if

      mxmv = nmv

      return
      end subroutine

	end module