      module mod_rmbv_csr
! **********************************************************************
!     Author : C. Voemel
!     Date of last modification : 7.7.00
!     Description : PERFORMS MV MULT. WITH MATRIX IN 'CSR'-STORAGE
!                   rmbv = Right Multiplication By Vector: y=Ax
! **********************************************************************
      use representation_of_data
      use properties
      implicit none
      interface rmbv_csr
        module procedure irmbv_csr
        module procedure srmbv_csr
        module procedure drmbv_csr
        module procedure crmbv_csr
        module procedure zrmbv_csr
      end interface
      contains
! **********************************************************************
! **********************************************************************
      subroutine irmbv_csr (mat,x,y,ierr)
      implicit none
      type(ispmat ), pointer :: mat
      integer , dimension(:), intent(in) :: x
      integer , dimension(:), intent(out) :: y
      integer, intent(out) :: ierr
      integer :: m,n,base,ofs,i,pntr
      character :: diag,type,part
      ierr = -1
      m = size(y)
      n = size(x)
      if ((mat%FIDA.ne.'CSR').or.(mat%M.ne.m).or.(mat%K.ne.n)) then
         ierr = blas_error_param
         return
      end if
      call get_infoa(mat%INFOA,'b',base,ierr)
      if (ierr.ne.0) then
         ierr = blas_error_param
         return
      end if
      ofs = 1 - base
      call get_descra(mat%DESCRA,'d',diag,ierr)
      if (ierr.ne.0) then
         ierr = blas_error_param
         return
      end if
      call get_descra(mat%DESCRA,'t',type,ierr)
      if (ierr.ne.0) then
         ierr = blas_error_param
         return
      end if
      call get_descra(mat%DESCRA,'a',part,ierr)
      if (ierr.ne.0) then
         ierr = blas_error_param
         return
      end if
      y = 0
      if (diag.eq.'U') then !process unstored diagonal
         if (m.eq.n) then
            y = x
         else
            ierr = blas_error_param
            return
         end if
      end if
      if ((type.eq.'S').and.(.not.(part.eq.'B')).and.(m.eq.n)) then
         if (part.eq.'U') then
            do i = 1, mat%M
               pntr = mat%pb(i)
               do while(pntr.lt.mat%pe(i))
                  if(i.eq.mat%IA1(pntr + ofs) + ofs) then
                     y(i) = y(i) &
                  + mat%A(pntr + ofs) * x(mat%IA1(pntr + ofs ) + ofs)
                  else if (i.lt.mat%IA1(pntr + ofs) + ofs) then
                     y(i) = y(i) &
                  + mat%A(pntr + ofs) * x(mat%IA1(pntr + ofs ) + ofs)
                     y(mat%IA1(pntr + ofs) + ofs) =  &
              y(mat%IA1(pntr + ofs ) + ofs) + mat%A(pntr + ofs) * x(i)
                  end if
                  pntr = pntr + 1
               end do
            end do
         else
            do i = 1, mat%M
               pntr = mat%pb(i)
               do while(pntr.lt.mat%pe(i))
                  if(i.eq.mat%IA1(pntr + ofs) + ofs) then
                     y(i) = y(i) &
                  + mat%A(pntr + ofs) * x(mat%IA1(pntr + ofs ) + ofs)
                  else if (i.gt.mat%IA1(pntr + ofs) + ofs) then
                     y(i) = y(i) &
                  + mat%A(pntr + ofs) * x(mat%IA1(pntr + ofs ) + ofs)
                     y(mat%IA1(pntr + ofs) + ofs) = &
              y(mat%IA1(pntr + ofs ) + ofs) + mat%A(pntr + ofs) * x(i)
                  end if
                  pntr = pntr + 1
               end do
            end do
         end if
         ierr = 0
      else if((type.eq.'H').and.(.not.(part.eq.'B')).and.(m.eq.n)) then
         if (part.eq.'U') then
            do i = 1, mat%M
               pntr = mat%pb(i)
               do while(pntr.lt.mat%pe(i))
                  if(i.eq.mat%IA1(pntr + ofs) + ofs) then
                     y(i) = y(i) &
                  + mat%A(pntr + ofs) * x(mat%IA1(pntr + ofs ) + ofs)
                  else if (i.lt.mat%IA1(pntr + ofs) + ofs) then
                     y(i) = y(i) &
                  + mat%A(pntr + ofs) * x(mat%IA1(pntr + ofs ) + ofs)
                    y(mat%IA1(pntr+ofs)+ofs)=y(mat%IA1(pntr+ofs)+ofs) &
                           +  (mat%A(pntr + ofs)) * x(i)
                  end if
                  pntr = pntr + 1
               end do
            end do
         else
            do i = 1, mat%M
               pntr = mat%pb(i)
               do while(pntr.lt.mat%pe(i))
                  if(i.eq.mat%IA1(pntr + ofs) + ofs) then
                     y(i) = y(i) &
                  + mat%A(pntr + ofs) * x(mat%IA1(pntr + ofs ) + ofs)
                  else if (i.gt.mat%IA1(pntr + ofs) + ofs) then
                     y(i) = y(i) &
                  + mat%A(pntr + ofs) * x(mat%IA1(pntr + ofs ) + ofs)
                   y(mat%IA1(pntr+ofs)+ofs)=y(mat%IA1(pntr+ofs)+ofs) &
                           +  (mat%A(pntr + ofs)) * x(i)
                  end if
                  pntr = pntr + 1
               end do
            end do
         end if
         ierr = 0
      else
         do i = 1, mat%M
            pntr = mat%pb(i)
            do while(pntr.lt.mat%pe(i))
              y(i) = y(i) &
                  + mat%A(pntr + ofs) * x(mat%IA1(pntr + ofs ) + ofs)
               pntr = pntr + 1
            end do
         end do
         ierr = 0
      end if
      end subroutine irmbv_csr
! **********************************************************************
! **********************************************************************
      subroutine srmbv_csr (mat,x,y,ierr)
      implicit none
      type(sspmat ), pointer :: mat
      real(KIND=sp) , dimension(:), intent(in) :: x
      real(KIND=sp) , dimension(:), intent(out) :: y
      integer, intent(out) :: ierr
      integer :: m,n,base,ofs,i,pntr
      character :: diag,type,part
      ierr = -1
      m = size(y)
      n = size(x)
      if ((mat%FIDA.ne.'CSR').or.(mat%M.ne.m).or.(mat%K.ne.n)) then
         ierr = blas_error_param
         return
      end if
      call get_infoa(mat%INFOA,'b',base,ierr)
      if (ierr.ne.0) then
         ierr = blas_error_param
         return
      end if
      ofs = 1 - base
      call get_descra(mat%DESCRA,'d',diag,ierr)
      if (ierr.ne.0) then
         ierr = blas_error_param
         return
      end if
      call get_descra(mat%DESCRA,'t',type,ierr)
      if (ierr.ne.0) then
         ierr = blas_error_param
         return
      end if
      call get_descra(mat%DESCRA,'a',part,ierr)
      if (ierr.ne.0) then
         ierr = blas_error_param
         return
      end if
      y = 0.0e0
      if (diag.eq.'U') then !process unstored diagonal
         if (m.eq.n) then
            y = x
         else
            ierr = blas_error_param
            return
         end if
      end if
      if ((type.eq.'S').and.(.not.(part.eq.'B')).and.(m.eq.n)) then
         if (part.eq.'U') then
            do i = 1, mat%M
               pntr = mat%pb(i)
               do while(pntr.lt.mat%pe(i))
                  if(i.eq.mat%IA1(pntr + ofs) + ofs) then
                     y(i) = y(i) &
                  + mat%A(pntr + ofs) * x(mat%IA1(pntr + ofs ) + ofs)
                  else if (i.lt.mat%IA1(pntr + ofs) + ofs) then
                     y(i) = y(i) &
                  + mat%A(pntr + ofs) * x(mat%IA1(pntr + ofs ) + ofs)
                     y(mat%IA1(pntr + ofs) + ofs) =  &
              y(mat%IA1(pntr + ofs ) + ofs) + mat%A(pntr + ofs) * x(i)
                  end if
                  pntr = pntr + 1
               end do
            end do
         else
            do i = 1, mat%M
               pntr = mat%pb(i)
               do while(pntr.lt.mat%pe(i))
                  if(i.eq.mat%IA1(pntr + ofs) + ofs) then
                     y(i) = y(i) &
                  + mat%A(pntr + ofs) * x(mat%IA1(pntr + ofs ) + ofs)
                  else if (i.gt.mat%IA1(pntr + ofs) + ofs) then
                     y(i) = y(i) &
                  + mat%A(pntr + ofs) * x(mat%IA1(pntr + ofs ) + ofs)
                     y(mat%IA1(pntr + ofs) + ofs) = &
              y(mat%IA1(pntr + ofs ) + ofs) + mat%A(pntr + ofs) * x(i)
                  end if
                  pntr = pntr + 1
               end do
            end do
         end if
         ierr = 0
      else if((type.eq.'H').and.(.not.(part.eq.'B')).and.(m.eq.n)) then
         if (part.eq.'U') then
            do i = 1, mat%M
               pntr = mat%pb(i)
               do while(pntr.lt.mat%pe(i))
                  if(i.eq.mat%IA1(pntr + ofs) + ofs) then
                     y(i) = y(i) &
                  + mat%A(pntr + ofs) * x(mat%IA1(pntr + ofs ) + ofs)
                  else if (i.lt.mat%IA1(pntr + ofs) + ofs) then
                     y(i) = y(i) &
                  + mat%A(pntr + ofs) * x(mat%IA1(pntr + ofs ) + ofs)
                    y(mat%IA1(pntr+ofs)+ofs)=y(mat%IA1(pntr+ofs)+ofs) &
                           +  (mat%A(pntr + ofs)) * x(i)
                  end if
                  pntr = pntr + 1
               end do
            end do
         else
            do i = 1, mat%M
               pntr = mat%pb(i)
               do while(pntr.lt.mat%pe(i))
                  if(i.eq.mat%IA1(pntr + ofs) + ofs) then
                     y(i) = y(i) &
                  + mat%A(pntr + ofs) * x(mat%IA1(pntr + ofs ) + ofs)
                  else if (i.gt.mat%IA1(pntr + ofs) + ofs) then
                     y(i) = y(i) &
                  + mat%A(pntr + ofs) * x(mat%IA1(pntr + ofs ) + ofs)
                   y(mat%IA1(pntr+ofs)+ofs)=y(mat%IA1(pntr+ofs)+ofs) &
                           +  (mat%A(pntr + ofs)) * x(i)
                  end if
                  pntr = pntr + 1
               end do
            end do
         end if
         ierr = 0
      else
         do i = 1, mat%M
            pntr = mat%pb(i)
            do while(pntr.lt.mat%pe(i))
              y(i) = y(i) &
                  + mat%A(pntr + ofs) * x(mat%IA1(pntr + ofs ) + ofs)
               pntr = pntr + 1
            end do
         end do
         ierr = 0
      end if
      end subroutine srmbv_csr
! **********************************************************************
! **********************************************************************
      subroutine drmbv_csr (mat,x,y,ierr)
      implicit none
      type(dspmat ), pointer :: mat
      real(KIND=dp) , dimension(:), intent(in) :: x
      real(KIND=dp) , dimension(:), intent(out) :: y
      integer, intent(out) :: ierr
      integer :: m,n,base,ofs,i,pntr
      character :: diag,type,part
      ierr = -1
      m = size(y)
      n = size(x)
      if ((mat%FIDA.ne.'CSR').or.(mat%M.ne.m).or.(mat%K.ne.n)) then
         ierr = blas_error_param
         return
      end if
      call get_infoa(mat%INFOA,'b',base,ierr)
      if (ierr.ne.0) then
         ierr = blas_error_param
         return
      end if
      ofs = 1 - base
      call get_descra(mat%DESCRA,'d',diag,ierr)
      if (ierr.ne.0) then
         ierr = blas_error_param
         return
      end if
      call get_descra(mat%DESCRA,'t',type,ierr)
      if (ierr.ne.0) then
         ierr = blas_error_param
         return
      end if
      call get_descra(mat%DESCRA,'a',part,ierr)
      if (ierr.ne.0) then
         ierr = blas_error_param
         return
      end if
      y = 0.0d0
      if (diag.eq.'U') then !process unstored diagonal
         if (m.eq.n) then
            y = x
         else
            ierr = blas_error_param
            return
         end if
      end if
      if ((type.eq.'S').and.(.not.(part.eq.'B')).and.(m.eq.n)) then
         if (part.eq.'U') then
            do i = 1, mat%M
               pntr = mat%pb(i)
               do while(pntr.lt.mat%pe(i))
                  if(i.eq.mat%IA1(pntr + ofs) + ofs) then
                     y(i) = y(i) &
                  + mat%A(pntr + ofs) * x(mat%IA1(pntr + ofs ) + ofs)
                  else if (i.lt.mat%IA1(pntr + ofs) + ofs) then
                     y(i) = y(i) &
                  + mat%A(pntr + ofs) * x(mat%IA1(pntr + ofs ) + ofs)
                     y(mat%IA1(pntr + ofs) + ofs) =  &
              y(mat%IA1(pntr + ofs ) + ofs) + mat%A(pntr + ofs) * x(i)
                  end if
                  pntr = pntr + 1
               end do
            end do
         else
            do i = 1, mat%M
               pntr = mat%pb(i)
               do while(pntr.lt.mat%pe(i))
                  if(i.eq.mat%IA1(pntr + ofs) + ofs) then
                     y(i) = y(i) &
                  + mat%A(pntr + ofs) * x(mat%IA1(pntr + ofs ) + ofs)
                  else if (i.gt.mat%IA1(pntr + ofs) + ofs) then
                     y(i) = y(i) &
                  + mat%A(pntr + ofs) * x(mat%IA1(pntr + ofs ) + ofs)
                     y(mat%IA1(pntr + ofs) + ofs) = &
              y(mat%IA1(pntr + ofs ) + ofs) + mat%A(pntr + ofs) * x(i)
                  end if
                  pntr = pntr + 1
               end do
            end do
         end if
         ierr = 0
      else if((type.eq.'H').and.(.not.(part.eq.'B')).and.(m.eq.n)) then
         if (part.eq.'U') then
            do i = 1, mat%M
               pntr = mat%pb(i)
               do while(pntr.lt.mat%pe(i))
                  if(i.eq.mat%IA1(pntr + ofs) + ofs) then
                     y(i) = y(i) &
                  + mat%A(pntr + ofs) * x(mat%IA1(pntr + ofs ) + ofs)
                  else if (i.lt.mat%IA1(pntr + ofs) + ofs) then
                     y(i) = y(i) &
                  + mat%A(pntr + ofs) * x(mat%IA1(pntr + ofs ) + ofs)
                    y(mat%IA1(pntr+ofs)+ofs)=y(mat%IA1(pntr+ofs)+ofs) &
                           +  (mat%A(pntr + ofs)) * x(i)
                  end if
                  pntr = pntr + 1
               end do
            end do
         else
            do i = 1, mat%M
               pntr = mat%pb(i)
               do while(pntr.lt.mat%pe(i))
                  if(i.eq.mat%IA1(pntr + ofs) + ofs) then
                     y(i) = y(i) &
                  + mat%A(pntr + ofs) * x(mat%IA1(pntr + ofs ) + ofs)
                  else if (i.gt.mat%IA1(pntr + ofs) + ofs) then
                     y(i) = y(i) &
                  + mat%A(pntr + ofs) * x(mat%IA1(pntr + ofs ) + ofs)
                   y(mat%IA1(pntr+ofs)+ofs)=y(mat%IA1(pntr+ofs)+ofs) &
                           +  (mat%A(pntr + ofs)) * x(i)
                  end if
                  pntr = pntr + 1
               end do
            end do
         end if
         ierr = 0
      else
         do i = 1, mat%M
            pntr = mat%pb(i)
            do while(pntr.lt.mat%pe(i))
              y(i) = y(i) &
                  + mat%A(pntr + ofs) * x(mat%IA1(pntr + ofs ) + ofs)
               pntr = pntr + 1
            end do
         end do
         ierr = 0
      end if
      end subroutine drmbv_csr
