!     +
      SUBROUTINE INTERP_f(n_in,x_in,y_in,n_out,dx_out,y_out,a,b,c)
!
!     Interpolates a real*4 array y_in of dimension n_in
!     x_in is the array of the independent variable, also of dimension n_in.
!     dx_out is the (input) new digitizing interval.  n_out is the output
!     dimension,of the output array y_out.  n_out and y_out are calculated.
!     -
      REAL*4 x_in(*), y_in(*), y_out(*),a(*), b(*),c(*)
!
      xtotal = x_in(n_in) - x_in(1)
      dx_out = xtotal/(n_out-1)
      CALL SPSPLN(N_in,X_in,Y_in,A,B,C)
      DO J=1,N_out
         y_out(J) = SPEVAL(N_in,X_in(1)+DX_out*(J-1),X_in,Y_in,A,B,C)
      enddo
      RETURN
      END
!     +
!     FUNCTION SPEVAL(N,U,X,Y,B,C,D)
!
!     EVALUATES THE CUBIC SPLINE FUNCTION
!
!     SPEVAL = Y(I) + B(I)*(U-X(I)) + C(I)*(U-X(I)**2 + D(I)*(U-X(I))**3
!
!     WHERE X(I).LT.U.LT.X(I+1),  USING HORNER'S RULE
!
!     IF U.LT.X(1) THEN I=1 IS USED
!     IF U.GE.X(N) THEN I=N IS USED
!
!     INPUT
!     N=NUMBER OF DATA POINTS
!     U=ABSCISSA AT WHICH SPLINE IS TO BE EVALUATED
!     X,Y ARE ARRAYS OF DATA ABSCISSAS AND ORDINATES
!     B,C,D ARE ARRAYS OF SPLINE COEFFICIENTS COMPUTED BY SPLINE
!
!     IF U IS NOT IN THE SAME INTERVAL AS THE PREVIOUS CALL, THEN A
!     BINARY SEARCH IS PERFORMED TO DETERMINE PROPER INTERVAL
!     This is the single-precision version of the program
!     Reference:  Forsythe et al., 1977 Ch. 4
!     -
      FUNCTION SPEVAL(N,U,X,Y,B,C,D)
      DIMENSION X(N),Y(N),B(N),C(N),D(N)
      DATA I/1/
      IF(I.GE.N) I=1
      IF(U.LT.X(I)) GO TO 10
      IF(U.LT.X(I+1)) GO TO 30
 10   I=1
      J=N+1
 20   K=(I+J)/2
      IF(U.LT.X(K)) J=K
      IF(U.GE.X(K)) I=K
      IF(J.GT.I+1) GO TO 20
 30   DX=U-X(I)
      SPEVAL=Y(I)+DX*(B(I)+DX*(C(I)+DX*D(I)))
      RETURN
      END
!     +
!     SUBROUTINE SPSPLN (N,X,Y,B,C,D)
!
!     THE COEFFICIENTS B(I), C(I) AND D(I) , I=1,2..N ARE COMPUTED
!     FOR A CUBIC INTERPOLATING SPLINE
!
!     S(X) = X(I) + B(I)*(X-X(I)) + C(I)*(X-X(I))**2 + D(I)*(X-X(I)**3
!
!     FOR X(I) .LE. X .LE. X(I+1)
!
!     INPUT
!
!     N = THE NUMBER OF DATA POINTS  (N.GE.2)
!     X = ABSCISSAS OF DATA POINTS IN STRICTLY INCREASING ORDER
!     Y = ORDINATES OF DATA POINTS
!
!     OUTPUT
!
!     B, C, D ARE THE ARRAYS OF THE SPLINE COEFFICIENTS
!
!     THE FUNCTION SUBPROGRAM SPEVAL CAN BE USED TO EVALUATE THE SPLINE
!     This is the single precision version
!     Reference: Forsythe et al., 1977 Ch. 4
!     -
      SUBROUTINE SPSPLN (N,X,Y,B,C,D)
      DIMENSION X(N),Y(N),B(N),C(N),D(N)
      NM1=N-1
      IF(N.LT.2) RETURN
      IF(N.LT.3) GO TO 50
      D(1)=X(2)-X(1)
      C(2)=(Y(2)-Y(1))/D(1)
      DO 10 I=2,NM1
         D(I)=X(I+1)-X(I)
         B(I)=2.0*(D(I-1)+D(I))
         C(I+1)=(Y(I+1)-Y(I))/D(I)
         C(I)=C(I+1)-C(I)
 10   CONTINUE
      B(1)=-D(1)
      B(N)=-D(N-1)
      C(1)=0.0D0
      C(N)=0.0D0
      IF(N.EQ.3) GO TO 15
      C(1)=C(3)/(X(4)-X(2))-C(2)/(X(3)-X(1))
      C(N)=C(N-1)/(X(N)-X(N-2))-C(N-2)/(X(N-1)-X(N-3))
      C(1)=C(1)*D(1)**2/(X(4)-X(1))
      C(N)=-C(N)*D(N-1)**2/(X(N)-X(N-3))
 15   DO 20 I=2,N
         T=D(I-1)/B(I-1)
         B(I)=B(I)-T*D(I-1)
         C(I)=C(I)-T*C(I-1)
 20   CONTINUE
      C(N)=C(N)/B(N)
      DO 30 IB=1,NM1
         I=N-IB
         C(I)=(C(I)-D(I)*C(I+1))/B(I)
 30   CONTINUE
      B(N)=(Y(N)-Y(NM1))/D(NM1)+D(NM1)*(C(NM1)+2.0*C(N))
      DO 40 I=1,NM1
         B(I)=(Y(I+1)-Y(I))/D(I)-D(I)*(C(I+1)+2.0*C(I))
         D(I)=(C(I+1)-C(I))/D(I)
         C(I)=3.0*C(I)
 40   CONTINUE
      C(N)=3.0*C(N)
      D(N)=D(N-1)
      RETURN
!
 50   B(1)=(Y(2)-Y(1))/(X(2)-X(1))
      C(1)=0.0D0
      D(1)=0.0D0
      B(2)=B(1)
      C(2)=0.0D0
      D(2)=0.0D0
      RETURN
      END
!
      function lenc(string)
!     +
!     function lenc(string)
!
!     Returns length of character variable STRING excluding right-hand-
!     most blanks or nulls
!     -
      character*(*) string
      length = len(string)      ! total length
      if (length .eq. 0) then
         lenc = 0
         return
      end if
      if(ichar(string(length:length)).eq.0)string(length:length) = ' '
      do j=length,1,-1
         lenc = j
         if (string(j:j).ne.' ' .and. ichar(string(j:j)).ne.0) return
      end do
      lenc = 0
      return
      end


c
c     file tmud2sa.f
c
c  . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
c  .                                                             .
c  .                  copyright (c) 1999 by UCAR                 .
c  .                                                             .
c  .       UNIVERSITY CORPORATION for ATMOSPHERIC RESEARCH       .
c  .                                                             .
c  .                      all rights reserved                    .
c  .                                                             .
c  .                                                             .
c  .                      MUDPACK version 5.0                    .
c  .                                                             .
c  . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
c
c
c ... author and specialist
c
c          John C. Adams (National Center for Atmospheric Research)
c          email: johnad@ucar.edu, phone: 303-497-1213

c ... For MUDPACK 5.0 information, visit the website:
c     (http://www.scd.ucar.edu/css/software/mudpack)
c
c
c ... purpose
c
c     test program for the MUDPACK solver mud2
c
c ... required MUDPACK files
c
c     mud2sa.f, mudcom.f
c
c
c
c *********************************************************
c *********************************************************
c
c     sample program/test driver for mud2sa
c
c **********************************************************
c **********************************************************
c
c
c     a sample program/test driver for mud2sa is below. it can be
c     executed as an initial test.  output is listed for the test
c     case described.
c
c     test the nonseparable self-adjoint solver mud2sa by approximating
c     the solution to the following elliptic pde in divergence form on
c     the full surface of a sphere of radius one.
c
c          div(sigma(t,p)*grad(u(t,p))) - lambda(t,p)*u(t,p) = f(t,p)
c
c     t and p are colatitude and longitude in radians.  choose a grid
c     as close to 2.5 degrees radians (73 x 145) as the mudpack size
c     constraints allow. multiplying thru by sin(t) puts the pde in the
c     following self-adjoint form suitable for mud2sa:
c
c          d(sin(t)*sigma*du/dt)/dt + d(sigma/sin(t)*du/dp)/dp -
c
c          sin(t)*lambda*u(t,p) = sin(t)*f(t,p).
c
c
c     for testing use the coefficients and exact solution:
c
c          sigma(t,p) = 1.5 + (sin(t)*cos(p))**2
c
c          lambda(t,p) = - sigma(t,p)
c
c          u(t,p) =  [sin(t)*(sin(t)*cos(t)*sin(p)*cos(p))]**2
c
c     (the exact solution is the restriction of the solution u(x,y,z) =
c     (x*y*z)**2 in cartesian coordinates to the surface of the sphere
c     in spherical coordinates).  assume the solution u(t,p) is specified
c     at the poles and is periodic in longitude.
c
c ************************************************************
c     output (32 bit floating point arithmetic)
c ***********************************************************
c
c     mud2sa test
c
c     integer input parameters
c     intl =  0 nta =  1 ntb =  1 npc =  0 npd =  0
c     itp =  5 jpq =  5 iet =  5 jep =  6
c     nt =  81 np = 161 iguess =  0 maxcy =  1
c      method =  2 work space estimate =  260820

c
c     multigrid option parameters
c     kcycle =  2
c     iprer =  2
c     ipost =  1
c     intpol =  3
c
c     floating point input parameters
c     ta =  0.000 tb =  3.142 pc =  0.000 pd =  6.283
c     tolerance (error control) =   0.000E+00
c
c     discretization call to mud2sa  intl =  0
c     ierror =  0 minimum work space =  225200
c
c     approximation call to mud2sa
c     intl =  1 method =  2 iguess =  0 maxcy =  1
c     tolmax =  0.00
c     ierror =  0
c     maximum error  =  0.655E-04
c
c ************************************************************
c ************************************************************
c
      program tmud2sa
      implicit none
      integer iitp,jjpq,iiet,jjep,nnt,nnp,llwork
c
c     set grid size with parameter statements
c
      parameter(iitp = 5, jjpq = 5, iiet = 5, jjep = 6)
      parameter ( nnt = iitp*2**(iiet-1) + 1)
      parameter ( nnp = jjpq*2**(jjep-1) + 1)
c
c     set work space for longitude relaxation only (see mud2sa.d)
c
      parameter (llwork = 20*nnt*nnp)
c
c     dimension solution,right hand side, and work arrays
c
      real u(nnt,nnp),r(nnt,nnp),w(llwork)
c
c     dimension input argument vectors and set up continguous storage
c     for labelling entries
c
      integer iparm(17),mgopt(4)
      real fparm(6)
      integer intl,nta,ntb,npc,npd,itp,jpq,iet,jep,nt,np,
     +                iguess,maxcy,method,nwork,lwork,iter
      common / iprm / intl,nta,ntb,npc,npd,itp,jpq,iet,jep,nt,np,
     +                iguess,maxcy,method,nwork,lwork,iter
      real ta,tb,pc,pd,tolmax,sinat,cosat,sinap,cosap,dlt,dlp
      common / fprm / ta,tb,pc,pd,tolmax,sinat(81),cosat(81),
     +                sinap(161),cosap(161),dlt,dlp
      integer i,j,ierror
      real pi,sint,cost,sinp,cosp,sigma,dsigdt,dsigdp
      real ctt,cpp,ct,cp,ce,tmp,dt,dp,dtt,dpp,ue,ut,up,utt,upp
      real sigt,sigp,xlmb,errm,p,t
c
c     equivlance iparm,fparm with labelled commons iprm,fprm
c
      equivalence (intl,iparm)
      equivalence (ta,fparm)
c
c     declare coefficient and boundary condition input subroutines external
c
      external sigt,sigp,xlmb,bndc
c
c     set input integer parameters
c
c     initialization
c
      intl = 0
c
c     set boundary condition flags: poles specified, longitude periodic
c
      nta = 1
      ntb = 1
      npc = 0
      npd = 0
c
c     set grid sizes from parameter statements
c
      itp = iitp
      jpq = jjpq
      iet = iiet
      jep = jjep
      nt = nnt
      np = nnp
c
c     full multigrid cycling (no initial guess at finest grid)
c
      iguess = 0
c
c     set one multigrid cycle
c
      maxcy = 1
c
c     set line relaxation in the longitude direction
c
      method = 2
c
c     set work space estimate
c
      nwork = llwork
c
c     set multigrid parameters (w(2,1) cycling with fully weighted
c     residual restriction and cubic prolongation).  this can also
c     be set by inputting mgopt(1) = 0 to mud2sa.
c
      mgopt(1) = 2
      mgopt(2) = 2
      mgopt(3) = 1
      mgopt(4) = 3
c
c     set floating point input parameters
c
      pi = 4.0*atan(1.0)
c
c     interval end points (in radians)
c
      ta = 0.0
      tb = pi
      pc = 0.
      pd = pi+pi
c
c     no error control
c
      tolmax = 0.0
c
c     set mesh increments
c
      dlt = (tb-ta)/float(nt-1)
      dlp = (pd-pc)/float(np-1)
c
c     preset sin,cos vectors to save computation on grid points
c
      do i=1,nt
	t = ta+(i-1)*dlt
	sinat(i) = sin(t)
	cosat(i) = cos(t)
      end do
      do j=1,np
	p = pc+(j-1)*dlp
	sinap(j) = sin(p)
	cosap(j) = cos(p)
      end do
c
c     initialize right hand side and solution array except at poles
c
      do  i=2,nt-1
	sint = sinat(i)
	cost = cosat(i)
	do j=1,np
	  sinp = sinap(j)
	  cosp = cosap(j)
	  sigma = 1.5 + (sint*cosp)**2
	  dsigdt = 2.0*cosp*cosp*sint*cost
	  dsigdp = -2.0*sint*sint*cosp*sinp
c
c         compute expanded pde coefficients
c
	  ctt = sint*sigma
	  cpp = sigma/sint
	  ct = sint*dsigdt + cost*sigma
	  cp = dsigdp/sint
	  ce = -sint*sigma
c
c         set intermediate variables for exact solution
c
	  tmp = (sint*cosp*sint*sinp*cost)
	  dt = (2.*sint*cost*cost-sint**3)*(cosp*sinp)
	  dp = (cosp**2-sinp**2)*(sint**2*cost)
	  dtt = (2.*cost**3-4.*cost*sint**2-3.*sint**2*cost)*(cosp*sinp)
	  dpp = (-4.*cosp*sinp)*(sint**2*cost)
c
c         set continuous solution and partial derivatives
c
	  ue = tmp*tmp
	  ut = 2.*tmp*dt
	  up = 2.*tmp*dp
	  utt = 2.*(dt*dt+tmp*dtt)
	  upp = 2.*(dp*dp+tmp*dpp)
c
c         set right hand side of continuous pde on grid
c
	  r(i,j) = ctt*utt+cpp*upp+ct*ut+cp*up+ce*ue
c
c         initialize solution array to zero
c
	  u(i,j) = 0.0
	end do
      end do
c
c     set u, r(unused) at poles
c
      do j=1,np
	u(1,j) = 0.0
	r(1,j) = 0.0
	u(nt,j) = 0.0
	r(nt,j) = 0.0
      end do
c
c     print input parameters
c
      write(*,100)
  100 format(//' mud2sa test' )

      write (*,101) (iparm(i),i=1,15)
  101 format(/' integer input parameters ',
     +/'intl = ',i2,' nta = ',i2,' ntb = ',i2,' npc = ',i2,' npd = ',i2,
     +/' itp = ',i2,' jpq = ',i2,' iet = ',i2,' jep = ',i2
     +/' nt = ',i3,' np = ',i3,' iguess = ',i2,' maxcy = ',i2,
     +/' method = ',i2, ' work space estimate = ',i7)

      write (*,102) (mgopt(i),i=1,4)
  102 format(/' multigrid option parameters ',
     +/' kcycle = ',i2,
     +/' iprer = ',i2,
     +/' ipost = ',i2
     +/' intpol = ',i2)

      write(*,103) (fparm(i),i=1,5)
  103 format(/' floating point input parameters ',
     +/' ta = ',f6.3,' tb = ',f6.3,' pc = ',f6.3,' pd = ',f6.3,
     +/' tolerance (error control) =  ' ,e10.3)
c
c     discretization call to mud2sa
c
      write(*,104) intl
  104 format(/' discretization call to mud2sa ', ' intl = ',i2)
      call mud2sa(iparm,fparm,w,sigt,sigp,xlmb,bndc,r,u,mgopt,ierror)
      write (*,105) ierror,iparm(16)
  105 format(' ierror = ',i2, ' minimum work space = ',i7)
      if (ierror.gt.0) call exit(0)
c
c     aprroximation call to mud2sa
c
      intl = 1
      write(*,106) intl, method, iguess, maxcy, tolmax
  106 format(/' approximation call to mud2sa ',
     +/' intl = ',i2, ' method = ',i2 , ' iguess = ',i2, ' maxcy = ',i2
     +/' tolmax = ',f5.2)
      call mud2sa(iparm,fparm,w,sigt,sigp,xlmb,bndc,r,u,mgopt,ierror)
      write (*,107) ierror
  107 format(' ierror = ',i2 )
      if (ierror.gt.0) call exit(0)
      if (ierror .le. 0) then
c
c     compute and print exact maximum error
c
      errm = 0.0
      do j=1,np
	sinp = sinap(j)
	cosp = cosap(j)
	do i=1,nt
	  sint = sinat(i)
	  cost = cosat(i)
	  ue = (sint*cosp*sint*sinp*cost)**2
	  errm = amax1(errm,abs((u(i,j)-ue)))
	end do
      end do
      write(*,108) errm
  108 format(' maximum error  = ',e10.3 )
      end if
      end

      function sigt(t,p)
c
c     colatitude coefficient (this will be called off grid by mud2sa)
c
      implicit none
      real t,p,sigt,sint,cosp
      sint = sin(t)
      cosp = cos(p)
      sigt = sint*(1.5+(sint*cosp)**2)
      return
      end

      function sigp(t,p)
c
c     longitude coefficient (this will be called off grid by mud2sa)
c
      implicit none
      real t,p,sigp,sint,cosp
      sint = sin(t)
      cosp = cos(p)
c     avoid polar singularities and division by zero
      if (abs(sint) .gt. 1.e-7) then
      sigp = (1.5+(sint*cosp)**2)/sint
      else
      sigp = 1.0
      end if
      return
      end

      function xlmb(t,p)
c
c     zero order coefficient evaluated only on grid points
c
      implicit none
      real t,p,xlmb
      integer i,j
      integer intl,nta,ntb,npc,npd,itp,jpq,iet,jep,nt,np,
     +                iguess,maxcy,method,nwork,lwork,iter
      real ta,tb,pc,pd,tolmax,sinat,cosat,sinap,cosap,dlt,dlp
      common / iprm / intl,nta,ntb,npc,npd,itp,jpq,iet,jep,nt,np,
     +                iguess,maxcy,method,nwork,lwork,iter
      common / fprm / ta,tb,pc,pd,tolmax,sinat(81),cosat(81),
     +                sinap(161),cosap(161),dlt,dlp
      i = int((t-ta)/dlt+0.5)+1
      j = int((p-pc)/dlp+0.5)+1
      xlmb = sinat(i)*(1.5 + (sinat(i)*cosap(j))**2)
      return
      end

      subroutine bndc(kbdy,torp,alfa,gbdy)
c
c     this subroutine must be provided as a dummy argument even though
c     there are no mixed derivative b.c.
c
      implicit none
      integer kbdy
      real torp,alfa,gbdy
      return
      end


module easy_scalapack
    use, intrinsic:: iso_fortran_env, only: output_unit, input_unit, error_unit
    implicit none

    type process_grid
        integer              :: rank
        integer              :: size
        integer              :: myr, myc
        integer              :: npr, npc
        integer              :: r1st, c1st
        integer              :: ctxt
        contains
            procedure        :: print_process_grid, destroy, stop_all
    end type

    interface process_grid
        procedure            :: init_processes
    end interface

    type dense_matrix
        type(process_grid)   :: pc
        integer              :: desc(9)
        integer              :: mg, ng
        integer              :: mb, nb
        integer              :: ml, nl
        real, allocatable    :: la(:,:)
        contains
            procedure        :: locr, locc
            procedure        :: bc_coords => block_cyclic_coords
            procedure        :: set       => set_dense_matrix
            procedure        :: print_mapping, serial_matrix, print_matrix
    end type

    interface dense_matrix
        procedure            :: init_dense_matrix
    end interface

    type subarray
        integer              :: ia, ja, m, n
        integer, pointer     :: desc(:), mb, nb, lld
        real, pointer        :: la(:,:)
        integer, allocatable :: ipiv(:)
        integer              :: lwork, liwork
        real, allocatable    :: work(:)
        integer, allocatable :: iwork(:)
    end type

    interface subarray
        procedure init_subarray
    end interface

    interface nums_lcm
        procedure least_common_multiple
    end interface

    interface nums_gcd
        procedure greatest_common_divisor
    end interface

    contains

        ! ###########################################################
        ! ########################################################### auxiliary
        ! ###########################################################

        pure elemental &
        function least_common_multiple(x,y) result(c)
        implicit none
        integer, intent(in) :: x,y
        integer             :: c
        c = x*y / greatest_common_divisor(x,y)
        end function

        pure elemental &
        function greatest_common_divisor(x,y) result(c)
        implicit none
        integer, intent(in) :: x,y
        integer             :: a,b
        integer             :: t,c
        a = x
        b = y
        do while (b/=0)
            t = b
            b = mod(a,b)
            a = t
        end do
        c = abs(a)
        end function

        ! ###########################################################
        ! ########################################################### process grid
        ! ###########################################################

        function init_processes( p, q ) result(pc)
        implicit none
        integer, intent(in) :: p, q
        type(process_grid)  :: pc
        external            :: blacs_pinfo, sl_init, blacs_gridinfo
        call blacs_pinfo( pc%rank, pc%size )
        if( p*q/=pc%size ) call pc%stop_all( "p*q /= size!" )
        call sl_init( pc%ctxt, p, q )
        call blacs_gridinfo( pc%ctxt, pc%npr, pc%npc, pc%myr, pc%myc )
        pc%r1st = 0
        pc%c1st = 0
        end function

        ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

        subroutine destroy( pc )
        implicit none
        class(process_grid), intent(in) :: pc
        external                        :: blacs_gridexit
        call blacs_gridexit( pc%ctxt )
        end subroutine

        subroutine stop_all( pc, message )
        implicit none
        class(process_grid), intent(in)        :: pc
        character(len=*), intent(in), optional :: message
        external                               :: blacs_exit
        if( present(message) .and. pc%rank==0 ) print *, message
        call blacs_exit(0)
        stop
        end subroutine

        ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

        subroutine print_process_grid(p)
        implicit none
        class(process_grid), intent(in) :: p
        write( output_unit, '("process",i3,2x,"out of",i3,2x)', advance='no' )  p%rank, p%size
        write( output_unit, '("indexed",2i3,2x)', advance='no' )  p%myr, p%myc
        write( output_unit, '("in process grid of the size",2i3)') p%npr, p%npc
        end subroutine

        ! ###########################################################
        ! ########################################################### dense matrix
        ! ###########################################################

        function init_dense_matrix( mg, ng, mb, nb, pc ) result(dm)
        implicit none
        integer, intent(in)             :: mg, ng
        integer, intent(in)             :: mb, nb
        class(process_grid), intent(in) :: pc
        type(dense_matrix)              :: dm
        integer                         :: info, numroc
        external                        :: numroc, descinit
        dm%mg = mg; dm%mb = mb
        dm%ng = ng; dm%nb = nb
        dm%ml = max( 1,  numroc( dm%mg, dm%mb, pc%myr, pc%r1st, pc%npr ) )
        dm%nl = max( 1,  numroc( dm%ng, dm%nb, pc%myc, pc%c1st, pc%npc ) )
        call descinit( dm%desc , dm%mg, dm%ng, dm%mb, dm%nb, pc%r1st, pc%c1st, pc%ctxt, dm%ml, info )
        dm%pc = pc
        if( info/=0 ) call pc%stop_all( "descinit info /=0" )
        allocate(dm%la(dm%ml,dm%nl))
        end function

        ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ LOCr(), LOCc()

        integer &
        function locr( dm, s )
        implicit none
        class(dense_matrix), intent(in) :: dm
        integer, intent(in), optional   :: s
        integer, external               :: numroc
        if( present(s) ) then
            locr = max( 1, numroc( s,     dm%mb, dm%pc%myr, dm%pc%r1st, dm%pc%npr ) )
        else
            locr = max( 1, numroc( dm%mg, dm%mb, dm%pc%myr, dm%pc%r1st, dm%pc%npr ) )
        end if
        end function

        integer &
        function locc( dm, s )
        implicit none
        class(dense_matrix), intent(in) :: dm
        integer, intent(in), optional   :: s
        integer, external               :: numroc
        if( present(s) ) then
            locc = max( 1,  numroc( s,     dm%nb, dm%pc%myc, dm%pc%c1st, dm%pc%npc ) )
        else
            locc = max( 1,  numroc( dm%ng, dm%nb, dm%pc%myc, dm%pc%c1st, dm%pc%npc ) )
        end if
        end function

        ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ i,j -> ip,jp and il,jl

        subroutine block_cyclic_1d( i, nb, p1st, np, ip, il )
        implicit none
        integer, intent(in)  :: i, nb, p1st, np
        integer, intent(out) :: ip, il
        ip = mod( p1st + (i-1)/nb , np )
        il = ((i-1)/(np*nb))*nb + mod( i-1, nb ) + 1
        end subroutine

        subroutine block_cyclic_coords( dm, i, j, ip, jp, il, jl )
        implicit none
        class(dense_matrix), intent(in) :: dm
        integer,            intent(in)  :: i, j
        integer,            intent(out) :: ip, jp, il, jl
        call block_cyclic_1d( i, dm%mb, dm%pc%r1st, dm%pc%npr, ip, il)
        call block_cyclic_1d( j, dm%nb, dm%pc%c1st, dm%pc%npc, jp, jl)
        end subroutine

        subroutine print_mapping(dm)
        implicit none
        class(dense_matrix), intent(in) :: dm
        integer                         :: i, j, ip, jp, il, jl, u
        if( dm%pc%rank==0 ) then
            open( newunit=u, file='dense_matrix_mapping.txt' )
            write(u,*) '#global', dm%mg, dm%ng
            write(u,*) '#block', dm%mb, dm%nb
            write(u,*) '#process', dm%pc%npr, dm%pc%npc
            do i = 1, dm%mg
                do j = 1, dm%ng
                    call dm%bc_coords(i,j,ip,jp,il,jl)
                    write(u,*) i,j,ip,jp,il,jl
                end do
            end do
            close(u)
        end if
        end subroutine

        ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

        subroutine serial_matrix(dm)
        implicit none
        class(dense_matrix), intent(inout) :: dm
        integer                            :: i, j
        do i = 1, dm%mg
            do j = 1, dm%ng
                call dm%set(i,j, real(j-1)*dm%mg + real(i) )
            end do
        end do
        end subroutine

        subroutine print_matrix(dm,u)
        implicit none
        class(dense_matrix), intent(inout) :: dm
        integer,                intent(in) :: u
        real                               :: work( dm%mb )
        call pslaprnt( dm%mg, dm%ng, dm%la(1,1), 1, 1, dm%desc, 0, 0, "", u, work )
        ! note: pdlaprnt for double, etc.
        end subroutine

        ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

        subroutine set_dense_matrix( dm, i, j, val )
        implicit none
        class(dense_matrix), intent(inout) :: dm
        integer,                intent(in) :: i, j
        real,                   intent(in) :: val
        integer                            :: ip, jp, il, jl
        call dm%bc_coords( i, j, ip, jp, il, jl )
        if( dm%pc%myr==ip .and. dm%pc%myc==jp ) then
            dm%la( il, jl ) = val
        end if
        end subroutine

        ! ###########################################################
        ! ########################################################### subarray
        ! ###########################################################

        function init_subarray( dm, ia, ja, m, n ) result(sa)
        implicit none
        class(dense_matrix), intent(in), target :: dm
        integer,   intent(in), optional         :: ia, ja, m, n
        type(subarray)                          :: sa
        integer                                 :: lcm
        if( present(ia) ) then
            sa%ia = ia
        else
            sa%ia = 1
        end if
        if( present(ja) ) then
            sa%ja = ja
        else
            sa%ja = 1
        end if
        if( present(m) ) then
            sa%m = m
        else
            sa%m = dm%mg - sa%ia + 1
        end if
        if( present(n) ) then
            sa%n = n
        else
            sa%n = dm%ng - sa%ja + 1
        end if
        sa%desc => dm%desc
        sa%la   => dm%la
        sa%mb   => dm%mb
        sa%nb   => dm%nb
        sa%lld  => dm%ml
        !
        allocate( sa%ipiv(( dm%locr(sa%m)+sa%mb )) )
        ! work, lwork
        sa%lwork = dm%locr(( sa%n + mod(sa%ia-1,sa%mb) ))*sa%nb
        allocate( sa%work(sa%lwork) )
        ! iwork, liwork
        sa%liwork = dm%locc(( sa%n + mod(sa%ja-1,sa%nb) )) + sa%nb
        if( dm%pc%npr/=dm%pc%npc ) then
            lcm = nums_lcm( dm%pc%npr,dm%pc%npc )
            sa%liwork = sa%liwork - sa%nb + &
                        max( ceiling( ceiling(real(dm%locr(sa%m))/sa%mb) / (real(lcm)/dm%pc%npr) ), sa%nb )
        end if
        allocate( sa%iwork(sa%liwork) )
        end function

end module easy_scalapack