! **********************************************************************
! **********************************************************************
      subroutine crmbv_csr (mat,x,y,ierr)
      implicit none
      type(cspmat ), pointer :: mat
      complex(KIND=sp) , dimension(:), intent(in) :: x
      complex(KIND=sp) , dimension(:), intent(out) :: y
      integer, intent(out) :: ierr
      integer :: m,n,base,ofs,i,pntr
      character :: diag,type,part
      ierr = -1
      m = size(y)
      n = size(x)
      if ((mat%FIDA.ne.'CSR').or.(mat%M.ne.m).or.(mat%K.ne.n)) then
         ierr = blas_error_param
         return
      end if
      call get_infoa(mat%INFOA,'b',base,ierr)
      if (ierr.ne.0) then
         ierr = blas_error_param
         return
      end if
      ofs = 1 - base
      call get_descra(mat%DESCRA,'d',diag,ierr)
      if (ierr.ne.0) then
         ierr = blas_error_param
         return
      end if
      call get_descra(mat%DESCRA,'t',type,ierr)
      if (ierr.ne.0) then
         ierr = blas_error_param
         return
      end if
      call get_descra(mat%DESCRA,'a',part,ierr)
      if (ierr.ne.0) then
         ierr = blas_error_param
         return
      end if
      y = (0.0e0, 0.0e0)
      if (diag.eq.'U') then !process unstored diagonal
         if (m.eq.n) then
            y = x
         else
            ierr = blas_error_param
            return
         end if
      end if
      if ((type.eq.'S').and.(.not.(part.eq.'B')).and.(m.eq.n)) then
         if (part.eq.'U') then
            do i = 1, mat%M
               pntr = mat%pb(i)
               do while(pntr.lt.mat%pe(i))
                  if(i.eq.mat%IA1(pntr + ofs) + ofs) then
                     y(i) = y(i) &
                  + mat%A(pntr + ofs) * x(mat%IA1(pntr + ofs ) + ofs)
                  else if (i.lt.mat%IA1(pntr + ofs) + ofs) then
                     y(i) = y(i) &
                  + mat%A(pntr + ofs) * x(mat%IA1(pntr + ofs ) + ofs)
                     y(mat%IA1(pntr + ofs) + ofs) =  &
              y(mat%IA1(pntr + ofs ) + ofs) + mat%A(pntr + ofs) * x(i)
                  end if
                  pntr = pntr + 1
               end do
            end do
         else
            do i = 1, mat%M
               pntr = mat%pb(i)
               do while(pntr.lt.mat%pe(i))
                  if(i.eq.mat%IA1(pntr + ofs) + ofs) then
                     y(i) = y(i) &
                  + mat%A(pntr + ofs) * x(mat%IA1(pntr + ofs ) + ofs)
                  else if (i.gt.mat%IA1(pntr + ofs) + ofs) then
                     y(i) = y(i) &
                  + mat%A(pntr + ofs) * x(mat%IA1(pntr + ofs ) + ofs)
                     y(mat%IA1(pntr + ofs) + ofs) = &
              y(mat%IA1(pntr + ofs ) + ofs) + mat%A(pntr + ofs) * x(i)
                  end if
                  pntr = pntr + 1
               end do
            end do
         end if
         ierr = 0
      else if((type.eq.'H').and.(.not.(part.eq.'B')).and.(m.eq.n)) then
         if (part.eq.'U') then
            do i = 1, mat%M
               pntr = mat%pb(i)
               do while(pntr.lt.mat%pe(i))
                  if(i.eq.mat%IA1(pntr + ofs) + ofs) then
                     y(i) = y(i) &
                  + mat%A(pntr + ofs) * x(mat%IA1(pntr + ofs ) + ofs)
                  else if (i.lt.mat%IA1(pntr + ofs) + ofs) then
                     y(i) = y(i) &
                  + mat%A(pntr + ofs) * x(mat%IA1(pntr + ofs ) + ofs)
                    y(mat%IA1(pntr+ofs)+ofs)=y(mat%IA1(pntr+ofs)+ofs) &
                           + conjg (mat%A(pntr + ofs)) * x(i)
                  end if
                  pntr = pntr + 1
               end do
            end do
         else
            do i = 1, mat%M
               pntr = mat%pb(i)
               do while(pntr.lt.mat%pe(i))
                  if(i.eq.mat%IA1(pntr + ofs) + ofs) then
                     y(i) = y(i) &
                  + mat%A(pntr + ofs) * x(mat%IA1(pntr + ofs ) + ofs)
                  else if (i.gt.mat%IA1(pntr + ofs) + ofs) then
                     y(i) = y(i) &
                  + mat%A(pntr + ofs) * x(mat%IA1(pntr + ofs ) + ofs)
                   y(mat%IA1(pntr+ofs)+ofs)=y(mat%IA1(pntr+ofs)+ofs) &
                           + conjg (mat%A(pntr + ofs)) * x(i)
                  end if
                  pntr = pntr + 1
               end do
            end do
         end if
         ierr = 0
      else
         do i = 1, mat%M
            pntr = mat%pb(i)
            do while(pntr.lt.mat%pe(i))
              y(i) = y(i) &
                  + mat%A(pntr + ofs) * x(mat%IA1(pntr + ofs ) + ofs)
               pntr = pntr + 1
            end do
         end do
         ierr = 0
      end if
      end subroutine crmbv_csr
! **********************************************************************
! **********************************************************************
      subroutine zrmbv_csr (mat,x,y,ierr)
      implicit none
      type(zspmat ), pointer :: mat
      complex(KIND=dp) , dimension(:), intent(in) :: x
      complex(KIND=dp) , dimension(:), intent(out) :: y
      integer, intent(out) :: ierr
      integer :: m,n,base,ofs,i,pntr
      character :: diag,type,part
      ierr = -1
      m = size(y)
      n = size(x)
      if ((mat%FIDA.ne.'CSR').or.(mat%M.ne.m).or.(mat%K.ne.n)) then
         ierr = blas_error_param
         return
      end if
      call get_infoa(mat%INFOA,'b',base,ierr)
      if (ierr.ne.0) then
         ierr = blas_error_param
         return
      end if
      ofs = 1 - base
      call get_descra(mat%DESCRA,'d',diag,ierr)
      if (ierr.ne.0) then
         ierr = blas_error_param
         return
      end if
      call get_descra(mat%DESCRA,'t',type,ierr)
      if (ierr.ne.0) then
         ierr = blas_error_param
         return
      end if
      call get_descra(mat%DESCRA,'a',part,ierr)
      if (ierr.ne.0) then
         ierr = blas_error_param
         return
      end if
      y = (0.0d0, 0.0d0)
      if (diag.eq.'U') then !process unstored diagonal
         if (m.eq.n) then
            y = x
         else
            ierr = blas_error_param
            return
         end if
      end if
      if ((type.eq.'S').and.(.not.(part.eq.'B')).and.(m.eq.n)) then
         if (part.eq.'U') then
            do i = 1, mat%M
               pntr = mat%pb(i)
               do while(pntr.lt.mat%pe(i))
                  if(i.eq.mat%IA1(pntr + ofs) + ofs) then
                     y(i) = y(i) &
                  + mat%A(pntr + ofs) * x(mat%IA1(pntr + ofs ) + ofs)
                  else if (i.lt.mat%IA1(pntr + ofs) + ofs) then
                     y(i) = y(i) &
                  + mat%A(pntr + ofs) * x(mat%IA1(pntr + ofs ) + ofs)
                     y(mat%IA1(pntr + ofs) + ofs) =  &
              y(mat%IA1(pntr + ofs ) + ofs) + mat%A(pntr + ofs) * x(i)
                  end if
                  pntr = pntr + 1
               end do
            end do
         else
            do i = 1, mat%M
               pntr = mat%pb(i)
               do while(pntr.lt.mat%pe(i))
                  if(i.eq.mat%IA1(pntr + ofs) + ofs) then
                     y(i) = y(i) &
                  + mat%A(pntr + ofs) * x(mat%IA1(pntr + ofs ) + ofs)
                  else if (i.gt.mat%IA1(pntr + ofs) + ofs) then
                     y(i) = y(i) &
                  + mat%A(pntr + ofs) * x(mat%IA1(pntr + ofs ) + ofs)
                     y(mat%IA1(pntr + ofs) + ofs) = &
              y(mat%IA1(pntr + ofs ) + ofs) + mat%A(pntr + ofs) * x(i)
                  end if
                  pntr = pntr + 1
               end do
            end do
         end if
         ierr = 0
      else if((type.eq.'H').and.(.not.(part.eq.'B')).and.(m.eq.n)) then
         if (part.eq.'U') then
            do i = 1, mat%M
               pntr = mat%pb(i)
               do while(pntr.lt.mat%pe(i))
                  if(i.eq.mat%IA1(pntr + ofs) + ofs) then
                     y(i) = y(i) &
                  + mat%A(pntr + ofs) * x(mat%IA1(pntr + ofs ) + ofs)
                  else if (i.lt.mat%IA1(pntr + ofs) + ofs) then
                     y(i) = y(i) &
                  + mat%A(pntr + ofs) * x(mat%IA1(pntr + ofs ) + ofs)
                    y(mat%IA1(pntr+ofs)+ofs)=y(mat%IA1(pntr+ofs)+ofs) &
                           + conjg (mat%A(pntr + ofs)) * x(i)
                  end if
                  pntr = pntr + 1
               end do
            end do
         else
            do i = 1, mat%M
               pntr = mat%pb(i)
               do while(pntr.lt.mat%pe(i))
                  if(i.eq.mat%IA1(pntr + ofs) + ofs) then
                     y(i) = y(i) &
                  + mat%A(pntr + ofs) * x(mat%IA1(pntr + ofs ) + ofs)
                  else if (i.gt.mat%IA1(pntr + ofs) + ofs) then
                     y(i) = y(i) &
                  + mat%A(pntr + ofs) * x(mat%IA1(pntr + ofs ) + ofs)
                   y(mat%IA1(pntr+ofs)+ofs)=y(mat%IA1(pntr+ofs)+ofs) &
                           + conjg (mat%A(pntr + ofs)) * x(i)
                  end if
                  pntr = pntr + 1
               end do
            end do
         end if
         ierr = 0
      else
         do i = 1, mat%M
            pntr = mat%pb(i)
            do while(pntr.lt.mat%pe(i))
              y(i) = y(i) &
                  + mat%A(pntr + ofs) * x(mat%IA1(pntr + ofs ) + ofs)
               pntr = pntr + 1
            end do
         end do
         ierr = 0
      end if
      end subroutine zrmbv_csr
! **********************************************************************
! **********************************************************************
      end module mod_rmbv_csr


C
C***********************************************************************
C                                                                      *
C            NACHOS II - A Finite Element Computer Program             *
C                        for Incompressible Flow Problems              *
C                                                                      *
C     Copyright (c) 1986,2019   National Technology & Engineering      *
C                               Solutions of Sandia, LLC (NTESS)       *
C                                                                      *
C                            All rights reserved.                      *
C                                                                      *
C     This software is distributed under the BSD 3-Clause License.     *
C                                                                      *
C***********************************************************************
C
      SUBROUTINE STREAM (XS,YS,ICON,LISTEL,LISTND,UN,PSIVEC)
C
C     ******************************************************************
C
C     PROGRAM TO CALCULATE THE STREAM FUNCTION FIELD FROM A KNOWN
C     VELOCITY FIELD VIA INTEGRATION ALONG ELEMENT EDGES
C
C     ******************************************************************
C
      CHARACTER*10 CDATA,PRNTR
C
      COMMON /INDATR/ RDATA(150)
      COMMON /INDATI/ IDATA(150)
      COMMON /INDATC/ CDATA(150)
      COMMON /TAPES/  NIN,NOUT,NTP0,NTP1,NTP2,NTP3,NTP4,NTP5,NTP6,NTP7,
     1                NTP8,NTP9,NTP10,NTP11,NTP12,NTP13
      COMMON /SZDAT/  NUMEL,NUMNOD,NMVAR,NUMDOF,NODSOL
      COMMON /PRBDAT/ IAXSYM,ITMDEP,IFORCE,IFREE,IVAR1,IVAR2,IPFUNC,
     1                IPNLTY,PNLTY
      COMMON /ELMDAT/ NNELM(6),NNCOR(6),NNMID(6),NNCTR(6),NSIDET(5),
     1                NSIDEQ(7),NNSIDE(6,4,3)
      COMMON /GAUSS2/ GSPT3(3),GSWT3(3)
C
      DIMENSION ICON(NUMEL,*), LISTEL(*), LISTND(*), XS(*), YS(*)
      DIMENSION UN(NUMNOD,*), PSIVEC(*)
      DIMENSION U(9), V(9), X(9), Y(9)
      DIMENSION DELPSI(4), PSI(4)
      DIMENSION FACT1(3,3), FACT2(2)
      DIMENSION DSX(3), DSY(3)
C
      DATA ((FACT1(I,J),I=1,3),J=1,3)/-.5,.666667,-.166667,-.666667,
     1     0.,.666667,.166667,-.666667,.5/
      DATA (FACT2(I),I=1,2)/.333333,1.333333/
      DATA NGAUSS/3/
C
C     STATEMENT FUNCTION
C
      FS(I,S)=(S**2-S)*.25*(I-2)*(I-3)-(1.-S**2)*(I-1)*(I-3)+(S**2+S)*
     1.25*(I-1)*(I-2)
C
C     ******************************************************************
C
C     READ CONTROL DATA
C
      WRITE (NOUT, 420)
      PSIBAS=RDATA(2)
      PRNTR=CDATA(3)
      IF (PRNTR.EQ.' ') PRNTR='SUMMARY'
      NINC=IDATA(4)
      IF (NINC.EQ.0) NINC=10000
      IF (ITMDEP.EQ.0) NINC=1
      WRITE (NOUT, 430) PSIBAS,NINC
      IF (PRNTR.EQ.'PRINT') WRITE (NOUT, 370)
      IF (PRNTR.EQ.'SUMMARY') WRITE (NOUT, 380)
      IF (PRNTR.EQ.'NOPRINT') WRITE (NOUT, 390)
C
C     SET POINTERS
C
      KINC=0
   10 CONTINUE
      KINC=KINC+1
      KOUNT=0
      KADD=1
      PSIMAX=0.
      PSIMIN=0.
      RESID=0.
C
C     READ SOLUTION FIELD
C
      READ (NTP9, END=350) TIME,NUMNOD,NUMVAR,((UN(I,J),I=1,NUMNOD),
     1J=1,NUMVAR)
C
C     LOOP ON ELEMENTS, CREATING NICNAMES AND CALCULATING DELTA PSI
C
      DO 20 I=1,NUMNOD
      PSIVEC(I)=0.
      LISTND(I)=0
   20 CONTINUE
      DO 310 N=1,NUMEL
      NN=ABS(LISTEL(N))
      KIND=MOD(NN,100)
      NN=NNELM(KIND)
      DO 30 J=1,NN
      INODE=ICON(N,J)
      U(J)=UN(INODE,1)
      V(J)=UN(INODE,2)
      X(J)=XS(INODE)
      Y(J)=YS(INODE)
   30 CONTINUE
      NPSI=NNCOR(KIND)
      NPSIM=NPSI-1
      IF (IAXSYM.EQ.1) GO TO 80
C
C     PLANAR GEOMETRY
C
      GO TO (40, 60, 40, 60, 40, 60), KIND
   40 CONTINUE
C
C     SUBPARAMETRIC ELEMENTS
C
      DO 50 I=1,NPSI
      I1=I
      I2=I+1
      I3=I+NPSI
      IF (I.EQ.NPSI) I2=1
      XDIFF=(X(I2)-X(I1))/2.
      YDIFF=(Y(I2)-Y(I1))/2.
      DELPSI(I)=(FACT2(1)*U(I1)+FACT2(2)*U(I3)+FACT2(1)*U(I2))*YDIFF-
     1(FACT2(1)*V(I1)+FACT2(2)*V(I3)+FACT2(1)*V(I2))*XDIFF
   50 CONTINUE
      GO TO 150
   60 CONTINUE
C
C     ISOPARAMETRIC ELEMENTS
C
      DO 70 I=1,NPSI
      I1=I
      I2=I+1
      I3=I+NPSI
      IF (I.EQ.NPSI) I2=1
      WX1=X(I1)*FACT1(1,1)+X(I3)*FACT1(2,1)+X(I2)*FACT1(3,1)
      WX2=X(I1)*FACT1(1,2)+X(I3)*FACT1(2,2)+X(I2)*FACT1(3,2)
      WX3=X(I1)*FACT1(1,3)+X(I3)*FACT1(2,3)+X(I2)*FACT1(3,3)
      WY1=Y(I1)*FACT1(1,1)+Y(I3)*FACT1(2,1)+Y(I2)*FACT1(3,1)
      WY2=Y(I1)*FACT1(1,2)+Y(I3)*FACT1(2,2)+Y(I2)*FACT1(3,2)
      WY3=Y(I1)*FACT1(1,3)+Y(I3)*FACT1(2,3)+Y(I2)*FACT1(3,3)
      DELPSI(I)=WY1*U(I1)+WY2*U(I3)+WY3*U(I2)-WX1*V(I1)-WX2*V(I3)-
     1WX3*V(I2)
   70 CONTINUE
      GO TO 150
   80 CONTINUE
C
C     AXISYMMETRIC GEOMETRY
C
      GO TO (90, 120, 90, 120, 90, 120), KIND
   90 CONTINUE
C
C     SUBPARAMETRIC ELEMENTS
C
      DO 110 I=1,NPSI
      I1=I
      I2=I+1
      I3=I+NPSI
      IF (I.EQ.NPSI) I2=1
      XDIFF=(X(I2)-X(I1))/2.
      YDIFF=(Y(I2)-Y(I1))/2.
      DO 100 LL=1,3
      DSX(LL)=0.
      DSY(LL)=0.
      DO 100 L=1,NGAUSS
      S=GSPT3(L)
      WW=GSWT3(L)
      R=X(I1)*(1.-S)*.5+X(I2)*(1.+S)*.5
      AA=FS(LL,S)
      DSX(LL)=DSX(LL)+WW*R*AA
      DSY(LL)=DSY(LL)+WW*R*AA
  100 CONTINUE
      DELPSI(I)=(DSX(1)*U(I1)+DSX(2)*U(I3)+DSX(3)*U(I2))*YDIFF-(DSY(1)*
     1V(I1)+DSY(2)*V(I3)+DSY(3)*V(I2))*XDIFF
  110 CONTINUE
      GO TO 150
  120 CONTINUE
C
C     ISOPARAMETRIC ELEMENTS
C
      DO 140 I=1,NPSI
      I1=I
      I2=I+1
      I3=I+NPSI
      IF (I.EQ.NPSI) I2=1
      DO 130 LL=1,3
      DSX(LL)=0.
      DSY(LL)=0.
      DO 130 L=1,NGAUSS
      S=GSPT3(L)
      WW=GSWT3(L)
      R=X(I1)*(S**2-S)*.5+X(I3)*(1.-S**2)+X(I2)*(S**2+S)*.5
      AA=FS(LL,S)
      B=(2.*S-1.)*Y(I1)*.5+(-2.*S)*Y(I3)+(2.*S+1.)*Y(I2)*.5
      C=(2.*S-1.)*X(I1)*.5+(-2.*S)*X(I3)+(2.*S+1.)*X(I2)*.5
      DSX(LL)=DSX(LL)+WW*R*AA*B
      DSY(LL)=DSY(LL)+WW*R*AA*C
  130 CONTINUE
      DELPSI(I)=DSX(1)*U(I1)+DSX(2)*U(I3)+DSX(3)*U(I2)-DSY(1)*V(I1)-
     1DSY(2)*V(I3)-DSY(3)*V(I2)
  140 CONTINUE
  150 CONTINUE
C
C     ADJUST STREAM FUNCTION INCREMENTS TO SATISFY ELEMENT MASS BALANCE
C
      S=0.
      DO 160 I=1,NPSI
      S=S+DELPSI(I)
  160 CONTINUE
      IF (ABS(S).GT.RESID) THEN
      RESID=ABS(S)
      NELR=N
      END IF
      S=S/NPSI
      DO 170 I=1,NPSI
      DELPSI(I)=DELPSI(I)-S
  170 CONTINUE
C
C     CALCULATE THE STREAM FUNCTION AT THE NODAL POINTS
C
C     FIRST ELEMENT IN THE MESH
C
      IF (N.NE.1) GO TO 200
      PSI(1)=PSIBAS
      DO 180 I=1,NPSIM
      PSI(I+1)=PSI(I)+DELPSI(I)
  180 CONTINUE
      DO 190 I=1,NPSI
      INODE=ICON(N,I)
      PSIVEC(INODE)=PSIVEC(INODE)+PSI(I)
      LISTND(INODE)=LISTND(INODE)+1
  190 CONTINUE
      GO TO 310
  200 CONTINUE
C
C     LOCATE CONNECTING NODE WITH KNOWN VALUE OF PSI
C
      NPRVEL=N-1
      DO 220 NP=1,NPSI
      KNODE=ICON(N,NP)
      NSTART=NP
      DO 220 NEL=1,NPRVEL
      KEL=NPRVEL-NEL+1
      NN=ABS(LISTEL(KEL))
      KIND2=MOD(NN,100)
      NN=NNCOR(KIND2)
      DO 210 I=1,NN
      INODE=ICON(KEL,I)
      IF (INODE.EQ.KNODE.AND.LISTND(INODE).GT.0) GO TO 230
  210 CONTINUE
  220 CONTINUE
      GO TO 300
  230 CONTINUE
C
C     CONNECTING NODE LOCATED, CALCULATE STREAM FUNCTION FOR
C     CURRENT ELEMENT
C
      PSI(NSTART)=PSIVEC(INODE)/LISTND(INODE)
      GO TO (240, 240, 260, 260, 260, 260) , KIND
  240 CONTINUE
      DO 250 I=1,NPSIM
      II=NSIDET(NSTART+I-1)
      III=NSIDET(NSTART+I)
      PSI(III)=PSI(II)+DELPSI(II)
  250 CONTINUE
      GO TO 280
  260 CONTINUE
      DO 270 I=1,NPSIM
      II=NSIDEQ(NSTART+I-1)
      III=NSIDEQ(NSTART+I)
      PSI(III)=PSI(II)+DELPSI(II)
  270 CONTINUE
C
C    ADD TO GLOBAL PSI VECTOR
C
  280 CONTINUE
      DO 290 I=1,NPSI
      INODE=ICON(N,I)
      PSIVEC(INODE)=PSIVEC(INODE)+PSI(I)
      LISTND(INODE)=LISTND(INODE)+1
  290 CONTINUE
      GO TO 310
  300 CONTINUE
      KOUNT=KOUNT+1
  310 CONTINUE
      IF (KOUNT.GE.1.AND.KINC.EQ.1) WRITE (NOUT, 400)
C
C     PROCESS GLOBAL VECTOR TO RECOVER AVERAGE PSI AT THE NODES
C
      DO 320 I=1,NUMNOD
      NPSI=LISTND(I)
      IF (NPSI.EQ.0) GO TO 320
      PSIVEC(I)=PSIVEC(I)/NPSI
  320 CONTINUE
C
C     GENERATE STREAM FUNCTION VALUES AT MIDSIDE NODES
C
      CALL MIDSID (PSIVEC,ICON,LISTEL)
C
C     FIND MAX AND MIN VALUES FOR STREAM FUNCTION (USES ONLY CORNER
C     NODE VALUES)
C
      IF (PRNTR.EQ.'SUMMARY') THEN
      CALL MAXMIN (LISTEL,ICON,7,PSIVEC(1),1,PSIMAX,PSIMIN,NELMX,
     1NODMX,NELMN,NODMN)
      WRITE (NOUT, 440) TIME,PSIMAX,NELMX,NODMX,PSIMIN,NELMN,NODMN
      WRITE (NOUT, 450) RESID,NELR
      END IF
C
C     WRITE TAPE FOR USE IN PLOTTING AND PRINT STREAM FUNCTION FIELD
C
      NPSIM=1
      WRITE (NTP5) TIME,NUMNOD,NPSIM,(PSIVEC(I),I=1,NUMNOD)
      IF (PRNTR.EQ.'PRINT') THEN
      DO 340 N=1,NUMEL
      NN=ABS(LISTEL(N))
      KIND=MOD(NN,100)
      NN=NNCOR(KIND)
      DO 330 I=1,NN
      INODE=ICON(N,I)
      PSI(I)=PSIVEC(INODE)
  330 CONTINUE
      WRITE (NOUT, 410) N,(PSI(I),I=1,NN)
  340 CONTINUE
      END IF
C
      IF (KINC.EQ.NINC) GO TO 360
      GO TO 10
  350 CONTINUE
      KINC=KINC-1
      WRITE (NOUT, 460) KINC
  360 CONTINUE
C
  370 FORMAT (//,3X,'PRINTING OF THE ENTIRE STREAM FUNCTION FIELD HAS BE
     1EN REQUESTED',/,3X,'VALUES OF THE STREAM FUNCTION ARE CALCULATED A
     2T THE CORNER NODES-' ,/,3X,'ORDERING IS COUNTERCLOCKWISE AROUND TH
     3E ELEMENT BEGINNING WITH THE IDENTIFYING NODE' )
  380 FORMAT (//,3X,'PRINTING OF THE STREAM FUNCTION SUMMARY DATA HAS BE
     1EN REQUESTED' )
  390 FORMAT (//,3X,'PRINTING OF THE STEAM FUNCTION SUMMARY DATA HAS BEE
     1N SUPPRESSED' )
  400 FORMAT (//,3X,'*** ELEMENT CONNECTIVITY (ORDERING) NOT SUFFICIENTL
     1Y CONTINUOUS ',/,3X,'*** TO ALLOW CALCULATION OF THE STREAM FUNCTI
     2ON IN ALL THE ELEMENTS'  )
  410 FORMAT (10X,'ELEMENT'I5,2X,'PSI='4(3X,E15.7))
  420 FORMAT (///,3X,'CALCULATION OF THE STREAM FUNCTION HAS BEEN REQUES
     1TED FOR THIS PROBLEM' )
  430 FORMAT (/,3X,'STREAM FUNCTION VALUE AT FIRST NODE = ',E15.7,/,3X,
     1'NUMBER OF TIME PLANES TO BE COMPUTED = ',I5)
  440 FORMAT (///,10X,'TIME='E15.7,/,10X,'MAXIMUM AND MINIMUM VALUES OF
     1THE STREAM FUNCTION--' ,/,10X,'MAX PSI='E15.7,3X,'IN ELEMENT ',I4,
     2' NODE',I4,/,10X,'MIN PSI='E15.7,3X,'IN ELEMENT ',I4,' NODE',I4)
  450 FORMAT (/,10X,'MAXIMUM ELEMENT MASS BALANCE ERROR = ' ,E15.7,3X,
     1'IN  ELEMENT ',I4,//)
  460 FORMAT (//,10X,'STREAM FUNCTION COMPUTED FOR',I5,' TIME STEPS')
      END


MODULE bregman

implicit none

!
! Public subroutines for compressive sensing using Bregman iterations.
! For large problems, use SplitBregman.
!
! REFERENCES:
!
! The Bregman algorithm is described in W. Yin, S. Osher, D. Goldfarb, and J. Darbon,
! "Bregman Iterative Algorithms for L1-Minimization with Applications to Compressed Sensing,"
! SIAM J. Img. Sci. 1, 143 (2008).
!
! Fixed-point continuation is described in E. T. Hale, W. Yin, and Y. Zhang,
! "A fixed-point continuation method for l1-regularized minimization with applications
! to compressed sensing," CAAM TR07-07, Rice University (2007).
!
! The split Bregman algorithm is described in T. Goldstein and S. Osher,
! "The split Bregman method for L1 regularized problems",
! SIAM Journal on Imaging Sciences Volume 2 Issue 2, Pages 323-343 (2009).
!
! The conjugae gradient algorithm is described in S. Boyd and L. Vandenberghe,
! "Convex Optimization" (Cambridge University Press, 2004).
!
! Coded by Vidvuds Ozolins (UCLA Materials Science & Eng).
! Last modified: August 5, 2012
!
public BregmanFPC
public SplitBregman
!public CGmin
!public Shrink

!
! The same as above, but takes advantage of sparse sensing matrices.
!
public SparseBregmanFPC
public SparseSplitBregman
!public SparseCGmin

! with right preconditioner
public BregmanRPrecond2
public BregmanRPrecond

!
! Private parameters for the fixed-point continuation (FPC) algorithm.
!
! MaxFPCit - maximum number of FPC iterations
! nPrint   - number of FPC its to print out gradients and residuals;
!            specify nPrint > MaxFPCit if output is not desired
! FPCgtol  - tolerance for gradient in FPC iterations; the algorithm will iterate until
!            FPCgtol > ||grad||_infty / mu - 1d0
! FPCxtol  - tolerance for the solution; the algorithm will iterate until
!            FPCxtol > ||u-uprev||_2 / ||uprev||_1
!
integer, private                  :: MaxFPCit = 60000
integer, private                  :: nPrint = 1000
double precision, private         :: FPCgtol = 1d-1
double precision, private         :: FPCxtol = 1d-4

!
! Tolerance factor for the CG algorithm: CG stops if ||grad|| <  CGtol*||deltaU||/||U||
!
double precision, private         :: CGtol = 1d-1

CONTAINS

SUBROUTINE BregmanFPC(nBregIt, tol, tau, mu, N, M, A, b, u) BIND(C,NAME="BregmanFPC")
  !
  ! Performs Bregman iterations using fixed-point continuation (FPC)
  ! as the solver for the mixed L1/L2 problem:
  !
  !    u = arg min_u { mu ||u||_1 + 1/2 ||Au-b||_2^2 }
  !
  ! The Bregman algorithm is described in W. Yin, S. Osher, D. Goldfarb, and J. Darbon,
  ! "Bregman Iterative Algorithms for L1-Minimization with Applications to Compressed Sensing,"
  ! SIAM J. Img. Sci. 1, 143 (2008).
  !
  ! Input parameters:
  !   nBregIt - Number of outer Bregman loops (usually 5)
  !   tol     - Required tolerance for the residual. The algorithm stops when
  !             tol > ||Au-b||_2 / ||b||_2
  !   tau     - step size for the FPC iterations;
  !             tau = MIN(1.999d0, -1.665d0 * M/N + 2.665d0)
  !   mu      - weight for the L1 norm of the solution
  !   N   - number of unknown expansion coefficients [ =length(u) ]
  !   M       - number of measurements [ =length(b) ]
  !   A       - sensing matrix of dimensions (M,N); the maximum eigenvalue of A.AT should be <= 1
  !             this can be enforced by dividing both A and b with lambda=Sqrt(Max(Eigenvalues(A.Transpose(A))))
  !   b       - array with measured signal values of length M
  !   u       - solution array of length N
  !
  ! Output:
  !   u       - solution
  !

  integer, intent(in) :: nBregIt, N, M
  double precision, intent(in) :: tol, tau, mu
  double precision,intent(in) :: A(M,N), b(M)
  double precision,intent(out) :: u(N)
!f2py intent(hide) :: M, N
!f2py intent(in) :: A, b, nBregIt, tol, tau, mu
!f2py intent(out) :: u

  double precision, allocatable:: uprev(:), grad(:), residual(:), x(:), bp(:)

  integer j, k
  double precision crit1, crit2

  ALLOCATE( grad(N), uprev(N), bp(M), x(M), residual(M) )

  bp = b

  do k = 1, nBregIt

     do j = 1, MaxFPCit
        uprev = u

        x = MATMUL(A, u) - bp
        grad = MATMUL(TRANSPOSE(A), x)
        u = u - tau * grad

        !        print *, ' norm of residual = ', SQRT(dot_product(x,x))
        !        print *, ' norm of gradient = ', SQRT(dot_product(grad,grad))
        !        print *, ' norm of u = ', SQRT(dot_product(u,u))

        call Shrink(u, N, mu*tau)
        !        print *, ' norm of u after shrinkage = ', SQRT(dot_product(u,u))

        crit1 = MAXVAL(ABS(grad)) / mu - 1d0
        crit2 = SQRT(DOT_PRODUCT(u-uprev,u-uprev)) / MAX(SUM(ABS(uprev)),1d0)

        if( MOD(j,nPrint) == 0 ) print '(i6,2f14.6)', j, crit1, crit2
        if( crit1 < FPCgtol .and. crit2 < FPCxtol ) exit
     end do

     if ( j >= MaxFPCit ) then
         print '(2(a,f12.8))', " Unconverged FPC: ||deltaU||/||U|| =", crit2, " ||grad||/mu - 1 = ", crit1
     end if

     residual = MATMUL(A,u) - b

     crit1 =  SQRT(DOT_PRODUCT(residual,residual)) / SQRT(DOT_PRODUCT(b,b))
     print '(a,i2,a,i6,a,f12.6)', ' Finished Bregman loop #',k,' after ', &
          j,' FPC steps, ||Au-b||/||b|| = ', crit1

     if( crit1 <= tol ) then
        exit
     else
        bp = bp - residual
     end if
  end do

  DEALLOCATE( grad, uprev, bp, x, residual )

  return
end SUBROUTINE BregmanFPC

SUBROUTINE SparseBregmanFPC(nBregIt, tol, tau, mu, N, M, nA, Aval, iAx, b, u)
  !
  ! Performs Bregman iterations using fixed-point continuation (FPC)
  ! as the solver for the mixed L1/L2 problem:
  !
  !    u = arg min_u { mu ||u||_1 + 1/2 ||Au-b||_2^2 }
  !
  ! This version uses a sparse sensing matrix A.
  !
  ! The Bregman algorithm is described in W. Yin, S. Osher, D. Goldfarb, and J. Darbon,
  ! "Bregman Iterative Algorithms for L1-Minimization with Applications to Compressed Sensing,"
  ! SIAM J. Img. Sci. 1, 143 (2008).
  !
  ! Input parameters:
  !   nBregIt - Number of outer Bregman loops (usually 5)
  !   tol     - Required tolerance for the residual. The algorithm stops when
  !             tol > ||Au-b||_2 / ||b||_2
  !   tau     - step size for the FPC iterations;
  !             tau = MIN(1.999d0, -1.665d0 * dble(M) / dble(N) + 2.665d0)
  !   mu      - weight for the L1 norm of the solution
  !   N       - number of unknown expansion coefficients [ =length(u) ]
  !   M       - number of measurements [ =length(b) ]
  !   nA      - number of nonzero values of the sensing matrix A
  !   Aval    - nonzero values of the sensing matrix; the maximum eigenvalue of A.AT should be <= 1;
  !             this can be enforced by dividing both A and b with lambda=Sqrt(Max(Eigenvalues(A.Transpose(A))))
  !   iAx     - indices of the nonzero elements of A; values of iAx are within the range (1:M,1:N)
  !   b       - array with measured signal values (of length M)
  !   u       - solution array (of length N)
  !
  ! Output:
  !   u       - solution
  !
  integer, intent(in) :: nBregIt, N, M, nA, iAx(nA,2)
  double precision, intent(in) :: tol, tau, mu
  double precision,intent(in) :: Aval(nA), b(M)
  double precision,intent(out) :: u(N)

  double precision, allocatable:: uprev(:), grad(:), residual(:), x(:), bp(:)

  integer i, j, k
  double precision crit1, crit2

  ALLOCATE( grad(N), uprev(N), bp(M), x(M), residual(M) )

  bp = b

  do k = 1, nBregIt

     do j = 1, MaxFPCit
        uprev = u

#ifdef IntelMKL
        !
        ! Use BLAS calls if Intel MKL is available.
        !
        call mkl_dcoogemv('N', M, Aval, iAx(:,1), iAx(:,2), nA, u, x)
        x = x - bp
        call mkl_dcoogemv('N', N, Aval, iAx(:,2), iAx(:,1), nA, x, grad)
#else
        !
        ! Manual matrix-vector multiplies
        !
        x = 0d0
        do i = 1, nA
           x(iAx(i,1)) = x(iAx(i,1)) + Aval(i) * u(iAx(i,2))
        end do
        x = x - bp

        grad = 0d0
        do i = 1, nA
           grad(iAx(i,2)) = grad(iAx(i,2)) + Aval(i) * x(iAx(i,1))
        end do
#endif

        u = u - tau * grad

        !        print *, ' norm of residual = ', SQRT(dot_product(x,x))
        !        print *, ' norm of gradient = ', SQRT(dot_product(grad,grad))
        !        print *, ' norm of u = ', SQRT(dot_product(u,u))

        call Shrink(u, N, mu*tau)
        !        print *, ' norm of u after shrinkage = ', SQRT(dot_product(u,u))

        crit1 = MAXVAL(ABS(grad)) / mu - 1d0
        crit2 = SQRT(DOT_PRODUCT(u-uprev,u-uprev)) / MAX(SUM(ABS(uprev)),1d0)

        if( MOD(j,nPrint) == 0 ) print '(i6,2f14.6)', j, crit1, crit2
        if( crit1 < FPCgtol .and. crit2 < FPCxtol ) exit
     end do

     if ( j>= MaxFPCit ) then
        print '(2(a,f12.8))', " Unconverged FPC: ||deltaU||/||U|| =", crit2, " ||grad||/mu - 1 = ", crit1
     end if

#ifdef IntelMKL
     !
     ! Use BLAS calls if Intel MKL is available.
     !
     call mkl_dcoogemv('N', M, Aval, iAx(:,1), iAx(:,2), nA, u, residual)
#else
     !
     ! Manual matrix-vector multiply
     !
     residual = 0d0
     do i = 1, nA
        residual(iAx(i,1)) = residual(iAx(i,1)) + Aval(i) * u(iAx(i,2))
     end do
#endif

     residual = residual - b

     crit1 =  SQRT(DOT_PRODUCT(residual,residual)) / SQRT(DOT_PRODUCT(b,b))
     print '(a,i2,a,i6,a,f12.6)', ' Finished Bregman loop #',k,' after ', &
          j,' FPC steps, ||Au-b||/||b|| = ', crit1

     if( crit1 <= tol ) then
        exit
     else
        bp = bp - residual
     end if
  end do

  DEALLOCATE( grad, uprev, bp, x, residual )

  return
end SUBROUTINE SparseBregmanFPC

SUBROUTINE SplitBregman(MaxIt, tol, mu, lambda, N, M, A, f, u)
  !
  ! Performs split Bregman iterations using conjugate gradients (CG) for the
  ! L2 minimizations and shrinkage for L1 minimizations.
  !
  !    u = arg min_u { ||u||_1 + mu/2 ||Au-f||_2^2 }
  !
  ! The algorithm is described in T. Goldstein and S. Osher,
  ! "The split Bregman method for L1 regularized problems",
  ! SIAM Journal on Imaging Sciences Volume 2 Issue 2, Pages 323-343 (2009).
  !
  ! Input parameters:
  !   MaxIt   - Number of outer split Bregman loops
  !   tol     - Required tolerance for the residual. The algorithm stops when
  !             tol > ||Au-f||_2 / ||f||_2
  !   mu      - weight for the L1 norm of the solution
  !   lambda  - weight for the split constraint (affects speed of convergence, not the result)
  !   N       - number of unknown expansion coefficients [ =length(u) ]
  !   M       - number of measurements [ =length(f) ]
  !   A       - sensing matrix A
  !   f       - array with measured signal values (of length M)
  !   u       - solution array (of length N)
  !
  ! Output:
  !   u       - solution
  !
  integer, intent(in)             :: MaxIt, N, M
  double precision, intent(in)    :: tol, mu, lambda
  double precision,intent(in)     :: A(M,N), f(M)
  double precision,intent(out)  :: u(N)
!f2py intent(hide) :: M, N
!f2py intent(in) :: A, f
!f2py intent(out) :: u

  integer k, MaxCGit
  double precision crit1, crit2
  double precision, allocatable:: uprev(:), b(:), d(:), bp(:)

  MaxCGit = MAX(10,N/2)
  crit1 = 1d0
  crit2 = 1d0

  ALLOCATE( uprev(N), b(N), d(N), bp(N) )

  b = 0d0
  d = 0d0

  do k = 1, MaxIt

     uprev = u

     bp = d - b
     call CGmin(N, M, A, f, bp, mu, lambda, MaxCGit, CGtol*crit1, u)

     d = b + u
     call Shrink(d, N, 1d0/lambda)

     crit1 = SQRT(dot_product(u-uprev,u-uprev)/dot_product(u,u))
     crit2 = SQRT(dot_product(u-d,u-d)/dot_product(u,u))
     if (mod(k, 5)==1) then
       print '(a,i3,2(a,f10.6))', ' SplitBregman: it=', k, ', |dU|/|U| = ', crit1, ', |d-U|/|U| = ', crit2
     end if
     if ( crit1 <= tol ) exit

     b = b + u - d

  end do

  if ( crit1 > tol ) then
     print '(2(a,f10.6))', ' Did not reach prescribed accuracy in SplitBregman: |dU|/|U| = ', crit1, &
          ', ||d-U||/||U|| = ', crit2
  end if

  DEALLOCATE( uprev, b, d, bp )
  return

end SUBROUTINE SplitBregman

SUBROUTINE SparseSplitBregman(MaxIt, tol, mu, lambda, N, M, nA, Aval, iAx, f, u)
  !
  ! Performs split Bregman iterations using conjugate gradients (CG) for the
  ! L2 minimizations and shrinkage for L1 minimizations.
  !
  !    u = arg min_u { ||u||_1 + mu/2 ||Au-f||_2^2 }
  !
  ! This version uses sparse sensing matrices A.
  !
  ! The algorithm is described in T. Goldstein and S. Osher,
  ! "The split Bregman method for L1 regularized problems",
  ! SIAM Journal on Imaging Sciences Volume 2 Issue 2, Pages 323-343 (2009).
  !
  ! Input parameters:
  !   MaxIt   - Number of outer split Bregman loops
  !   tol     - Required tolerance for the residual. The algorithm stops when
  !             tol > ||Au-f||_2 / ||f||_2
  !   mu      - weight for the L1 norm of the solution
  !   lambda  - weight for the split constraint (affects speed of convergence, not the result)
  !   N       - number of unknown expansion coefficients [ =length(u) ]
  !   M       - number of measurements [ =length(f) ]
  !   nA      - number of nonzero values of the sensing matrix A
  !   Aval    - nonzero values of the sensing matrix; the maximum eigenvalue of A.AT should be <= 1;
  !             this can be enforced by dividing both A and f with lambda=Sqrt(Max(Eigenvalues(A.Transpose(A))))
  !   iAx     - indices of the nonzero elements of A; values of iAx are within the range (1:M,1:N)
  !   f       - array with measured signal values (of length M)
  !   u       - solution array (of length N)
  !
  ! Output:
  !   u       - solution
  !
  integer, intent(in) :: MaxIt, N, M, nA, iAx(nA,2)
  double precision, intent(in) :: tol, mu, lambda
  double precision,intent(in) :: Aval(nA), f(M)
  double precision,intent(out) :: u(N)

  integer k, MaxCGit
  double precision crit1, crit2
  double precision, allocatable:: uprev(:), b(:), d(:), bp(:)

  MaxCGit = MAX(10,N/5)
  crit1 = 1d0
  crit2 = 1d0

  ALLOCATE( uprev(N), b(N), d(N), bp(N) )
  b = 0d0
  d = 0d0

  do k = 1, MaxIt

     uprev = u

     bp = d - b
     call SparseCGmin(N, M, nA, Aval, iAx, f, bp, mu, lambda, MaxCGit, CGtol*crit1, u)

     d = b + u
     call Shrink(d, N, 1d0/lambda)

     crit1 = SQRT(DOT_PRODUCT(u-uprev,u-uprev)/DOT_PRODUCT(u,u))
     crit2 = SQRT(DOT_PRODUCT(u-d,u-d)/DOT_PRODUCT(u,u))
     print '(a,i3,2(a,f10.6))', ' SplitBregman: it=', k, ', ||deltaU||/||U|| = ', crit1, &
          ', ||d-U||/||U|| = ', crit2
     if ( crit1 <= tol ) exit

     b = b + u - d

  end do

  if ( crit1 > tol ) then
     print '(2(a,f10.6))', ' Did not reach prescribed accuracy in SplitBregman: ||deltaU||/||U|| = ', crit1, &
          ', ||d-U||/||U|| = ', crit2
  end if

  DEALLOCATE( uprev, b, d, bp )
  return

end SUBROUTINE SparseSplitBregman

SUBROUTINE CGmin(N, M, A, f, b, mu, lambda, MaxIt, gtol, u)
  !
  ! Conjugate gradient routine to perform L2-based minimization of
  !
  !     min_u { mu/2 ||Au-f||_2^2 + lambda/2 ||b-u||_2^2 }
  !
  ! Algorithm is described in S. Boyd and L. Vandenberghe,
  ! "Convex Optimization" (Cambridge University Press, 2004).
  !
  ! Inut parameters:
  !    A    - sensing matrix of dimensions (M,N)
  !    M    - number of measurements
  !    N    - number of expansion coefficients
  !    f    - values of measurements
  !    b    - vector enforcing the split-off L1 constraint
  !    mu   - weight of the L2 constraint on Au=f
  !    lambda - weight of the split-off constraint
  !    MaxIt  - max. number of CG iterations
  !    gtol - tolerance for the gradient; exit if gtol > ||grad||_2
  !    u    - starting guess for the solution
  !
  ! Output parameter:
  !    u    - converged solution
  !
  integer, intent(in) :: MaxIt, N, M
  double precision, intent(in) :: gtol, mu, lambda
  double precision,intent(in) :: A(M,N), f(M), b(N)
  double precision,intent(out) :: u(N)

  integer k
  double precision, allocatable:: p(:), r(:), rp(:), x(:)
  double precision beta, alpha, delta, deltaprev

  ALLOCATE( p(N), r(N), rp(N), x(M) )

  x = MATMUL(A,u) - f
  r = -( mu * MATMUL(TRANSPOSE(A),x) - lambda * (b - u) )

  p = r
  delta = DOT_PRODUCT(r,r)
  !    print '(a,f16.4)', ' initial norm of gradient = ', SQRT(delta)

  do k = 1, MaxIt

     x = MATMUL(A,p)
     rp = mu * MATMUL(TRANSPOSE(A),x) + lambda * p

     alpha = delta / DOT_PRODUCT(p,rp)

     !     print '(a,f16.6)', ' gradient check = ', DOT_PRODUCT(r,r - alpha * rp)

     u = u + alpha * p
     r = r - alpha * rp

     deltaprev = delta
     delta = DOT_PRODUCT(r,r)

     !     print '(a,f16.4)', ' norm of gradient = ', SQRT(delta)

     if( SQRT(delta) < gtol ) then
        !     print '(a,i4,a)', ' Finished after ', k, ' CG iterations.'
        exit
     end if

     beta = delta / deltaprev
     p = beta * p + r

  end do

  if ( SQRT(delta) > gtol ) then
     print '(a,f12.6)', ' Unconverged gradient after CGmin = ', SQRT(delta)
  end if

  DEALLOCATE( p, r, rp, x )

  return
end SUBROUTINE CGmin

SUBROUTINE SparseCGmin(N, M, nA, Aval, iAx, f, b, mu, lambda, MaxIt, gtol, u)
  !
  ! Conjugate gradient routine to perform L2-based minimization of
  !
  !     min_u { mu/2 ||Au-f||_2^2 + lambda/2 ||b-u||_2^2 }
  !
  ! This version uses a sparse sensing matrix A.
  !
  ! Algorithm is described in S. Boyd and L. Vandenberghe,
  ! "Convex Optimization" (Cambridge University Press, 2004).
  !
  ! Inut parameters:
  !    M    - number of measurements
  !    N    - number of expansion coefficients
  !    nA   - number of nonzero values of the sensing matrix A
  !    Aval - nonzero values of the sensing matrix
  !    iAx    - indices of the nonzero elements of A; values of iAx are within the range (1:M,1:N)
  !    f    - values of measurements
  !    b    - vector enforcing the split-off L1 constraint
  !    mu   - weight of the L2 constraint on Au=f
  !    lambda - weight of the split-off constraint
  !    MaxIt  - max. number of CG iterations
  !    gtol - tolerance for the gradient; exit if gtol > ||grad||_2
  !    u    - starting guess for the solution
  !
  ! Output parameter:
  !    u    - converged solution
  !
  integer, intent(in)            :: MaxIt, N, M, nA, iAx(nA,2)
  double precision, intent(in)   :: gtol, mu, lambda
  double precision,intent(in)    :: Aval(nA), f(M), b(N)
  double precision,intent(out) :: u(N)

  integer i, k
  double precision, allocatable:: p(:), r(:), rp(:), x(:)
  double precision beta, alpha, delta, deltaprev

  ALLOCATE( p(N), r(N), rp(N), x(M) )

#ifdef IntelMKL
  !
  ! Use BLAS calls if Intel MKL is available.
  !
  call mkl_dcoogemv('N', M, Aval, iAx(:,1), iAx(:,2), nA, u, x)
  x = x - f
  call mkl_dcoogemv('N', N, Aval, iAx(:,2), iAx(:,1), nA, x, r)
  r = -( mu * r - lambda * (b - u) )
#else
  !
  ! Manual matrix-vector multiplies.
  !
  x = 0d0
  do i = 1, nA
     x(iAx(i,1)) = x(iAx(i,1)) + Aval(i) * u(iAx(i,2))
  end do
  x = x - f

  r = 0d0
  do i = 1, nA
     r(iAx(i,2)) = r(iAx(i,2)) + Aval(i) * x(iAx(i,1))
  end do
  r = -( mu * r - lambda * (b - u) )
#endif

  p = r
  delta = DOT_PRODUCT(r,r)
  !      print '(a,f16.4)', ' norm of gradient = ', SQRT(delta)

  do k = 1, MaxIt

#ifdef IntelMKL
     !
     ! Use BLAS calls if Intel MKL is available.
     !
     call mkl_dcoogemv('N', M, Aval, iAx(1:nA,1), iAx(1:nA,2), nA, p, x)
     call mkl_dcoogemv('N', N, Aval, iAx(1:nA,2), iAx(1:nA,1), nA, x, rp)
#else
     !
     ! Manual matrix-vector multiplies.
     !
     x = 0d0
     do i = 1, nA
        x(iAx(i,1)) = x(iAx(i,1)) + Aval(i) * p(iAx(i,2))
     end do

     rp = 0d0
     do i = 1, nA
        rp(iAx(i,2)) = rp(iAx(i,2)) + Aval(i) * x(iAx(i,1))
     end do
#endif

     rp = mu * rp + lambda * p

     alpha = delta / DOT_PRODUCT(p,rp)
     !     print '(a,f16.6)', ' gradient check = ', dot_product(r,r - alpha * rp)

     u = u + alpha * p
     r = r - alpha * rp

     deltaprev = delta
     delta = DOT_PRODUCT(r,r)
     !     print '(a,f16.4)', ' norm of gradient = ', SQRT(delta)

     if( SQRT(delta) < gtol ) then
        !     print '(a,i4,a)', ' Finished after ', k, ' CG iterations.'
        exit
     end if

     beta = delta / deltaprev
     p = beta * p + r

  end do

  if ( SQRT(delta) > gtol ) then
     print '(a,f12.6)', ' Unconverged gradient after CGmin = ', SQRT(delta)
  end if

  DEALLOCATE( p, r, rp, x )

  return
end SUBROUTINE SparseCGmin

subroutine Shrink( u, N, alpha )
  !
  ! Defines L1-based shrinkage.
  !
  integer, intent(in)  :: N
  double precision, intent(in) :: alpha
  double precision, intent(out) :: u(N)

  where (u > 0d0)
     u = MAX(ABS(u) - alpha, 0d0)
  elsewhere
     u = - MAX(ABS(u) - alpha, 0d0)
  end where

  return
end subroutine Shrink

!--------------------------------------------
!Right preconditioner
subroutine RightPreconditioner(M, N, A, mu, lambda, Vm)
  integer, intent(in) :: M, N
  double precision, intent(in) :: mu, lambda
  double precision, intent(in) :: A(M,N)
  double precision, intent(out) :: Vm(N,N)

  integer i, LDA, lwork, info, ldvl, ldvr, Debug
  double precision tol, beta
  double precision, allocatable :: wr(:), wi(:), work(:), vl(:,:), vr(:,:)
  double precision, allocatable :: mt(:,:)

  tol=1d-8
  beta=0
  Debug=0
  LDA=N
  lwork=10*N
  ldvl=N
  ldvr=N
  allocate(mt(N,N), wr(N), wi(N), work(max(1,lwork)), vl(ldvl,N), vr(ldvr,N))

  !print *, "A:", size(A)
  !mt=mu*matmul(transpose(A), A)
  !much faster
  call dgemm('N', 'N', N, N, M, mu, transpose(A), N, A, M, beta, mt, N)
  !print *, "N:", N

  do i=1, N
     mt(i,i)=mt(i,i)+lambda
  end do
  mt=(mt+transpose(mt))/2d0

  if (Debug > 0) then
     print *, 'mt: '
     print *, shape(mt)
     !print '(4(f8.4,4x))', mt
  end if

  !print *, "---Begin deysv:"
  call dsyev('V', 'L', N, mt, LDA, wr, work, lwork, info)
  !print *, "---End deysv"
  !  call dgeev('N', 'V', N, mt, LDA, wr, wi, vl, ldvl, vr, ldvr, work, lwork, info)

  if (Debug >0) then
     print *, 'wr: '
     print '(4(f8.4, 4x))', wr
     print *, 'mt: '
     do i=1, N
        print '(4f16.8)', mt(:,i)
     end do
  end if

  Vm=0d0
  do i=1, N
     Vm(i,i)=1d0/sqrt(wr(i))
  end do
  Vm=matmul(mt, matmul(Vm, transpose(mt)))

  deallocate(wr, wi, work, vl, vr, mt)

  return
end subroutine RightPreconditioner

!--------------------------------------------
!conjugate gradient method for splitbregman

subroutine CGmin2(M, N, A, f, C, b, u, mu, lambda, MaxIt, gtol)
  !
  ! Conjugate gradient routine to perform L2-based minimization of
  !
  !     min_u { mu/2 ||Au-f||_2^2 + lambda/2 ||b-Cu||_2^2 }
  !
  ! Algorithm is described in S. Boyd and L. Vandenberghe,
  ! "Convex Optimization" (Cambridge University Press, 2004).
  !
  ! Inut parameters:
  !    A    - sensing matrix of dimensions (M,N)
  !    C    - L1 norm matrix of dimensions (N',N)
  !    M    - number of measurements
  !    N    - number of expansion coefficients
  !    N'   -
  !    f    - values of measurements
  !    b    - vector enforcing the split-off L1 constraint
  !    mu   - weight of the L2 constraint on Au=f
  !    lambda - weight of the split-off constraint
  !    MaxIt  - max. number of CG iterations
  !    gtol - tolerance for the gradient; exit if gtol > ||grad||_2
  !    u    - starting guess for the solution
  !
  ! Output parameter:
  !    u    - converged solution
  !
  integer, intent(in) :: MaxIt, M, N
  double precision, intent(in) :: gtol, mu, lambda
  double precision, intent(in) :: A(M,N), f(M), C(N,N), b(N)
  double precision, intent(out) :: u(N)

  integer k
  double precision, allocatable :: p(:), r(:), rp(:), x(:)
  double precision beta, alpha, delta, deltaprev

  allocate(p(N), r(N), rp(N), x(N))
  p=0d0
  r=0d0
  rp=0d0

!  x=matmul(A,u)-f
  r=-mu*matmul(transpose(A),matmul(A,u)-f)-lambda*matmul(transpose(C),matmul(C,u)-b)
  p=r
  delta=dot_product(r, r)

  do k=1, MaxIt
     rp=mu*matmul(transpose(A),matmul(A, p))+lambda*matmul(transpose(C), matmul(C, p))
     alpha=delta/dot_product(p, rp)

     u=u+alpha*p
     r=r-alpha*rp

     deltaprev=delta
     delta=dot_product(r, r)

     if (sqrt(delta)<gtol) then
        !print *
        !print *, 'Finished: k=', k
        exit
     end if

     beta=delta/deltaprev
     p=beta*p+r
  end do

  if (sqrt(delta) > gtol) then
     print '(a,f12.6)', 'Unconverged gradient after CGmin2 = ', sqrt(delta)
  end if

  deallocate(p, r, rp, x)

  return

end subroutine CGmin2

!--------------------------------------------
!norm

!--------------------------------------------
!splitbregman2
subroutine splitbregman2(MaxIt, tol, mu, lambda, N, M, A, f, C, u)
  integer, intent(in) :: MaxIt, M, N
  double precision, intent(in) :: tol, mu, lambda
  double precision, intent(in) :: A(M,N), f(M), C(N,N)
  double precision, intent(out) :: u(N)

  integer k, MaxCGit, nPrint, converged
  double precision crit1, crit2, CGtol
  double precision, allocatable :: uprev(:), b(:), d(:)
  MaxCGit=min(100, N)
  CGtol=1d-3
  crit1=1d0
  crit2=1d0
  nPrint=int(MaxIt/10)
  converged=0d0

  allocate(uprev(N), b(N), d(N))
  uprev=0d0
  b=0d0
  d=0d0

  do k=1, MaxIt
     uprev=u
     call CGmin2(M, N, A, f, C, d-b, u, mu, lambda, MaxCGit, crit1*CGtol)
     d=b+matmul(C, u)
     call Shrink(d, N, 1/lambda)
     crit1=sqrt(dot_product(uprev-u, uprev-u)/dot_product(u,u))
     crit2=sqrt(dot_product(matmul(C,u)-d, matmul(C,u)-d)/dot_product(u,u))

     if (mod(k,nPrint)==0) then
        !print '(2(f12.6))', "Bregman: ||du||/||u|| = ",crit1, ", ||Cu-d||/||u|| = ",crit2
        print 100, crit1, crit2
     end if
  100 format("Bregman: ||du||/||u|| = ", f12.6, ", ||Cu-d||/||u|| = ", f12.6)
     if (crit1<=tol .and. crit2<=tol) then
        converged=1
        exit
     end if

     b=b+matmul(C,u)-d
  end do

  if (converged<=0) then
     print *, "SplitBregman2 stopped with ||du||/||u|| = ", sqrt(dot_product(uprev-u, uprev-u)/dot_product(u,u))
     print *, "Finished ",k," split Bregman iteractions in total!"
  end if

  deallocate(uprev, b, d)

  return
end subroutine splitbregman2

!--------------------------------------------
!Bregman with right preconditioner, with constraint "C"
! hence the suffix "2"
subroutine BregmanRPrecond2(maxIter, M, N, A, b, mu, lambda, tol, C, u)
  integer, intent(in) :: maxIter, M, N
  double precision, intent(in) :: mu, lambda, tol
  double precision, intent(in) :: A(M,N), b(M), C(N,N)
  double precision, intent(out) :: u(N)

  integer i, j
  double precision sum
  double precision, allocatable :: Bm(:,:), Vm(:,:), BmVm(:,:)

  allocate(Bm(M,N), Vm(N,N), BmVm(M,N))

  !print *, "-Begin BregmanRPrecond2:"

  do i=1, N
     do j=1, N
        sum=sum+C(i,j)*C(i,j)
     end do
  end do

  if (sum<=1d-12) then
     Bm=A
  else
     Bm=matmul(A,C)
  end if

  !print *, "--Begin RightPreconditioner:"
  call RightPreconditioner(M, N, A, mu, lambda, Vm)
  !print *, "--End RightPreconditioner."

  BmVm=matmul(Bm, Vm)
  call splitbregman2(maxIter, tol, mu, lambda, N, M, BmVm, b, Vm, u)

  if (sum<=1d-12) then
     u=matmul(Vm, u)
  else
     u=matmul(C, matmul(Vm, u))
  end if

  deallocate(Bm, Vm, BmVm)

  return
end subroutine BregmanRPrecond2

!--------------------------------------------
!Bregman with right preconditioner
subroutine BregmanRPrecond(maxIter, M, N, A, b, mu, lambda, tol, u)
  integer, intent(in) :: maxIter, M, N
  double precision, intent(in) :: mu, lambda, tol
  double precision, intent(in) :: A(M,N), b(M)
  double precision, intent(out) :: u(N)

  integer i, j
  double precision, allocatable :: Vm(:,:), BmVm(:,:)

!f2py intent(hide),depend(A) :: M=shape(M,0), N=shape(M,1)
!f2py intent(in) :: A, b
!f2py intent(out) :: u
  allocate(Vm(N,N), BmVm(M,N))

  ! print *, "--Begin RightPreconditioner:"
  call RightPreconditioner(M, N, A, mu, lambda, Vm)
  !print *, "--End RightPreconditioner."

  BmVm=matmul(A, Vm)
  call splitbregman(maxIter, tol, mu, lambda, N, M, BmVm, b, u)

  u=matmul(Vm, u)

  deallocate(Vm, BmVm)

  return
end subroutine BregmanRPrecond

!--------------------------------------------
!random sampling
subroutine ransam(X, A, B, N, K)
  integer, intent(in) :: N, K
  integer, intent(in) :: X(N)
  integer, intent(inout) :: A(K)
  integer, intent(inout) :: B(N-K)

  integer Neff, index, Debug, isin, iB
  integer Xtmp(N)
  double precision val
  integer i, j

  if (K>N) then
     print *, 'Pool too small!'
  end if

  Xtmp=X
  if (dot_product(Xtmp, Xtmp) < 1d-12) then
     do i=1, N
        Xtmp(i)=i
     end do
  end if
  A=0d0
  Debug=0d0

! random_seed
  call random_seed()
! check random number generator
  if (Debug>0) then
     do i=1, 10
        call random_number(val)
        print *, 'val:', val
     end do
     print *
  end if

  do i=1, K
     call random_number(val)
     Neff=N-i+1
     index=int(Neff*val)+1

     if (Debug>0) then
        print *, 'val: ', val
        print *, 'index: ', index
        print *, 'Selected: ', X(index)
        print *, '---------------------------'
     end if

     A(i)=Xtmp(index)
     do j=index, N-1
        Xtmp(j)=Xtmp(j+1)
     end do
  end do

  if(minval(A)<1 .and. maxval(A)>N) then
     print *, 'Something wrong with random sampling!'
  end if

  iB=1
  do i=1, N
     isin=0
     do j=1, K
        if (X(i)==A(j)) then
           isin=1
        end if
     end do
     if (isin==0) then
        B(iB)=X(i)
        iB=iB+1
     end if
  end do

end subroutine ransam

!csfitting Amat(Mtot, Ntot); En(Mtot); Wt(Moto)
subroutine csfit(Amat, En, Wt, Mtot, Ntot, solfinal)
  integer i, j, k
  integer Mtot, Ntot, nline, nout, nin, nmu, nsub

  double precision lambda
  !in
  double precision Amat(Mtot,Ntot), En(Mtot), Wt(Mtot)
  double precision, allocatable :: mulist(:), theC(:,:)
  integer, allocatable :: Inlist(:), Outlist(:), X(:)

  integer nsubin, nsubout, index
  double precision mu, relerr, errtmp
  integer, allocatable :: Insublist(:), Outsublist(:)
  double precision, allocatable :: Asub(:,:), Esub(:), Csub(:,:), sol(:)
  double precision, allocatable :: Aout(:,:), Eout(:), Etmp(:)
  !out
  double precision, intent(out) :: solfinal(Ntot)

!f2py intent(hide) :: Mtot, Ntot
!f2py intent(in) :: Amat, En, Wt
!f2py intent(out) :: solfinal

  !main program
  !select training set
  nsub=2
  nout=int(Mtot*0.12)
  nin=Mtot-nout
  allocate(Inlist(nin), Outlist(nout), X(Mtot))
  do i=1, Mtot
     X(i)=i
  end do
  call ransam(X, Inlist, Outlist, Mtot, nin)
  !print *, 'Shape of Inlist: ', shape(Inlist)
  print *, 'Selected for fitting: ', shape(Inlist)

  !set mu and lambda
  lambda=3d0
  nmu=5
  allocate(mulist(nmu))
  do i=1, nmu
     mulist(i)=dble(3d0)**dble(i-2d0)
  end do
  print *
  print *, 'lambda: ', lambda
  print *, 'mulist: '
  print '(5(f8.4, 4x))', mulist

  !set theC(selected fitting)
  allocate(theC(Ntot, Ntot))
  theC=0d0
  do i=1, Ntot
     theC(i, i)=1d0
  end do
  print *
  print *, "theC: (Identity Matrix)"
  print *, "Shape: "
  print *, shape(theC)
  print *

  !start main loop
  !BregmanRPrecond2(M, N, A, b, mu, lambda, C, u)
  nsubin=int(nin*0.6)
  nsubout=nin-nsubin
  allocate(Insublist(nsubin), Outsublist(nsubout))
  allocate(Asub(nsubin, Ntot), Esub(nsubin), Csub(Ntot, Ntot), sol(Ntot))
  allocate(Aout(nout, Ntot), Eout(nout), Etmp(nout))
  Csub=0d0
  sol=0d0
  solfinal=0d0
  errtmp=1d0

!  call ransam(Inlist, Insublist, Outsublist, nin, nsubin)
  print *
  print *, 'Split Bregman begin...'
  print *
  do i=1, nmu  ! loop over mulist
     mu=mulist(i)
     print 202, mu
 202 format("Mu = ", f8.4, '------------------------------------------------------')
     do j=1, nsub  ! loop over subset list

        sol=0d0
        call ransam(Inlist, Insublist, Outsublist, nin, nsubin)
        print *, "Selected forces: ", nsubin
        do k=1, nsubin
           index=Insublist(k)
           Asub(k,:)=Amat(index,:)
           Esub(k)=En(index)
        end do

        call BregmanRPrecond2(200, nsubin, Ntot, Asub, Esub, mu, lambda, 1D-4, Csub, sol)
        do k=1, nout
           index=Outlist(k)
           Aout(k,:)=Amat(index,:)
           Eout(k)=En(index)
        end do

        Etmp=matmul(Aout, matmul(theC, sol))
        relerr=sqrt(dot_product(Etmp-Eout, Etmp-Eout)/dot_product(Eout,Eout))
        print *, 'relative error: ', relerr

        !select the sol with minimum relerr
        if (relerr < errtmp) then
           errtmp=relerr
           solfinal=sol
        end if
        print *

     end do !end loop over subset

     print *, 'Finished mu: ', mu
     print *

  end do !end loop over mulist

  print *, '------------------------------------------------'
  print *, 'Minimum relative error: ', errtmp
  print *, 'solfinal: '
  print *, 'shape: ', shape(solfinal)
  open(33,file='sol',form='formatted',status='unknown')
  do i=1, Ntot
     write(33, *) solfinal(i)
  end do
  close(33)

end subroutine csfit

end MODULE bregman


      subroutine vecjac(n,x,fjac,ldfjac,nprob)
      integer n,ldfjac,nprob
      double precision x(n),fjac(ldfjac,n)
c     **********
c
c     subroutine vecjac
c
c     This subroutine defines the Jacobian matrices of fourteen
c     test functions. The problem dimensions are as described
c     in the prologue comments of vecfcn.
c
c     The subroutine statement is
c
c       subroutine vecjac(n,x,fjac,ldfjac,nprob)
c
c     where
c
c       n is a positive integer variable.
c
c       x is an array of length n.
c
c       fjac is an output n by n array which contains the
c         Jacobian matrix of the nprob function evaluated at x.
c
c       ldfjac is a positive integer variable not less than n
c         which specifies the leading dimension of the array fjac.
c
c       nprob is a positive integer variable which defines the
c         number of the problem. nprob must not exceed 14.
c
c     Subprograms called
c
c       FORTRAN-supplied ... atan,cos,dble,exp,max,min,sin,sqrt
c
c     Argonne National Laboratory. MINPACK Project. march 1980.
c     Burton S. Garbow, Kenneth E. Hillstrom, Jorge J. More
c
c     **********
      integer i,j,k,ml,mu
      double precision c1,c3,c4,c5,c6,c9,eight,fiftn,five,four,h,
     *                 hundrd,one,prod,six,sum,sum1,sum2,temp,temp1,
     *                 temp2,temp3,temp4,ten,three,ti,tj,tk,tpi,
     *                 twenty,two,zero
      data zero,one,two,three,four,five,six,eight,ten,fiftn,twenty,
     *     hundrd
     *     /0.0d0,1.0d0,2.0d0,3.0d0,4.0d0,5.0d0,6.0d0,8.0d0,1.0d1,
     *      1.5d1,2.0d1,1.0d2/
      data c1,c3,c4,c5,c6,c9 /1.0d4,2.0d2,2.02d1,1.98d1,1.8d2,2.9d1/
c
c     Jacobian routine selector.
c
      go to (10,20,50,60,90,100,200,230,290,320,350,380,420,450),
     *      nprob
c
c     Rosenbrock function.
c
   10 continue
      fjac(1,1) = -one
      fjac(1,2) = zero
      fjac(2,1) = -twenty*x(1)
      fjac(2,2) = ten
      return
c
c     Powell singular function.
c
   20 continue
      do 40 k = 1, 4
         do 30 j = 1, 4
            fjac(k,j) = zero
   30       continue
   40    continue
      fjac(1,1) = one
      fjac(1,2) = ten
      fjac(2,3) = sqrt(five)
      fjac(2,4) = -fjac(2,3)
      fjac(3,2) = two*(x(2) - two*x(3))
      fjac(3,3) = -two*fjac(3,2)
      fjac(4,1) = two*sqrt(ten)*(x(1) - x(4))
      fjac(4,4) = -fjac(4,1)
      return
c
c     Powell badly scaled function.
c
   50 continue
      fjac(1,1) = c1*x(2)
      fjac(1,2) = c1*x(1)
      fjac(2,1) = -exp(-x(1))
      fjac(2,2) = -exp(-x(2))
      return
c
c     Wood function.
c
   60 continue
      do 80 k = 1, 4
         do 70 j = 1, 4
            fjac(k,j) = zero
   70       continue
   80    continue
      temp1 = x(2) - three*x(1)**2
      temp2 = x(4) - three*x(3)**2
      fjac(1,1) = -c3*temp1 + one
      fjac(1,2) = -c3*x(1)
      fjac(2,1) = -two*c3*x(1)
      fjac(2,2) = c3 + c4
      fjac(2,4) = c5
      fjac(3,3) = -c6*temp2 + one
      fjac(3,4) = -c6*x(3)
      fjac(4,2) = c5
      fjac(4,3) = -two*c6*x(3)
      fjac(4,4) = c6 + c4
      return
c
c     Helical valley function.
c
   90 continue
      tpi = eight*atan(one)
      temp = x(1)**2 + x(2)**2
      temp1 = tpi*temp
      temp2 = sqrt(temp)
      fjac(1,1) = hundrd*x(2)/temp1
      fjac(1,2) = -hundrd*x(1)/temp1
      fjac(1,3) = ten
      fjac(2,1) = ten*x(1)/temp2
      fjac(2,2) = ten*x(2)/temp2
      fjac(2,3) = zero
      fjac(3,1) = zero
      fjac(3,2) = zero
      fjac(3,3) = one
      return
c
c     Watson function.
c
  100 continue
      do 120 k = 1, n
         do 110 j = k, n
            fjac(k,j) = zero
  110       continue
  120    continue
      do 170 i = 1, 29
         ti = dble(i)/c9
         sum1 = zero
         temp = one
         do 130 j = 2, n
            sum1 = sum1 + dble(j-1)*temp*x(j)
            temp = ti*temp
  130       continue
         sum2 = zero
         temp = one
         do 140 j = 1, n
            sum2 = sum2 + temp*x(j)
            temp = ti*temp
  140       continue
         temp1 = two*(sum1 - sum2**2 - one)
         temp2 = two*sum2
         temp = ti**2
         tk = one
         do 160 k = 1, n
            tj = tk
            do 150 j = k, n
               fjac(k,j) = fjac(k,j)
     *                     + tj
     *                       *((dble(k-1)/ti - temp2)
     *                         *(dble(j-1)/ti - temp2) - temp1)
               tj = ti*tj
  150          continue
            tk = temp*tk
  160       continue
  170    continue
      fjac(1,1) = fjac(1,1) + six*x(1)**2 - two*x(2) + three
      fjac(1,2) = fjac(1,2) - two*x(1)
      fjac(2,2) = fjac(2,2) + one
      do 190 k = 1, n
         do 180 j = k+1, n
            fjac(j,k) = fjac(k,j)
  180       continue
  190    continue
      return
c
c     Chebyquad function.
c
  200 continue
      tk = one/dble(n)
      do 220 j = 1, n
         temp1 = one
         temp2 = two*x(j) - one
         temp = two*temp2
         temp3 = zero
         temp4 = two
         do 210 k = 1, n
            fjac(k,j) = tk*temp4
            ti = four*temp2 + temp*temp4 - temp3
            temp3 = temp4
            temp4 = ti
            ti = temp*temp2 - temp1
            temp1 = temp2
            temp2 = ti
  210       continue
  220    continue
      return
c
c     Brown almost-linear function.
c
  230 continue
      prod = one
      do 250 j = 1, n
         prod = x(j)*prod
         do 240 k = 1, n
            fjac(k,j) = one
  240       continue
         fjac(j,j) = two
  250    continue
      do 280 j = 1, n
         temp = x(j)
         if (temp .eq. zero) then
            temp = one
            prod = one
            do 260 k = 1, n
               if (k .ne. j) prod = x(k)*prod
  260          continue
            end if
         fjac(n,j) = prod/temp
  280    continue
      return
c
c     Discrete boundary value function.
c
  290 continue
      h = one/dble(n+1)
      do 310 k = 1, n
         temp = three*(x(k) + dble(k)*h + one)**2
         do 300 j = 1, n
            fjac(k,j) = zero
  300       continue
         fjac(k,k) = two + temp*h**2/two
         if (k .ne. 1) fjac(k,k-1) = -one
         if (k .ne. n) fjac(k,k+1) = -one
  310    continue
      return
c
c     Discrete integral equation function.
c
  320 continue
      h = one/dble(n+1)
      do 340 k = 1, n
         tk = dble(k)*h
         do 330 j = 1, n
            tj = dble(j)*h
            temp = three*(x(j) + tj + one)**2
            fjac(k,j) = h*min(tj*(one-tk),tk*(one-tj))*temp/two
  330       continue
         fjac(k,k) = fjac(k,k) + one
  340    continue
      return
c
c     Trigonometric function.
c
  350 continue
      do 370 j = 1, n
         temp = sin(x(j))
         do 360 k = 1, n
            fjac(k,j) = temp
  360       continue
         fjac(j,j) = dble(j+1)*temp - cos(x(j))
  370    continue
      return
c
c     Variably dimensioned function.
c
  380 continue
      sum = zero
      do 390 j = 1, n
         sum = sum + dble(j)*(x(j) - one)
  390    continue
      temp = one + six*sum**2
      do 410 k = 1, n
         do 400 j = k, n
            fjac(k,j) = dble(k*j)*temp
            fjac(j,k) = fjac(k,j)
  400       continue
         fjac(k,k) = fjac(k,k) + one
  410    continue
      return
c
c     Broyden tridiagonal function.
c
  420 continue
      do 440 k = 1, n
         do 430 j = 1, n
            fjac(k,j) = zero
  430       continue
         fjac(k,k) = three - four*x(k)
         if (k .ne. 1) fjac(k,k-1) = -one
         if (k .ne. n) fjac(k,k+1) = -two
  440    continue
      return
c
c     Broyden banded function.
c
  450 continue
      ml = 5
      mu = 1
      do 480 k = 1, n
         do 460 j = 1, n
            fjac(k,j) = zero
  460       continue
         do 470 j = max(1,k-ml), min(k+mu,n)
            if (j .ne. k) fjac(k,j) = -(one + two*x(j))
  470       continue
         fjac(k,k) = two + fiftn*x(k)**2
  480    continue
      return
c
c     Last card of subroutine vecjac.
c
      end


      SUBROUTINE foo(N,X,Y,Z,F3,F1,W)
      INTEGER N
      REAL*8  X(N),Y(N),Z(N),F3(0:N),F1(0:N),W(0:N)
      REAL*8 DT

      INTEGER I,J

       DO 10,I=1,14
         X(I) = 1.0D0
 10   CONTINUE

      DO 20,I=1,14,3
         Y(I) = 1.0D0
 20   CONTINUE

       DO 30,I=N+1,N+20,3
         Z(I) = 1.0D0
 30   CONTINUE

      DO 40,I=0,N
         DO 50,J=I,I+N
            F3(I) = F3(I) + F1(J) * W(J-I)
 50      CONTINUE
         F3(I) = F3(I) * DT
 40   CONTINUE

      END


submodule(euler_interface_m) euler_prob_0041_m
    implicit none

contains

    module character(len=20) function euler0041()
        write (euler0041, "(i20)") ans(7654321)
    end function euler0041

    integer function ans(n)
        use euler_primes_m, only: sieve_of_Eratosthenes
        implicit none
        integer, intent(in) :: n
        logical, allocatable :: is_prime(:)
        integer :: i

        call sieve_of_Eratosthenes(n, is_prime)
        do i = n, 1, -1
            if (is_prime(i) .and. is_pandigital(i, digs_of_int(i))) exit
        end do

        ans = i
    end function ans
end submodule euler_prob_0041_m


C NCLFORTSTART
      subroutine mocloops(nyaux,mlon,nlat,kdep,nrx,tlat,lat_aux_grid
     +                   ,rmlak,work1,work2,work3,wmsg,tmp1,tmp2,tmp3)
      implicit none
      integer  nyaux,mlon,nlat,kdep,nrx

      double precision     work1(mlon,nlat,kdep), work2(mlon,nlat,kdep)
     +                    ,work3(mlon,nlat,kdep), wmsg
      double precision     tmp1(nyaux,kdep,2)   , tmp2(nyaux,kdep,2)
     +                    ,tmp3(nyaux,kdep,2)
      double precision     lat_aux_grid(nyaux)  , tlat(mlon,nlat)

      integer  rmlak(mlon,nlat,2)
C NCLEND
      integer  ny, kd, nl, ml, nr
c c c logical  section(mlon,nlat,kdep)

c initilize
      do nr=1,nrx
        do kd=1,kdep
          do ny=1,nyaux
             tmp1(ny,kd,nr) = 0.0d0
             tmp2(ny,kd,nr) = 0.0d0
             tmp3(ny,kd,nr) = 0.0d0
          end do
        end do
      end do

c globe [note: rmlak(:,:,1)]

      do ny=2,nyaux

        do nl=1,nlat
          do ml=1,mlon
             if (tlat(ml,nl).ge.lat_aux_grid(ny-1) .and.
     +           tlat(ml,nl).lt.lat_aux_grid(ny)   .and.
     +           rmlak(ml,nl,1).eq.1) then

                 do kd=1,kdep
                    if (work1(ml,nl,kd).ne.wmsg)  then
                        tmp1(ny,kd,1) = tmp1(ny,kd,1) + work1(ml,nl,kd)
                        tmp2(ny,kd,1) = tmp2(ny,kd,1) + work2(ml,nl,kd)
                        tmp3(ny,kd,1) = tmp3(ny,kd,1) + work3(ml,nl,kd)
                    end if
                 end do

             end if
          end do
        end do

      end do

c atlantic [note: rmlak(:,:,2)]

      do ny=2,nyaux

        do nl=1,nlat
          do ml=1,mlon
             if (tlat(ml,nl).ge.lat_aux_grid(ny-1) .and.
     +           tlat(ml,nl).lt.lat_aux_grid(ny)   .and.
     +           rmlak(ml,nl,2).eq.1) then

                 do kd=1,kdep
                    if (work1(ml,nl,kd).ne.wmsg)  then
                        tmp1(ny,kd,2) = tmp1(ny,kd,2) + work1(ml,nl,kd)
                        tmp2(ny,kd,2) = tmp2(ny,kd,2) + work2(ml,nl,kd)
                        tmp3(ny,kd,2) = tmp3(ny,kd,2) + work3(ml,nl,kd)
                    end if
                 end do

             end if
          end do
        end do

      end do

      return
      end


! benchmark of the function proj

program benchmark_proj
  implicit none
  integer, parameter :: N0=128, N1=128, N2=64, N=100
  double precision, allocatable :: vx(:,:,:,:), vy(:,:,:,:), vz(:,:,:,:)
  double precision, allocatable :: kx(:,:,:), ky(:,:,:), kz(:,:,:)
  double precision, allocatable :: inv_k_square_nozero(:,:,:)
  real :: start, finish, cumtime
  integer :: i

  allocate(vx(2, N2, N1, N0), vy(2, N2, N1, N0), vz(2, N2, N1, N0))
  allocate(kx(N2, N1, N0), ky(N2, N1, N0), kz(N2, N1, N0))
  allocate(inv_k_square_nozero(N2, N1, N0))

  call random_number(vx)
  call random_number(vy)
  call random_number(vz)
  call random_number(kx)
  call random_number(ky)
  call random_number(kz)
  call random_number(inv_k_square_nozero)

  cumtime = 0

  print*, "This program make some calculations."
  do i = 1, N
     call cpu_time(start)
     call proj(vx, vy, vz, kx, ky, kz, inv_k_square_nozero, N0, N1, N2)
     call cpu_time(finish)
     cumtime = cumtime + finish - start
  enddo
  print '("Mean Time = ",f6.3," ms")', 1000*cumtime/N

  deallocate(vx, vy, vz)
  deallocate(kx, ky, kz)
  deallocate(inv_k_square_nozero)
end program benchmark_proj

subroutine proj(vx, vy, vz, kx, ky, kz, inv_k_square_nozero, N0, N1, N2)

  implicit none

  ! Input/Output
  integer, intent(in) :: N0, N1, N2
  double precision, intent(inout) :: vx(2, N2, N1, N0), vy(2, N2, N1, N0), vz(2, N2, N1, N0)
  double precision, intent(in) :: kx(N2, N1, N0), ky(N2, N1, N0), kz(N2, N1, N0)
  double precision, intent(in) :: inv_k_square_nozero(N2, N1, N0)

  ! Locals
  double precision :: tmp(2)
  integer:: i, j, k

  do k = 1, N0
     do j = 1, N1
        do i = 1, N2
           tmp(1:2) = (kx(i,j,k) * vx(1:2,i,j,k) &
                       + ky(i,j,k) * vy(1:2,i,j,k) &
                       + kz(i,j,k) * vz(1:2,i,j,k) &
                      ) * inv_k_square_nozero(i,j,k)

           vx(1:2,i,j,k) = vx(1:2,i,j,k) - kx(i,j,k) * tmp
           vy(1:2,i,j,k) = vy(1:2,i,j,k) - ky(i,j,k) * tmp
           vz(1:2,i,j,k) = vz(1:2,i,j,k) - kz(i,j,k) * tmp
        enddo
     enddo
  enddo

end subroutine proj


submodule(euler_interface_m) euler_prob_0004_m
    implicit none

contains

    module character(len=20) function euler0004()
        write (euler0004, "(i20)") ans(999)
    end function euler0004

    integer function ans(n)
        integer, intent(in) :: n
        integer :: a, b, p_max

        p_max = 0
        a = 100

        do a = 100, n
            do b = 100, n
                if (is_palindromic(a*b) .and. a*b > p_max) p_max = a*b
            end do
        end do

        ans = p_max
    end function ans
end submodule euler_prob_0004_m


! { dg-do run }
! Check fix for PR24783 where we did try to resolve the implicit type
! from the wrong namespace thus rejecting valid code.
      MODULE mod1
      IMPLICIT NONE
      CONTAINS
      SUBROUTINE sub(vec, ny)
      IMPLICIT REAL (a-h,o-z)
      IMPLICIT INTEGER (i-n)
      DIMENSION vec(ny)
      ny = fun(vec(ny),1,1)
      RETURN
      END SUBROUTINE sub
      REAL FUNCTION fun(r1, i1, i2)
      IMPLICIT REAL (r,f)
      IMPLICIT INTEGER (i)
      DIMENSION r1(i1:i2)
      r1(i1) = i1 + 1
      r1(i2) = i2 + 1
      fun = r1(i1) + r1(i2)
      END FUNCTION fun
      END MODULE mod1

      use mod1
      IMPLICIT REAL (d)
      INTEGER i
      dimension di(5)
      i = 1
      if (fun(di(i),1,2).NE.5) call abort()
      call sub(di(i),i)
      if (i.NE.4) call abort()
      end


MODULE mo_column
  IMPLICIT NONE
CONTAINS
  ! Compute only one column
  SUBROUTINE compute_column(nz, q, t)
    IMPLICIT NONE

    INTEGER, INTENT(IN)   :: nz   ! Size of the array field
    REAL, INTENT(INOUT)   :: t(:) ! Field declared as one column only
    REAL, INTENT(INOUT)   :: q(:) ! Field declared as one column only
    INTEGER :: k                  ! Loop index
    REAL :: c                     ! Coefficient
    REAL :: d                     ! Intermediate variable

    ! CLAW definition
    ! Define the new dimension on which the transformation parallelize the
    ! single column abstraction. In this case, the automatic promotion
    ! deduction will be activated as the data/over clauses are not present.

    !$claw define dimension proma(1:nproma) &
    !$claw sca

    c = 5.345
    DO k = 2, nz
      t(k) = c * k
      d    = t(k)**2
      q(k) = q(k - 1)  + t(k) * c
    END DO
    q(nz) = q(nz) * c
  END SUBROUTINE compute_column
END MODULE mo_column


C$Procedure BSCHOI ( Binary search with order vector, integer )

      INTEGER FUNCTION BSCHOI ( VALUE, NDIM, ARRAY, ORDER )

C$ Abstract
C
C      Do a binary search for a given value within an integer array,
C      accompanied by an order vector. Return the index of the
C      matching array entry, or zero if the key value is not found.
C
C$ Disclaimer
C
C     THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE
C     CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S.
C     GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE
C     ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE
C     PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS"
C     TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY
C     WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A
C     PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC
C     SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE
C     SOFTWARE AND RELATED MATERIALS, HOWEVER USED.
C
C     IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA
C     BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT
C     LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND,
C     INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS,
C     REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE
C     REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY.
C
C     RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF
C     THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY
C     CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE
C     ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE.
C
C$ Required_Reading
C
C     None.
C
C$ Keywords
C
C      ARRAY,  SEARCH
C
C$ Declarations

      IMPLICIT NONE
      INTEGER          VALUE
      INTEGER          NDIM
      INTEGER          ARRAY ( * )
      INTEGER          ORDER ( * )

C$ Brief_I/O
C
C      VARIABLE  I/O  DESCRIPTION
C      --------  ---  --------------------------------------------------
C      VALUE      I   Value to find in ARRAY.
C      NDIM       I   Dimension of ARRAY.
C      ARRAY      I   Array to be searched.
C      ORDER      I   Order vector.
C      BSCHOI     O   Index of VALUE in ARRAY. (Zero if not found.)
C
C$ Detailed_Input
C
C      VALUE       is the value to be found in the input array.
C
C      NDIM        is the number of elements in the input array.
C
C      ARRAY       is the array to be searched.
C
C
C      ORDER       is an order array that can be used to access
C                  the elements of ARRAY in order.
C
C$ Detailed_Output
C
C      BSCHOI      is the index of the input value in the input array.
C                  If ARRAY does not contain VALUE, BSCHOI is zero.
C
C                  If ARRAY contains more than one occurrence of VALUE,
C                  BSCHOI may point to any of the occurrences.
C
C$ Parameters
C
C     None.
C
C$ Files
C
C     None.
C
C$ Exceptions
C
C      Error free.
C
C      1) If NDIM < 1 the value of the function is zero.
C
C$ Particulars
C
C      A binary search is implemented on the input array, whose order
C      is given by an associated order vector. If an element of the
C      array is found to match the input value, the index of that
C      element is returned. If no matching element is found, zero is
C      returned.
C
C$ Examples
C
C      Let ARRAY and ORDER contain the following elements:
C
C            ARRAY         ORDER
C            -----------   -----
C              100             2
C                1             3
C               10             1
C            10000             5
C             1000             4
C
C      Then
C
C            BSCHOI (  1000, 5, ARRAY, ORDER )  = 5
C            BSCHOI (     1, 5, ARRAY, ORDER )  = 2
C            BSCHOI ( 10000, 5, ARRAY, ORDER )  = 4
C            BSCHOI (    -1, 5, ARRAY, ORDER )  = 0
C            BSCHOI (    17, 5, ARRAY, ORDER )  = 0
C
C      That is,
C
C            ARRAY(5) =  1000
C            ARRAY(2) =     1
C            ARRAY(4) = 10000
C
C      (Compare with BSCHOI_2.)
C
C$ Restrictions
C
C      ORDER is assumed to give the order of the elements of ARRAY
C      in increasing order. If this condition is not met, the results
C      of BSCHOI are unpredictable.
C
C$ Author_and_Institution
C
C       I.M. Underwood  (JPL)
C       W.L. Taber      (JPL)
C
C$ Literature_References
C
C       None.
C
C$ Version
C
C-    SPICELIB Version 1.0.0, 18-SEP-1995 (IMU) (WLT)
C
C-&

C$ Index_Entries
C
C     binary search for an integer using an order vector
C
C-&

C
C     Local variables
C
      INTEGER          LEFT
      INTEGER          RIGHT
      INTEGER          I

C
C     Set the initial bounds for the search area.
C
      LEFT  = 1
      RIGHT = NDIM

      DO WHILE ( LEFT .LE. RIGHT )

C
C        Check the middle element.
C
         I = (LEFT+RIGHT)/2

C
C        If the middle element matches, return its location.
C
         IF ( VALUE .EQ. ARRAY(ORDER(I)) ) THEN
            BSCHOI = ORDER(I)
            RETURN

C
C        Otherwise narrow the search area.
C
         ELSE IF ( VALUE .LT. ARRAY(ORDER(I)) ) THEN
            RIGHT = I-1
         ELSE
            LEFT  = I+1
         END IF

      END DO

C
C     If the search area is empty, return zero.
C
      BSCHOI = 0

      RETURN
      END


! ##################################################################################################################################
! Begin MIT license text.
! _______________________________________________________________________________________________________

! Copyright 2019 Dr William R Case, Jr (dbcase29@gmail.com)

! Permission is hereby granted, free of charge, to any person obtaining a copy of this software and
! associated documentation files (the "Software"), to deal in the Software without restriction, including
! without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
! copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to
! the following conditions:

! The above copyright notice and this permission notice shall be included in all copies or substantial
! portions of the Software and documentation.

! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS
! OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN
! THE SOFTWARE.
! _______________________________________________________________________________________________________

! End MIT license text.

      SUBROUTINE ORDER_GAUSS ( KORDER, SSS, HHH )

! Calculates abscissa and weight coefficients for Gaussian integration of order KORDER = 1 to 10.

      USE PENTIUM_II_KIND, ONLY       :  BYTE, LONG, DOUBLE
      USE IOUNT1, ONLY                :  ERR, F04, F06, WRT_ERR, WRT_LOG
      USE SCONTR, ONLY                :  BLNK_SUB_NAM, FATAL_ERR, MAX_ORDER_GAUSS, MEFE
      USE TIMDAT, ONLY                :  TSEC
      USE SUBR_BEGEND_LEVELS, ONLY    :  ORDER_BEGEND
      USE CONSTANTS_1, ONLY           :  ZERO, TWO
      USE CONSTANTS_GAUSS, ONLY       :  HHV, SSV
      USE MODEL_STUF, ONLY            :  EMG_IFE, ERR_SUB_NAM, NUM_EMG_FATAL_ERRS

      USE ORDER_GAUSS_USE_IFs

      IMPLICIT NONE

      CHARACTER(LEN=LEN(BLNK_SUB_NAM)):: SUBR_NAME = 'ORDER_GAUSS'

      INTEGER(LONG), INTENT(IN)       :: KORDER               ! Gaussian integration order to use
      INTEGER(LONG)                   :: I                    ! DO loop index
      INTEGER(LONG)                   :: II                   ! A term in a computed index into SSS, HHH arrays
      INTEGER(LONG)                   :: JJ                   ! A computed index into SSS, HHH arrays
      INTEGER(LONG)                   :: KK                   ! A computed index into SSS, HHH arrays
      INTEGER(LONG)                   :: LL                   ! A computed index into SSS, HHH arrays
      INTEGER(LONG)                   :: MM                   ! A computed index into SSS, HHH arrays
      INTEGER(LONG)                   :: NN                   ! A term in a computed index into SSS, HHH arrays
      INTEGER(LONG)                   :: IBEGIN(11) = (/0, 1, 2, 4, 6, 9,12,16,20,25,30/)
      INTEGER(LONG), PARAMETER        :: SUBR_BEGEND = ORDER_BEGEND

      REAL(DOUBLE) ,INTENT(OUT)       :: SSS(MAX_ORDER_GAUSS) ! Gauss abscissa's
      REAL(DOUBLE) ,INTENT(OUT)       :: HHH(MAX_ORDER_GAUSS) ! Gauss weight coeffs

      INTRINSIC MOD

! **********************************************************************************************************************************
      IF (WRT_LOG >= SUBR_BEGEND) THEN
         CALL OURTIM
         WRITE(F04,9001) SUBR_NAME,TSEC
 9001    FORMAT(1X,A,' BEGN ',F10.3)
      ENDIF

! **********************************************************************************************************************************
! Initialize outputs

      DO I=1,MAX_ORDER_GAUSS
         SSS(I) = ZERO
         HHH(I) = ZERO
      ENDDO

! Check KORDER to make sure it no less than 1 nor greater than MAX_ORDER.  Error if not.

      IF ((KORDER >= 1) .AND. (KORDER <= MAX_ORDER_GAUSS)) THEN

! Abscissa and weight coefficients for Gaussian integ. of order KORDER

         IF (KORDER == 1) THEN
            SSS(1) = ZERO
            HHH(1) = TWO
         ELSE
            II = IBEGIN(KORDER)
            LL = IBEGIN(KORDER+1)
            JJ = LL - II
            NN = 2*JJ
            IF (MOD(KORDER,2) /= 0) THEN
               SSS(JJ) = SSV(LL-1)
               HHH(JJ) = HHV(LL-1)
               NN = NN - 1
               JJ = JJ - 1
            ENDIF
            DO KK=1,JJ
               LL = II + KK - 1
               MM = NN - KK + 1
               SSS(MM) =  SSV(LL)
               HHH(MM) =  HHV(LL)
               SSS(KK) = -SSV(LL)
               HHH(KK) =  HHV(LL)
             ENDDO
         ENDIF

      ELSE

         NUM_EMG_FATAL_ERRS = NUM_EMG_FATAL_ERRS + 1
         FATAL_ERR = FATAL_ERR + 1
         IF (WRT_ERR > 0) THEN
            WRITE(ERR,1931) SUBR_NAME, MAX_ORDER_GAUSS, KORDER
            WRITE(F06,1931) SUBR_NAME, MAX_ORDER_GAUSS, KORDER
         ELSE
            IF (NUM_EMG_FATAL_ERRS <= MEFE) THEN
               ERR_SUB_NAM(NUM_EMG_FATAL_ERRS) = SUBR_NAME
               EMG_IFE(NUM_EMG_FATAL_ERRS,1)   = 1931
               EMG_IFE(NUM_EMG_FATAL_ERRS,2)   = KORDER
            ENDIF
         ENDIF
         CALL OUTA_HERE ( 'Y' )                            ! Coding error, so quit

      ENDIF
! **********************************************************************************************************************************
      IF (WRT_LOG >= SUBR_BEGEND) THEN
         CALL OURTIM
         WRITE(F04,9002) SUBR_NAME,TSEC
 9002    FORMAT(1X,A,' END  ',F10.3)
      ENDIF

      RETURN

! **********************************************************************************************************************************
 1931 FORMAT(' *ERROR  1931: PROGRAMMING ERROR IN SUBROUTINE ',A                                                                   &
                    ,/,14X,' GAUSSIAN INTEGRATION ORDER CANNOT BE < 1 OR >',I3,' BUT VALUE IS ',I8)

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

      END SUBROUTINE ORDER_GAUSS