!^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^!^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
!^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^!^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
!! 3D oil reservoir Simulator project
!! by Mehrdad Gharib Shirangi From Spring 2010 until Fall 2010
!! mehrdad.ghsh@gmail.com
!! Copy Right by Mehrdad Gharib Shirangi
!^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^!^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
!^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^!^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^

Module Well

Use globalvar
Use Trans

!************************************************************************************************************************************
!                                                    Explanations
! This Madul contains some Subroutines, the common point of these subroutines is that they are all about Wells, or Well rates

!Subroutine 'wellIndex_cons' calculates the matrix of constant part of Well Index matrix,

!   subroutine wellIndex , multiplies the constant term of Well Index matrix by (kro)/(muo)(Bo) and (krw)/(muw)(Bw) ,
! Needless to say, the Well Index is a matrix with Nwell columns and Nz rows, so for each layer that is not ptoducing 'oil' or 'water ' ,
! the entry of W_Index_O or W_Index_ w will be zero respectively. It is possible that a layer just produces oil or just Water, then kro or
! krw would be zero

! subroutine calc_rate, computes the oil rate and water rate of each well, and puts the value into a vector, the vectors Oilrate and Waterrate are
! Global vectors and are used in other subroutines like 'con_check' and Output

! In subroutine Calc_DeltaPwf, the value of DeltaPwf is calculated for each layer in the well and these values are in a matrix with Nwell columns and Nz rows
! The algorithm used in this sub is from Dr. Li's course Notes . There are 4 cases considered here : Production well, with q oil sp or BHP sp , and
! Injector Well with q water sp, or BHP sp.
! in case of constant rate production or injection, the value of BHP is determined using a loop. This loop is very exact and after BHP is determined, there
! is no need to improve it, as Fwell (would become)= 1d-12
! In case of BHP sp, the iterations aim to precisely calculate del_pwf and the convergence criteria is that oil rate or water rate is not changing with
! recalculating del_pwf

!************************************************************************************************************************************
! contains transmissibility functions
use globalvar
implicit none

Contains

    subroutine wellIndex_cons ! calculates the matrix of constant part of Well Index
    implicit none
    integer:: i_well, i_k,  alfa_well , counter	, m , n

        Do i_well = 1 , Nwell
            Do i_k = Well_k(i_well , 1) , Well_k(i_well ,2)
                alfa_well = Well_loc(i_well,1) + ( Well_loc(i_well,2) - 1 ) * Nx + (i_k - 1 ) * Nx * Ny
                R_equ(i_well , i_k ) = 0.28 * sqrt( ky(alfa_well) * Deltax( Well_loc(i_well,1))**2 + kx(alfa_well) * Deltay( Well_loc(i_well,2))**2 ) / ( sqrt(kx(alfa_well)) + sqrt(ky(alfa_well)) )
                KH(i_well , i_k) =  ( kx(alfa_well) * ky(alfa_well) ) ** (0.5)
                ! the above terms are not a function of pressure or Saturation, but the below one is, so I can calculate the above terms for once and then just
                ! calculate the pressure and saturation dependent term during program Run
                Well_index_cons(i_well , i_k ) = 2 *  3.14159265 * betac * KH(i_well , i_k) * Deltaz(alfa_well) / log( R_equ(i_well,i_k) / r_w(i_well) )
            EndDo
        EndDo
            n = n_Kr
            m = 1
            do while (abs(n-m)>1)
                if (SW_AtSor < Sw_mat(floor( m + (n-m+1)/2.0) ) )  then
                    n = floor(m + ( n - m + 1) / 2.0);
                else
                    m = floor(m + ( n - m + 1) / 2.0);
                end if
            end do

		kr_inj = krw(m)+ (SW_AtSor -Sw_mat(m))/(Sw_mat(n)-Sw_mat(m))*(krw(n)-krw(m))
    Endsubroutine wellIndex_cons

    !********************************************************************************************************
    subroutine wellIndex ! this sub would be called at each time step from solver subroutine
    integer:: i_well, i_k,  alfa_well , counter
        !counter = 0

        W_index_o = 0.0
        W_index_w = 0.0
        Do i_well = 1 , Nwell
			if ( W_type(i_well) == 'inje') then
				Do i_k = Well_k(i_well , 1) , Well_k(i_well ,2)
					alfa_well = Well_loc(i_well,1) + ( Well_loc(i_well,2) - 1 ) * Nx +  ( i_k - 1) * Nx * Ny
					W_index_o(i_well,i_k) = 0.0
					if ( k_r(alfa_well , 'w' ) .GT. kr_inj )  then
		                W_index_w(i_well,i_k) = Well_index_cons(i_well,i_k) * k_r(alfa_well , 'w' ) / (mu_f( pressure(alfa_well),'w' ) * B_f( W_press(alfa_well) , 'w' ) )
					Else
						W_index_w(i_well,i_k) = Well_index_cons(i_well,i_k) * kr_inj / (mu_f( pressure(alfa_well),'w' ) * B_f( W_press(alfa_well) , 'w' ) )
					EndIf
				EndDo
			Else
				Do i_k = Well_k(i_well , 1) , Well_k(i_well ,2)
					alfa_well = Well_loc(i_well,1) + ( Well_loc(i_well,2) - 1 ) * Nx +  ( i_k - 1) * Nx * Ny
					W_index_o(i_well,i_k) = Well_index_cons(i_well,i_k) * k_r(alfa_well , 'o' ) / (mu_f( pressure(alfa_well),'o' ) * B_f( pressure(alfa_well) , 'o' ) )
					W_index_w(i_well,i_k) = Well_index_cons(i_well,i_k) * k_r(alfa_well , 'w' ) / (mu_f( pressure(alfa_well),'w' ) * B_f( W_press(alfa_well) , 'w' ) )
				EndDo
			EndIF
        EndDO

    Endsubroutine wellIndex

    !********************************************************************************************************
    subroutine calc_rate

    Implicit none

    integer :: i_well , alfa_w  , alfa_wprim , alfa_wpp , i_k ,i , W_index
    integer :: counter
    real*8 :: qo, qw

    ! writing oil rates to a matrix
    oilrate = 0.0
    waterrate = 0.0
    TOILP = 0
    WOR = 0

    If (Nz .NE. 1) then
        call Calc_DeltaPwf
	EndIf
        counter = 0
        WOR = 0
        Do i_well = 1, Nwell
            if ( ( W_type(i_well) == 'prod') .AND. ( Schedule(i_well , 2 , sche_N) .NE. 0)  )then
				qo = 0
				qw = 0
				W_index = Ntotal + i_well  ! Pwf position in pressure vector
				Do i_k = Well_k(i_well , 1) , Well_k(i_well ,2)
					 alfa_w = Well_loc(i_well,1) + ( Well_loc(i_well,2) - 1) * Nx +  ( i_k - 1) * Nx * Ny
					 qo = qo + w_index_o(i_well, i_k ) * (pressure(alfa_w) - pressure(W_index ) - Del_Pwf(i_well, i_k))
					 qoL(i_well, i_k) = w_index_o(i_well, i_k ) * (pressure(alfa_w) - pressure(W_index ) - Del_Pwf(i_well, i_k))
				EndDO

				Do i_k = Well_k(i_well , 1) , Well_k(i_well ,2)
					alfa_w = Well_loc(i_well,1) + ( Well_loc(i_well,2) - 1) * Nx +  ( i_k - 1) * Nx * Ny
					qw = qw + w_index_w(i_well, i_k ) * (pressure(alfa_w) - pressure(W_index ) - Del_Pwf(i_well, i_k))
					qwL(i_well, i_k) = w_index_w(i_well, i_k ) * (pressure(alfa_w) - pressure(W_index ) - Del_Pwf(i_well, i_k))
			    EndDo

				oilrate(i_well) = qo
				waterRate(i_well) = qw
				if ( abs(qo) .GE. 1 ) then
					WOR(i_well) = qw / qo
				EndIf
				TOILP = TOILP + oilrate(i_well) * d_time !! Total OIL Production in that Time_step
!				if ( Schedule(i_well , 3 ,sche_N) == 0.0 ) then
!				   oilrate (i_well) = 0
!				   waterRate(i_well) = 0
!				EndIf
			ElseIf ( Schedule(i_well , 2 , sche_N) .NE. 0) Then
				oilrate (i_well) = 0
				qw = 0
				W_index = Ntotal + i_well  ! Pwf position in pressure vector
				Do i_k = Well_k(i_well , 1) , Well_k(i_well ,2)
					 alfa_w = Well_loc(i_well,1) + ( Well_loc(i_well,2) - 1) * Nx +  ( i_k - 1) * Nx * Ny
					 qw = qw + w_index_w(i_well, i_k ) * (pressure(alfa_w) - pressure(W_index ) - Del_Pwf(i_well, i_k))
				EndDO
				waterRate(i_well) = qw
			EndIf
        EndDo

    Endsubroutine calc_rate

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

    subroutine Calc_DeltaPwf ! calculates the matrix of Del_Pwf
    implicit none

    integer :: i_well, i_k,  alfa_well , alfa_w , W_index , B_index , N_index , ii , counter
    integer :: con ! convergence , when == 0 , not converged
    Real, Allocatable, Dimension(:) :: O_Volume, W_Volume , mix_den ! O_Volume is the vector of Volume of oil in each completion ( for dt = 1 day , and dp = 1 psi )
    Real, Allocatable, Dimension(:) :: qoN , qoP , qwN , qwP ! q oil New, q water New ... for convergence check in case of BHPsp
    real*8 :: denom , eps_pwf , Fwell ,max_dif , c1 , c2

    Del_Pwf = 0
    Allocate ( O_Volume(Nz) )
    Allocate ( W_Volume(Nz ) ) ! Well_k(i_well ,2) - Well_k(i_well ,1)
    Allocate ( mix_den(Nz ) )

    Allocate ( qoN(Nz) )
    Allocate ( qwN(Nz) )
    Allocate ( qoP(Nz) )
    Allocate ( qwP(Nz) )

        Do i_well = 1 , Nwell
            W_index = Ntotal + i_well  ! Pwf position in pressure vector
            alfa_w = 2 * Ntotal + i_well
            if ( W_type(i_well) == 'prod') then
               if ( Schedule(i_well , 2 , sche_N) .EQ. 1 ) then ! oil rate is given
                       counter  = 0
                       con = 0 ! convergence criteria
                       Do while (con == 0)
                           if ( counter .NE. 0 ) then
                              ! checking convergence
                              max_dif = 0
                              Do i_k = Well_k(i_well , 1) , Well_k(i_well ,2)
                                 ! finding the maximum difference
                                 B_index = Well_loc(i_well,1) + ( Well_loc(i_well,2) - 1) * Nx + ( i_k - 1 )* Nx * Ny
                                 max_dif = max ( max_dif , abs( pressure(B_index) - pressure(W_index ) - Del_Pwf(i_well, i_k) ) )
                              EndDo
                              if  ( (max_dif < 1.0D-7 ) .OR.  ( abs(eps_pwf / max_dif) < 0.01 ) )  then
                                 con = 1
                                 exit
                              EndIf
                           EndIf
                           counter = counter + 1
                           O_Volume = 0
                           W_Volume = 0
                           mix_den = 0
                           i_K =  Well_k(i_well ,2)
                           ! stage 1 : obtaining Oil Volume and Water Volume ,
                           Do while (i_k .GE. Well_k(i_well , 1) )
                              B_index = Well_loc(i_well,1) + ( Well_loc(i_well,2) - 1) * Nx + ( i_k - 1 ) * Nx * Ny
                              O_Volume(i_k) = w_index_o(i_well, i_k ) * 1.0 * ( pressure(B_index) - pressure(W_index) - Del_Pwf(i_well, i_k) )
                              W_Volume(i_k) = w_index_w(i_well, i_k ) * 1.0 * ( pressure(B_index) - pressure(W_index) - Del_Pwf(i_well, i_k) )
                              if (i_k .NE. Well_k(i_well ,2) ) then
                                 O_Volume(i_k) = O_Volume(i_k) + O_Volume(i_k + 1)
                                 W_Volume(i_k) = W_Volume(i_k) + W_Volume(i_k + 1)
                              EndIf
                              mix_den(i_k) = ( W_Volume(i_k) * den_w + O_Volume(i_k) * den_o ) / ( W_Volume(i_k) * den_w / density( pressure(W_index) + Del_Pwf(i_well, i_k),'w') + O_Volume(i_k) * den_o / density( pressure(W_index) + Del_Pwf(i_well, i_k),'o' ) )
                              ! BHP or Pwf for oil and water are the same , so pressure( W_index) works for both
                              i_K = i_K - 1
                           EndDo
                           ! stage 2 : obtaining Del_pwf
                           Do i_k = Well_k(i_well , 1) + 1 , Well_k(i_well ,2)
                              B_index = Well_loc(i_well,1) + ( Well_loc(i_well,2) - 1) * Nx + ( i_k - 1 ) * Nx * Ny
                              N_index = Well_loc(i_well,1) + ( Well_loc(i_well,2) - 1) * Nx + ( i_k - 1 - 1) * Nx * Ny
                              Del_Pwf(i_well , i_k ) = mix_den(i_k - 1) / 144.0 *( Deltaz(B_index) +  Deltaz(N_index) ) / 2.0
                              !if (i_k .NE. Well_k(i_well , 1) + 1 ) then ! if this is not the first layer which has del_pwf
                              Del_Pwf(i_well , i_k ) = Del_Pwf(i_well , i_k ) + Del_Pwf(i_well , i_k - 1)
                           EndDO
                           ! stage 3 : modifying pwf
                           Fwell = - Schedule(i_well , 3 , sche_N)
                           denom = 0
                           Do i_k = Well_k(i_well , 1) , Well_k(i_well ,2)
                              B_index = Well_loc(i_well,1) + ( Well_loc(i_well,2) - 1) * Nx + ( i_k - 1 )* Nx * Ny
                              Fwell = Fwell + w_index_o(i_well, i_k ) * ( pressure(B_index) - pressure(W_index ) - Del_Pwf(i_well, i_k))
                              denom = denom + w_index_o(i_well, i_k )
                           EndDO
!                           if ( Schedule(i_well , 3 , sche_N) .EQ. 0.0 ) then ! total liquid rate == 0
!						       Do i_k = Well_k(i_well , 1) , Well_k(i_well ,2)
!                                  B_index = Well_loc(i_well,1) + ( Well_loc(i_well,2) - 1) * Nx + ( i_k - 1 )* Nx * Ny
!								  Fwell = Fwell + w_index_w(i_well, i_k ) * ( W_press(B_index) - pressure(W_index ) - Del_Pwf(i_well, i_k))
!                                  denom = denom + w_index_w(i_well, i_k )
!                               EndDo
!                           EndIf
                           eps_pwf =  Fwell / denom
                           pressure(W_index ) = pressure(W_index ) + eps_pwf
                           YY(alfa_w) = YY(alfa_w) + eps_pwf
                       EndDO
               Elseif ( Schedule(i_well , 2 , sche_N) .EQ. 3 ) then ! Total Liquid Rate Specified
                       counter  = 0
                       con = 0 ! convergence criteria
                       Do while (con == 0)
                           if ( counter .NE. 0 ) then
                              ! checking convergence
                              max_dif = 0
                              Do i_k = Well_k(i_well , 1) , Well_k(i_well ,2)
                                 ! finding the maximum difference
                                 B_index = Well_loc(i_well,1) + ( Well_loc(i_well,2) - 1) * Nx + ( i_k - 1 )* Nx * Ny
                                 max_dif = max ( max_dif , abs( pressure(B_index) - pressure(W_index ) - Del_Pwf(i_well, i_k) ) )
                              EndDo
                              if  ( (max_dif < 1.0D-7 ) .OR. abs(eps_pwf / max_dif) < 0.01)  then
                                 con = 1
                                 exit
                              EndIf
                           EndIf
                           counter = counter + 1
                           O_Volume = 0
                           W_Volume = 0
                           mix_den = 0
                           i_K =  Well_k(i_well ,2)
                           ! stage 1 : obtaining Oil Volume and Water Volume ,
                           Do while (i_k .GE. Well_k(i_well , 1) )
                              B_index = Well_loc(i_well,1) + ( Well_loc(i_well,2) - 1) * Nx + ( i_k - 1 ) * Nx * Ny
                              O_Volume(i_k) = w_index_o(i_well, i_k ) * 1.0 * ( pressure(B_index) - pressure(W_index) - Del_Pwf(i_well, i_k) )
                              W_Volume(i_k) = w_index_w(i_well, i_k ) * 1.0 * ( pressure(B_index) - pressure(W_index) - Del_Pwf(i_well, i_k) )
                              if (i_k .NE. Well_k(i_well ,2) ) then
                                 O_Volume(i_k) = O_Volume(i_k) + O_Volume(i_k + 1)
                                 W_Volume(i_k) = W_Volume(i_k) + W_Volume(i_k + 1)
                              EndIf
                              mix_den(i_k) = ( W_Volume(i_k) * den_w + O_Volume(i_k) * den_o ) / ( W_Volume(i_k) * den_w / density( pressure(W_index) + Del_Pwf(i_well, i_k),'w') + O_Volume(i_k) * den_o / density( pressure(W_index) + Del_Pwf(i_well, i_k),'o' ) )
                              ! BHP or Pwf for oil and water are the same , so pressure( W_index) works for both
                              i_K = i_K - 1
                           EndDo
                           ! stage 2 : obtaining Del_pwf
                           Do i_k = Well_k(i_well , 1) + 1 , Well_k(i_well ,2)
                              B_index = Well_loc(i_well,1) + ( Well_loc(i_well,2) - 1) * Nx + ( i_k - 1 ) * Nx * Ny
                              N_index = Well_loc(i_well,1) + ( Well_loc(i_well,2) - 1) * Nx + ( i_k - 1 - 1) * Nx * Ny
                              Del_Pwf(i_well , i_k ) = mix_den(i_k - 1) / 144.0 *( Deltaz(B_index) +  Deltaz(N_index) ) / 2.0
                              !if (i_k .NE. Well_k(i_well , 1) + 1 ) then ! if this is not the first layer which has del_pwf
                              Del_Pwf(i_well , i_k ) = Del_Pwf(i_well , i_k ) + Del_Pwf(i_well , i_k - 1)
                           EndDO
                           ! stage 3 : modifying pwf
                           Fwell = - Schedule(i_well , 3 , sche_N)
                           denom = 0
                           Do i_k = Well_k(i_well , 1) , Well_k(i_well ,2)
                              B_index = Well_loc(i_well,1) + ( Well_loc(i_well,2) - 1) * Nx + ( i_k - 1 )* Nx * Ny
                              Fwell = Fwell + w_index_o(i_well, i_k ) * ( pressure(B_index) - pressure(W_index ) - Del_Pwf(i_well, i_k)) &
											+ w_index_w(i_well, i_k ) * ( pressure(B_index) - pressure(W_index ) - Del_Pwf(i_well, i_k))
                              denom = denom + w_index_o(i_well, i_k )  + w_index_w(i_well, i_k )
                           EndDO
                           eps_pwf =  Fwell / denom
                           pressure(W_index ) = pressure(W_index ) + eps_pwf
                           YY(alfa_w) = YY(alfa_w) + eps_pwf
                       EndDO

               ElseIf ( Schedule(i_well , 2 , sche_N) .EQ. 2 ) then ! BHP specified case
                       qoN = 0
                       qoP = 0
                       qwN = 0
                       qwP = 0
                       counter  = 0
                       con = 0 ! convergence criteria
                       Do while (con == 0)
                           counter = counter + 1
                           O_Volume = 0
                           W_Volume = 0
                           mix_den = 0
                           i_K =  Well_k(i_well ,2)
                           ! stage 1 : obtaining Oil Volume and Water Volume ,
                           Do while (i_k .GE. Well_k(i_well , 1) )
                              B_index = Well_loc(i_well,1) + ( Well_loc(i_well,2) - 1) * Nx + ( i_k - 1 ) * Nx * Ny
                              O_Volume(i_k) = w_index_o(i_well, i_k ) * 1.0 * ( pressure(B_index) - pressure(W_index) - Del_Pwf(i_well, i_k) )
                              W_Volume(i_k) = w_index_w(i_well, i_k ) * 1.0 * ( pressure(B_index) - pressure(W_index) - Del_Pwf(i_well, i_k) )
                              if (i_k .NE. Well_k(i_well ,2) ) then
                                 O_Volume(i_k) = O_Volume(i_k) + O_Volume(i_k + 1)
                                 W_Volume(i_k) = W_Volume(i_k) + W_Volume(i_k + 1)
                              EndIf
                              mix_den(i_k) = ( W_Volume(i_k) * den_w + O_Volume(i_k) * den_o ) / ( W_Volume(i_k) * den_w / density( pressure(W_index) + Del_Pwf(i_well, i_k),'w') + O_Volume(i_k) * den_o / density( pressure(W_index) + Del_Pwf(i_well, i_k),'o' ) )
                              ! BHP or Pwf for oil and water are the same , so pressure( W_index) works for both
                              i_K = i_K - 1
                           EndDo
                           ! stage 2 : obtaining Del_pwf
                           Do i_k = Well_k(i_well , 1) + 1 , Well_k(i_well ,2)
                              B_index = Well_loc(i_well,1) + ( Well_loc(i_well,2) - 1) * Nx + ( i_k - 1 ) * Nx * Ny
                              N_index = Well_loc(i_well,1) + ( Well_loc(i_well,2) - 1) * Nx + ( i_k - 1 - 1) * Nx * Ny
                              Del_Pwf(i_well , i_k ) = mix_den(i_k - 1) / 144.0 *( Deltaz(B_index) +  Deltaz(N_index) ) / 2.0
                              !if (i_k .NE. Well_k(i_well , 1) + 1 ) then ! if this is not the first layer which has del_pwf
                              Del_Pwf(i_well , i_k ) = Del_Pwf(i_well , i_k ) + Del_Pwf(i_well , i_k - 1)
                           EndDO
                           ! stage 3 : convergence
                            Do i_k = Well_k(i_well , 1) , Well_k(i_well ,2)
                               B_index = Well_loc(i_well,1) + ( Well_loc(i_well,2) - 1) * Nx + ( i_k - 1 )* Nx * Ny
                               qoN(i_k) = w_index_o(i_well, i_k ) * ( pressure(B_index) - pressure(W_index ) - Del_Pwf(i_well, i_k) )
                               qwN(i_k) = w_index_w(i_well, i_k ) * ( pressure(B_index) - pressure(W_index ) - Del_Pwf(i_well, i_k) )
                            EndDo
                           if ( counter .NE. 1 ) then
                              ! checking convergence
                              max_dif = 0
                              Do i_k = Well_k(i_well , 1) , Well_k(i_well ,2)
                                 if  ( abs(qwN(i_k)) > 1   ) then
                                    max_dif = max ( max_dif , abs(qwN(i_k) - qwP(i_k) ) /qwN(i_k) )
                                 EndIf
                                 if  ( abs(qoN(i_k)) > 1   ) then
									max_dif = max ( max_dif , abs(qoN(i_k) - qoP(i_k) ) /qoN(i_k) )
                                 EndIf
							  EndDo
                              if  (max_dif < 0.000001)  then
                                 con = 1
                                   !exit
                              EndIf
                           EndIf
                          qoP = qoN
                          qwP = qwN

                       EndDO
                   EndIf
            Else ! Injection Well
               if ( Schedule(i_well , 2 , sche_N) .EQ. 1 ) then ! injection rate is given
                       counter  = 0
                       con = 0 ! convergence criteria
                       Do while (con == 0)
                           if ( counter .NE. 0 ) then
                              ! checking convergence
                              max_dif = 0
                              Do i_k = Well_k(i_well , 1) , Well_k(i_well ,2)
                                 ! finding the maximum difference
                                 B_index = Well_loc(i_well,1) + ( Well_loc(i_well,2) - 1) * Nx + ( i_k - 1 )* Nx * Ny
                                 max_dif = max ( max_dif , abs( pressure(B_index) - pressure(W_index ) - Del_Pwf(i_well, i_k) ) )
                              EndDo
                              if  (abs(eps_pwf / max_dif) < 0.01)  then
                                 con = 1
                                 exit
                              EndIf
                           EndIf
                           counter = counter + 1

                           ! obtaining Del_pwf
                           Do i_k = Well_k(i_well , 1) + 1 , Well_k(i_well ,2)
                              c1 = 0
                              c2 = 2
                              Do while ( abs(c1-c2) > 0.1)
                                  c1 = Del_Pwf(i_well , i_k )
                                  B_index = Well_loc(i_well,1) + ( Well_loc(i_well,2) - 1) * Nx + ( i_k - 1 ) * Nx * Ny
                                  N_index = Well_loc(i_well,1) + ( Well_loc(i_well,2) - 1) * Nx + ( i_k - 1 - 1) * Nx * Ny
                                  Del_Pwf(i_well , i_k ) = density( pressure(W_index) + Del_Pwf(i_well, i_k),'w') / 144.0 *( Deltaz(B_index) +  Deltaz(N_index) ) / 2.0
                                  !if (i_k .NE. Well_k(i_well , 1) + 1 ) then ! if this is not the first layer which has del_pwf
                                  Del_Pwf(i_well , i_k ) = Del_Pwf(i_well , i_k ) + Del_Pwf(i_well , i_k - 1)
                                  c2 = Del_Pwf(i_well , i_k )
                              EndDo
                           EndDO
                           ! stage 3 : modifying pwf
                           Fwell = Schedule(i_well , 3 , sche_N)
                           denom = 0
                           Do i_k = Well_k(i_well , 1) , Well_k(i_well ,2)
                              B_index = Well_loc(i_well,1) + ( Well_loc(i_well,2) - 1) * Nx + ( i_k - 1 )* Nx * Ny
                              Fwell = Fwell + w_index_w(i_well, i_k ) * ( pressure(B_index) - pressure(W_index ) - Del_Pwf(i_well, i_k))
                              denom = denom + w_index_w(i_well, i_k )
                           EndDO

                           eps_pwf =  Fwell / denom
                           pressure(W_index ) = pressure(W_index ) + eps_pwf
                           YY(alfa_w) = YY(alfa_w) + eps_pwf
                       EndDO
               Elseif ( Schedule(i_well , 2 , sche_N) .EQ. 2 ) then  ! BHP of Injection specified case
                       qwN = 0
                       qwP = 0
                       counter  = 0
                       con = 0 ! convergence criteria
                       Do while (con == 0)
                           counter = counter + 1
                           O_Volume = 0
                           W_Volume = 0
                           mix_den = 0
                           i_K =  Well_k(i_well ,2)
                           ! stage 2 : obtaining Del_pwf
                           Do i_k = Well_k(i_well , 1) + 1 , Well_k(i_well ,2)
                              c1 = 0
                              c2 = 2
                              Do while ( abs(c1-c2) > 0.1)
                                  c1 = Del_Pwf(i_well , i_k )
                                  B_index = Well_loc(i_well,1) + ( Well_loc(i_well,2) - 1) * Nx + ( i_k - 1 ) * Nx * Ny
                                  N_index = Well_loc(i_well,1) + ( Well_loc(i_well,2) - 1) * Nx + ( i_k - 1 - 1) * Nx * Ny
                                  Del_Pwf(i_well , i_k ) = density( pressure(W_index) + Del_Pwf(i_well, i_k),'w') / 144.0 *( Deltaz(B_index) +  Deltaz(N_index) ) / 2.0
                                  !if (i_k .NE. Well_k(i_well , 1) + 1 ) then ! if this is not the first layer which has del_pwf
                                  Del_Pwf(i_well , i_k ) = Del_Pwf(i_well , i_k ) + Del_Pwf(i_well , i_k - 1)
                                  c2 = Del_Pwf(i_well , i_k )
                              EndDo
                           EndDO                           ! stage 3 : convergence
                           if ( counter .NE. 1 ) then
                              ! checking convergence
                              max_dif = 0
                              Do i_k = Well_k(i_well , 1) , Well_k(i_well ,2)
                                 B_index = Well_loc(i_well,1) + ( Well_loc(i_well,2) - 1) * Nx + ( i_k - 1 )* Nx * Ny
                                 qwN(i_k) = w_index_w(i_well, i_k ) * ( pressure(B_index) - pressure(W_index ) - Del_Pwf(i_well, i_k) )
                                 max_dif = max ( max_dif , abs(qwN(i_k) - qwP(i_k) ) /qwN(i_k) )
                              EndDo
                              if  (max_dif < 0.01)  then
                                 con = 1
                                 !exit
                              EndIf
                           Else
                               Do i_k = Well_k(i_well , 1) , Well_k(i_well ,2)
 								   B_index = Well_loc(i_well,1) + ( Well_loc(i_well,2) - 1) * Nx + ( i_k - 1 )* Nx * Ny
								   qoN(i_k) = w_index_o(i_well, i_k ) * ( pressure(B_index) - pressure(W_index ) - Del_Pwf(i_well, i_k) )
								   qwN(i_k) = w_index_w(i_well, i_k ) * ( pressure(B_index) - pressure(W_index ) - Del_Pwf(i_well, i_k) )
							   EndDo
                           EndIf
                           qoP = qoN
                           qwP = qwN
                       EndDO
            EndIf
       EndIf

   EndDo
   DeAllocate (O_Volume)
   DeAllocate (W_Volume)
   DeAllocate (mix_den)

  Endsubroutine Calc_DeltaPwf
    !********************************************************************************************************
!    subroutine calc_fwell
!
!    Endsubroutine calc_fwell
    !********************************************************************************************************
subroutine check_BHP

integer :: i_well , W_index, alfa_w

integer :: iwell_sche ! Number of well that its schedule has changed
integer :: sche_type , b_index ! type of new schedule
real*8 :: sche_val ! value of new schdule
Logical :: change_Sche ! If a schdule has changed , it would be .True.

change_Sche = .False.
!	If (time == 500) then
!			time = 500
!	endIf
	Do i_well = 1 , Nwell
		b_index =  Well_loc(i_well,1) + ( Well_loc(i_well,2) - 1) * Nx
		change_Sche = .False.
		W_index = Ntotal + i_well  ! Pwf position in pressure vector
		alfa_w = 2 * Ntotal + i_well
		if ( W_type(i_well) == 'prod') then
            if ( WOR(i_well) > max_WOR) then ! shut in the well
				change_Sche = .True.
			    Schedule(i_well , 2 , sche_N) = 1 ! switching to zero rate
		        Schedule(i_well , 3 , sche_N) = 0.0
		        iwell_sche = i_well ; sche_type = 1  ; sche_val = 0.0 ; change_Sche = .True. ; exit
		    EndIf
		    if ((( Schedule(i_well , 2 , sche_N) .EQ. 1 ) .OR. ( Schedule(i_well , 2 , sche_N) .EQ. 3 ) ) .AND. ( Schedule(i_well , 3 , sche_N) .NE. 0 )  )then ! oil rate is given
			   if ( pressure(W_index) < minBHP) then
					change_Sche = .True.
					Schedule(i_well , 2 , sche_N) = 2 ! switching to constant BHP
					Schedule(i_well , 3 , sche_N) = minBHP
					iwell_sche = i_well ; sche_type = 2  ; sche_val = minBHP ; change_Sche = .True. ; exit
			   EndIF
			EndIf

		Else
			if ( Schedule(i_well , 2 , sche_N) .EQ. 1 ) then ! injection rate is given
				if ( pressure(W_index) > maxBHP) then
					change_Sche = .True.
					Schedule(i_well , 2 , sche_N) = 2 ! switching to constant BHP
					Schedule(i_well , 3 , sche_N) = maxBHP
					iwell_sche = i_well ; sche_type = 2  ; sche_val = minBHP ; change_Sche = .True. ; exit
				EndIF
			EndIf
		EndIF

		If (change_Sche) then
			Open(2,DEFAULTFILE='.\sim_output\' , FILE='WARNING_Change of Schedule.DAT', status='unknown' , access = 'append')
			write(2,*) 'Time =' , Time
			write(2,*) 'well #  ', iwell_sche
			write(2,*) 'New Schedule Type', Schedule(iwell_sche , 2 , sche_N)
			write(2,*) 'New Schedule Value', Schedule(iwell_sche, 3 , sche_N)
			close(2)
		EndIf
	EndDo

Endsubroutine check_BHP

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

EndModule Well


C NCLFORTSTART
      SUBROUTINE TRIPLE2GRID2D(X,Y,Z,KPTS,ZMSG,DISTMX,MOPT,LAT2D,LON2D,
     +                         ZGRID,NDIM,MDIM)
      IMPLICIT NONE
      INTEGER KPTS,NDIM,MDIM,MOPT
      DOUBLE PRECISION X(KPTS),Y(KPTS),Z(KPTS),ZMSG,DISTMX
      DOUBLE PRECISION LAT2D(MDIM,NDIM),LON2D(MDIM,NDIM),
     +                 ZGRID(MDIM,NDIM)
C NCLEND

C untested

c          SET EACH GRID POINT TO THE NEAREST OBSERVATION.
c .   The user can set distmx to some value. Setting to
c .   some very large value basically means that all grid
c .   points will be filled. Otherwise, only observations within
c .   distmx will be used.
c
c mopt   option for which distance formula to be used
c .      =  0 ; use pythag approx to calculate distance
c .             (quick/less-general]
c .      =  1 ; use great circle formula to calculate distance (slower)
c
c distmx any x/y observation .le. distmx will be used.
c .      Set to some very large number [ 1.e20 ] if all grid points
c .      are to be returned with some value.
c .      Observations .gt. distmx will be ignored. If distmx is set
c .        small than it is possible that some grid points will be
c .        filled with missing values.

C NCL    zgrid = triple2grid2d (x,y,z, lon2d,lat2d, opt)

c                      local: re: rad earth (km) [only for mopt=1]
      INTEGER N,M,K
      DOUBLE PRECISION DIST(KPTS),DMIN,RE,RLAT,RAD,ATMP
      DATA RE/6371.2200D0/

      RAD = 4.D0*ATAN(1.0D0)/180.D0

      DO N = 1,NDIM
         DO M = 1,MDIM
            ZGRID(M,N) = ZMSG
c           do separately for optimization reasons
            IF (MOPT.EQ.0) THEN
               DO K = 1,KPTS
                  DIST(K) = SQRT((X(K)-LON2D(M,N))**2+
     +                 (Y(K)-LAT2D(M,N))**2)
               END DO
            ELSE
               RLAT = LAT2D(M,N)*RAD
               DO K = 1,KPTS
C
C The ATMP variable is necessary to make sure the
C value passed to ACOS is between -1 and 1.
C (Otherwise, you might get "NaN".)
C
                  ATMP = SIN(RLAT)*SIN(Y(K)*RAD)
     +                   + COS(RLAT)*COS(Y(K)*RAD)*
     +                     COS((X(K)-LON2D(M,N))*RAD)
                  ATMP  = MIN(1.D0,MAX(-1.D0,ATMP))
                  DIST(K) = ACOS(ATMP)*RE
               END DO
            END IF
c     assign z(k) to nearest grid point
            DMIN = 1.D+36
            DO K = 1,KPTS
               IF (Z(K).NE.ZMSG) THEN
                  IF (DIST(K).LT.DMIN .AND. DIST(K).LT.DISTMX) THEN
                     DMIN = DIST(K)
                     ZGRID(M,N) = Z(K)
                  END IF
               END IF
            END DO

         END DO
      END DO

      RETURN
      END


    MODULE blas_dense_mat_op

      ! Fortran 95 Bindings Generic Interface Blocks
      ! .  for section 2.8.7 -- Matrix Operations
      ! .  using external procedures.
      ! Written on 14 December 2000
      ! .  Zohair Maany and Sven Hammarling, NAG Central Office.

      PRIVATE
      PUBLIC :: ge_norm, gb_norm, sy_norm, he_norm, sb_norm, hb_norm, sp_norm, &
       hp_norm, tr_norm, tb_norm, tp_norm, ge_diag_scale, gb_diag_scale, &
       ge_lrscale, gb_lrscale, sy_lrscale, sb_lrscale, sp_lrscale, he_lrscale, &
       hb_lrscale, hp_lrscale, ge_diag_scale_acc, gb_diag_scale_acc, ge_acc, &
       gb_acc, sy_acc, sb_acc, sp_acc, tr_acc, tb_acc, tp_acc, ge_add, gb_add, &
       sy_add, sb_add, sp_add, tr_add, tb_add, tp_add

      INTERFACE ge_norm
        ! a has shape (m,n)
        FUNCTION ge_norm_d(a,norm)
          USE blas_operator_arguments, ONLY : blas_norm_type
          USE blas_precision, ONLY : wp => dp
          REAL (wp), INTENT (IN) :: a(:,:)
          REAL (wp) :: ge_norm_d
          TYPE (blas_norm_type), INTENT (IN), OPTIONAL :: norm
        END FUNCTION ge_norm_d
        FUNCTION ge_norm_z(a,norm)
          USE blas_operator_arguments, ONLY : blas_norm_type
          USE blas_precision, ONLY : wp => dp
          COMPLEX (wp), INTENT (IN) :: a(:,:)
          REAL (wp) :: ge_norm_z
          TYPE (blas_norm_type), INTENT (IN), OPTIONAL :: norm
        END FUNCTION ge_norm_z
        FUNCTION ge_norm_s(a,norm)
          USE blas_operator_arguments, ONLY : blas_norm_type
          USE blas_precision, ONLY : wp => sp
          REAL (wp), INTENT (IN) :: a(:,:)
          REAL (wp) :: ge_norm_s
          TYPE (blas_norm_type), INTENT (IN), OPTIONAL :: norm
        END FUNCTION ge_norm_s
        FUNCTION ge_norm_c(a,norm)
          USE blas_operator_arguments, ONLY : blas_norm_type
          USE blas_precision, ONLY : wp => sp
          COMPLEX (wp), INTENT (IN) :: a(:,:)
          REAL (wp) :: ge_norm_c
          TYPE (blas_norm_type), INTENT (IN), OPTIONAL :: norm
        END FUNCTION ge_norm_c
      END INTERFACE

      INTERFACE gb_norm
        ! a has shape (kl+ku+1,n), ku=SIZE(a,1)-1-kl
        FUNCTION gb_norm_d(a,m,kl,norm)
          USE blas_operator_arguments, ONLY : blas_norm_type
          USE blas_precision, ONLY : wp => dp
          REAL (wp), INTENT (IN) :: a(:,:)
          INTEGER, INTENT (IN) :: m, kl
          REAL (wp) :: gb_norm_d
          TYPE (blas_norm_type), INTENT (IN), OPTIONAL :: norm
        END FUNCTION gb_norm_d
        FUNCTION gb_norm_z(a,m,kl,norm)
          USE blas_operator_arguments, ONLY : blas_norm_type
          USE blas_precision, ONLY : wp => dp
          COMPLEX (wp), INTENT (IN) :: a(:,:)
          INTEGER, INTENT (IN) :: m, kl
          REAL (wp) :: gb_norm_z
          TYPE (blas_norm_type), INTENT (IN), OPTIONAL :: norm
        END FUNCTION gb_norm_z
        FUNCTION gb_norm_s(a,m,kl,norm)
          USE blas_operator_arguments, ONLY : blas_norm_type
          USE blas_precision, ONLY : wp => sp
          REAL (wp), INTENT (IN) :: a(:,:)
          INTEGER, INTENT (IN) :: m, kl
          REAL (wp) :: gb_norm_s
          TYPE (blas_norm_type), INTENT (IN), OPTIONAL :: norm
        END FUNCTION gb_norm_s
        FUNCTION gb_norm_c(a,m,kl,norm)
          USE blas_operator_arguments, ONLY : blas_norm_type
          USE blas_precision, ONLY : wp => sp
          COMPLEX (wp), INTENT (IN) :: a(:,:)
          INTEGER, INTENT (IN) :: m, kl
          REAL (wp) :: gb_norm_c
          TYPE (blas_norm_type), INTENT (IN), OPTIONAL :: norm
        END FUNCTION gb_norm_c
      END INTERFACE

      INTERFACE sy_norm
        ! a has shape (n,n)
        FUNCTION sy_norm_d(a,norm,uplo)
          USE blas_operator_arguments, ONLY : blas_uplo_type, blas_norm_type
          USE blas_precision, ONLY : wp => dp
          REAL (wp), INTENT (IN) :: a(:,:)
          REAL (wp) :: sy_norm_d
          TYPE (blas_uplo_type), INTENT (IN), OPTIONAL :: uplo
          TYPE (blas_norm_type), INTENT (IN), OPTIONAL :: norm
        END FUNCTION sy_norm_d
        FUNCTION sy_norm_z(a,norm,uplo)
          USE blas_operator_arguments, ONLY : blas_uplo_type, blas_norm_type
          USE blas_precision, ONLY : wp => dp
          COMPLEX (wp), INTENT (IN) :: a(:,:)
          REAL (wp) :: sy_norm_z
          TYPE (blas_uplo_type), INTENT (IN), OPTIONAL :: uplo
          TYPE (blas_norm_type), INTENT (IN), OPTIONAL :: norm
        END FUNCTION sy_norm_z
        FUNCTION sy_norm_s(a,norm,uplo)
          USE blas_operator_arguments, ONLY : blas_uplo_type, blas_norm_type
          USE blas_precision, ONLY : wp => sp
          REAL (wp), INTENT (IN) :: a(:,:)
          REAL (wp) :: sy_norm_s
          TYPE (blas_uplo_type), INTENT (IN), OPTIONAL :: uplo
          TYPE (blas_norm_type), INTENT (IN), OPTIONAL :: norm
        END FUNCTION sy_norm_s
        FUNCTION sy_norm_c(a,norm,uplo)
          USE blas_operator_arguments, ONLY : blas_uplo_type, blas_norm_type
          USE blas_precision, ONLY : wp => sp
          COMPLEX (wp), INTENT (IN) :: a(:,:)
          REAL (wp) :: sy_norm_c
          TYPE (blas_uplo_type), INTENT (IN), OPTIONAL :: uplo
          TYPE (blas_norm_type), INTENT (IN), OPTIONAL :: norm
        END FUNCTION sy_norm_c
      END INTERFACE

      INTERFACE he_norm
        ! a has shape (n,n)
        FUNCTION he_norm_z(a,norm,uplo)
          USE blas_operator_arguments, ONLY : blas_uplo_type, blas_norm_type
          USE blas_precision, ONLY : wp => dp
          COMPLEX (wp), INTENT (IN) :: a(:,:)
          REAL (wp) :: he_norm_z
          TYPE (blas_uplo_type), INTENT (IN), OPTIONAL :: uplo
          TYPE (blas_norm_type), INTENT (IN), OPTIONAL :: norm
        END FUNCTION he_norm_z
        FUNCTION he_norm_c(a,norm,uplo)
          USE blas_operator_arguments, ONLY : blas_uplo_type, blas_norm_type
          USE blas_precision, ONLY : wp => sp
          COMPLEX (wp), INTENT (IN) :: a(:,:)
          REAL (wp) :: he_norm_c
          TYPE (blas_uplo_type), INTENT (IN), OPTIONAL :: uplo
          TYPE (blas_norm_type), INTENT (IN), OPTIONAL :: norm
        END FUNCTION he_norm_c
      END INTERFACE

      INTERFACE sb_norm
        ! a has shape (k+1,n), k=band width=size(a,1)-1
        FUNCTION sb_norm_d(a,norm,uplo)
          USE blas_operator_arguments, ONLY : blas_uplo_type, blas_norm_type
          USE blas_precision, ONLY : wp => dp
          REAL (wp), INTENT (IN) :: a(:,:)
          REAL (wp) :: sb_norm_d
          TYPE (blas_uplo_type), INTENT (IN), OPTIONAL :: uplo
          TYPE (blas_norm_type), INTENT (IN), OPTIONAL :: norm
        END FUNCTION sb_norm_d
        FUNCTION sb_norm_z(a,norm,uplo)
          USE blas_operator_arguments, ONLY : blas_uplo_type, blas_norm_type
          USE blas_precision, ONLY : wp => dp
          COMPLEX (wp), INTENT (IN) :: a(:,:)
          REAL (wp) :: sb_norm_z
          TYPE (blas_uplo_type), INTENT (IN), OPTIONAL :: uplo
          TYPE (blas_norm_type), INTENT (IN), OPTIONAL :: norm
        END FUNCTION sb_norm_z
        FUNCTION sb_norm_s(a,norm,uplo)
          USE blas_operator_arguments, ONLY : blas_uplo_type, blas_norm_type
          USE blas_precision, ONLY : wp => sp
          REAL (wp), INTENT (IN) :: a(:,:)
          REAL (wp) :: sb_norm_s
          TYPE (blas_uplo_type), INTENT (IN), OPTIONAL :: uplo
          TYPE (blas_norm_type), INTENT (IN), OPTIONAL :: norm
        END FUNCTION sb_norm_s
        FUNCTION sb_norm_c(a,norm,uplo)
          USE blas_operator_arguments, ONLY : blas_uplo_type, blas_norm_type
          USE blas_precision, ONLY : wp => sp
          COMPLEX (wp), INTENT (IN) :: a(:,:)
          REAL (wp) :: sb_norm_c
          TYPE (blas_uplo_type), INTENT (IN), OPTIONAL :: uplo
          TYPE (blas_norm_type), INTENT (IN), OPTIONAL :: norm
        END FUNCTION sb_norm_c
      END INTERFACE

      INTERFACE hb_norm
        ! a has shape (k+1,n), k=band width=size(a,1)-1
        FUNCTION hb_norm_z(a,norm,uplo)
          USE blas_operator_arguments, ONLY : blas_uplo_type, blas_norm_type
          USE blas_precision, ONLY : wp => dp
          COMPLEX (wp), INTENT (IN) :: a(:,:)
          REAL (wp) :: hb_norm_z
          TYPE (blas_uplo_type), INTENT (IN), OPTIONAL :: uplo
          TYPE (blas_norm_type), INTENT (IN), OPTIONAL :: norm
        END FUNCTION hb_norm_z
        FUNCTION hb_norm_c(a,norm,uplo)
          USE blas_operator_arguments, ONLY : blas_uplo_type, blas_norm_type
          USE blas_precision, ONLY : wp => sp
          COMPLEX (wp), INTENT (IN) :: a(:,:)
          REAL (wp) :: hb_norm_c
          TYPE (blas_uplo_type), INTENT (IN), OPTIONAL :: uplo
          TYPE (blas_norm_type), INTENT (IN), OPTIONAL :: norm
        END FUNCTION hb_norm_c
      END INTERFACE

      INTERFACE sp_norm
        ! ap has shape ((n*1)*n/2)
        FUNCTION sp_norm_d(ap,norm,uplo)
          USE blas_operator_arguments, ONLY : blas_uplo_type, blas_norm_type
          USE blas_precision, ONLY : wp => dp
          REAL (wp), INTENT (IN) :: ap(:)
          REAL (wp) :: sp_norm_d
          TYPE (blas_uplo_type), INTENT (IN), OPTIONAL :: uplo
          TYPE (blas_norm_type), INTENT (IN), OPTIONAL :: norm
        END FUNCTION sp_norm_d
        FUNCTION sp_norm_z(ap,norm,uplo)
          USE blas_operator_arguments, ONLY : blas_uplo_type, blas_norm_type
          USE blas_precision, ONLY : wp => dp
          COMPLEX (wp), INTENT (IN) :: ap(:)
          REAL (wp) :: sp_norm_z
          TYPE (blas_uplo_type), INTENT (IN), OPTIONAL :: uplo
          TYPE (blas_norm_type), INTENT (IN), OPTIONAL :: norm
        END FUNCTION sp_norm_z
        FUNCTION sp_norm_s(ap,norm,uplo)
          USE blas_operator_arguments, ONLY : blas_uplo_type, blas_norm_type
          USE blas_precision, ONLY : wp => sp
          REAL (wp), INTENT (IN) :: ap(:)
          REAL (wp) :: sp_norm_s
          TYPE (blas_uplo_type), INTENT (IN), OPTIONAL :: uplo
          TYPE (blas_norm_type), INTENT (IN), OPTIONAL :: norm
        END FUNCTION sp_norm_s
        FUNCTION sp_norm_c(ap,norm,uplo)
          USE blas_operator_arguments, ONLY : blas_uplo_type, blas_norm_type
          USE blas_precision, ONLY : wp => sp
          COMPLEX (wp), INTENT (IN) :: ap(:)
          REAL (wp) :: sp_norm_c
          TYPE (blas_uplo_type), INTENT (IN), OPTIONAL :: uplo
          TYPE (blas_norm_type), INTENT (IN), OPTIONAL :: norm
        END FUNCTION sp_norm_c
      END INTERFACE

      INTERFACE hp_norm
        ! ap has shape ((n*1)*n/2)
        FUNCTION hp_norm_z(ap,norm,uplo)
          USE blas_operator_arguments, ONLY : blas_uplo_type, blas_norm_type
          USE blas_precision, ONLY : wp => dp
          COMPLEX (wp), INTENT (IN) :: ap(:)
          REAL (wp) :: hp_norm_z
          TYPE (blas_uplo_type), INTENT (IN), OPTIONAL :: uplo
          TYPE (blas_norm_type), INTENT (IN), OPTIONAL :: norm
        END FUNCTION hp_norm_z
        FUNCTION hp_norm_c(ap,norm,uplo)
          USE blas_operator_arguments, ONLY : blas_uplo_type, blas_norm_type
          USE blas_precision, ONLY : wp => sp
          COMPLEX (wp), INTENT (IN) :: ap(:)
          REAL (wp) :: hp_norm_c
          TYPE (blas_uplo_type), INTENT (IN), OPTIONAL :: uplo
          TYPE (blas_norm_type), INTENT (IN), OPTIONAL :: norm
        END FUNCTION hp_norm_c
      END INTERFACE

      INTERFACE tr_norm
        ! a has shape (n,n)
        FUNCTION tr_norm_d(a,norm,uplo,diag)
          USE blas_operator_arguments, ONLY : blas_uplo_type, blas_norm_type, &
           blas_diag_type
          USE blas_precision, ONLY : wp => dp
          REAL (wp), INTENT (IN) :: a(:,:)
          REAL (wp) :: tr_norm_d
          TYPE (blas_uplo_type), INTENT (IN), OPTIONAL :: uplo
          TYPE (blas_norm_type), INTENT (IN), OPTIONAL :: norm
          TYPE (blas_diag_type), INTENT (IN), OPTIONAL :: diag
        END FUNCTION tr_norm_d
        FUNCTION tr_norm_z(a,norm,uplo,diag)
          USE blas_operator_arguments, ONLY : blas_uplo_type, blas_norm_type, &
           blas_diag_type
          USE blas_precision, ONLY : wp => dp
          COMPLEX (wp), INTENT (IN) :: a(:,:)
          REAL (wp) :: tr_norm_z
          TYPE (blas_uplo_type), INTENT (IN), OPTIONAL :: uplo
          TYPE (blas_norm_type), INTENT (IN), OPTIONAL :: norm
          TYPE (blas_diag_type), INTENT (IN), OPTIONAL :: diag
        END FUNCTION tr_norm_z
        FUNCTION tr_norm_s(a,norm,uplo,diag)
          USE blas_operator_arguments, ONLY : blas_uplo_type, blas_norm_type, &
           blas_diag_type
          USE blas_precision, ONLY : wp => sp
          REAL (wp), INTENT (IN) :: a(:,:)
          REAL (wp) :: tr_norm_s
          TYPE (blas_uplo_type), INTENT (IN), OPTIONAL :: uplo
          TYPE (blas_norm_type), INTENT (IN), OPTIONAL :: norm
          TYPE (blas_diag_type), INTENT (IN), OPTIONAL :: diag
        END FUNCTION tr_norm_s
        FUNCTION tr_norm_c(a,norm,uplo,diag)
          USE blas_operator_arguments, ONLY : blas_uplo_type, blas_norm_type, &
           blas_diag_type
          USE blas_precision, ONLY : wp => sp
          COMPLEX (wp), INTENT (IN) :: a(:,:)
          REAL (wp) :: tr_norm_c
          TYPE (blas_uplo_type), INTENT (IN), OPTIONAL :: uplo
          TYPE (blas_norm_type), INTENT (IN), OPTIONAL :: norm
          TYPE (blas_diag_type), INTENT (IN), OPTIONAL :: diag
        END FUNCTION tr_norm_c
      END INTERFACE

      INTERFACE tb_norm
        ! a has shape (k+1,n), k=band width=size(a,1)-1
        FUNCTION tb_norm_d(a,norm,uplo,diag)
          USE blas_operator_arguments, ONLY : blas_uplo_type, blas_norm_type, &
           blas_diag_type
          USE blas_precision, ONLY : wp => dp
          REAL (wp), INTENT (IN) :: a(:,:)
          REAL (wp) :: tb_norm_d
          TYPE (blas_uplo_type), INTENT (IN), OPTIONAL :: uplo
          TYPE (blas_norm_type), INTENT (IN), OPTIONAL :: norm
          TYPE (blas_diag_type), INTENT (IN), OPTIONAL :: diag
        END FUNCTION tb_norm_d
        FUNCTION tb_norm_z(a,norm,uplo,diag)
          USE blas_operator_arguments, ONLY : blas_uplo_type, blas_norm_type, &
           blas_diag_type
          USE blas_precision, ONLY : wp => dp
          COMPLEX (wp), INTENT (IN) :: a(:,:)
          REAL (wp) :: tb_norm_z
          TYPE (blas_uplo_type), INTENT (IN), OPTIONAL :: uplo
          TYPE (blas_norm_type), INTENT (IN), OPTIONAL :: norm
          TYPE (blas_diag_type), INTENT (IN), OPTIONAL :: diag
        END FUNCTION tb_norm_z
        FUNCTION tb_norm_s(a,norm,uplo,diag)
          USE blas_operator_arguments, ONLY : blas_uplo_type, blas_norm_type, &
           blas_diag_type
          USE blas_precision, ONLY : wp => sp
          REAL (wp), INTENT (IN) :: a(:,:)
          REAL (wp) :: tb_norm_s
          TYPE (blas_uplo_type), INTENT (IN), OPTIONAL :: uplo
          TYPE (blas_norm_type), INTENT (IN), OPTIONAL :: norm
          TYPE (blas_diag_type), INTENT (IN), OPTIONAL :: diag
        END FUNCTION tb_norm_s
        FUNCTION tb_norm_c(a,norm,uplo,diag)
          USE blas_operator_arguments, ONLY : blas_uplo_type, blas_norm_type, &
           blas_diag_type
          USE blas_precision, ONLY : wp => sp
          COMPLEX (wp), INTENT (IN) :: a(:,:)
          REAL (wp) :: tb_norm_c
          TYPE (blas_uplo_type), INTENT (IN), OPTIONAL :: uplo
          TYPE (blas_norm_type), INTENT (IN), OPTIONAL :: norm
          TYPE (blas_diag_type), INTENT (IN), OPTIONAL :: diag
        END FUNCTION tb_norm_c
      END INTERFACE

      INTERFACE tp_norm
        ! ap has shape ((n+1)*n/2)
        FUNCTION tp_norm_d(ap,norm,uplo,diag)
          USE blas_operator_arguments, ONLY : blas_uplo_type, blas_norm_type, &
           blas_diag_type
          USE blas_precision, ONLY : wp => dp
          REAL (wp), INTENT (IN) :: ap(:)
          REAL (wp) :: tp_norm_d
          TYPE (blas_uplo_type), INTENT (IN), OPTIONAL :: uplo
          TYPE (blas_norm_type), INTENT (IN), OPTIONAL :: norm
          TYPE (blas_diag_type), INTENT (IN), OPTIONAL :: diag
        END FUNCTION tp_norm_d
        FUNCTION tp_norm_z(ap,norm,uplo,diag)
          USE blas_operator_arguments, ONLY : blas_uplo_type, blas_norm_type, &
           blas_diag_type
          USE blas_precision, ONLY : wp => dp
          COMPLEX (wp), INTENT (IN) :: ap(:)
          REAL (wp) :: tp_norm_z
          TYPE (blas_uplo_type), INTENT (IN), OPTIONAL :: uplo
          TYPE (blas_norm_type), INTENT (IN), OPTIONAL :: norm
          TYPE (blas_diag_type), INTENT (IN), OPTIONAL :: diag
        END FUNCTION tp_norm_z
        FUNCTION tp_norm_s(ap,norm,uplo,diag)
          USE blas_operator_arguments, ONLY : blas_uplo_type, blas_norm_type, &
           blas_diag_type
          USE blas_precision, ONLY : wp => sp
          REAL (wp), INTENT (IN) :: ap(:)
          REAL (wp) :: tp_norm_s
          TYPE (blas_uplo_type), INTENT (IN), OPTIONAL :: uplo
          TYPE (blas_norm_type), INTENT (IN), OPTIONAL :: norm
          TYPE (blas_diag_type), INTENT (IN), OPTIONAL :: diag
        END FUNCTION tp_norm_s
        FUNCTION tp_norm_c(ap,norm,uplo,diag)
          USE blas_operator_arguments, ONLY : blas_uplo_type, blas_norm_type, &
           blas_diag_type
          USE blas_precision, ONLY : wp => sp
          COMPLEX (wp), INTENT (IN) :: ap(:)
          REAL (wp) :: tp_norm_c
          TYPE (blas_uplo_type), INTENT (IN), OPTIONAL :: uplo
          TYPE (blas_norm_type), INTENT (IN), OPTIONAL :: norm
          TYPE (blas_diag_type), INTENT (IN), OPTIONAL :: diag
        END FUNCTION tp_norm_c
      END INTERFACE

      INTERFACE ge_diag_scale
        ! a has shape (m,n)
        ! d has shape (m), if side = blas_left_side
        ! .     shape (n), if side = blas_right_side
        SUBROUTINE ge_diag_scale_d(d,a,side)
          USE blas_operator_arguments, ONLY : blas_side_type
          USE blas_precision, ONLY : wp => dp
          REAL (wp), INTENT (IN) :: d(:)
          REAL (wp), INTENT (INOUT) :: a(:,:)
          TYPE (blas_side_type), INTENT (IN), OPTIONAL :: side
        END SUBROUTINE ge_diag_scale_d
        SUBROUTINE ge_diag_scale_z(d,a,side)
          USE blas_operator_arguments, ONLY : blas_side_type
          USE blas_precision, ONLY : wp => dp
          COMPLEX (wp), INTENT (IN) :: d(:)
          COMPLEX (wp), INTENT (INOUT) :: a(:,:)
          TYPE (blas_side_type), INTENT (IN), OPTIONAL :: side
        END SUBROUTINE ge_diag_scale_z
        SUBROUTINE ge_diag_scale_s(d,a,side)
          USE blas_operator_arguments, ONLY : blas_side_type
          USE blas_precision, ONLY : wp => sp
          REAL (wp), INTENT (IN) :: d(:)
          REAL (wp), INTENT (INOUT) :: a(:,:)
          TYPE (blas_side_type), INTENT (IN), OPTIONAL :: side
        END SUBROUTINE ge_diag_scale_s
        SUBROUTINE ge_diag_scale_c(d,a,side)
          USE blas_operator_arguments, ONLY : blas_side_type
          USE blas_precision, ONLY : wp => sp
          COMPLEX (wp), INTENT (IN) :: d(:)
          COMPLEX (wp), INTENT (INOUT) :: a(:,:)
          TYPE (blas_side_type), INTENT (IN), OPTIONAL :: side
        END SUBROUTINE ge_diag_scale_c
      END INTERFACE

      INTERFACE gb_diag_scale
        ! a has shape (kl+ku+1,n), ku=SIZE(a,1)-1-kl
        ! d has shape (m), if side = blas_left_side
        ! .     shape (n), if side = blas_right_side
        SUBROUTINE gb_diag_scale_d(d,a,m,kl,side)
          USE blas_operator_arguments, ONLY : blas_side_type
          USE blas_precision, ONLY : wp => dp
          REAL (wp), INTENT (IN) :: d(:)
          REAL (wp), INTENT (INOUT) :: a(:,:)
          INTEGER, INTENT (IN) :: m, kl
          TYPE (blas_side_type), INTENT (IN), OPTIONAL :: side
        END SUBROUTINE gb_diag_scale_d
        SUBROUTINE gb_diag_scale_z(d,a,m,kl,side)
          USE blas_operator_arguments, ONLY : blas_side_type
          USE blas_precision, ONLY : wp => dp
          COMPLEX (wp), INTENT (IN) :: d(:)
          COMPLEX (wp), INTENT (INOUT) :: a(:,:)
          INTEGER, INTENT (IN) :: m, kl
          TYPE (blas_side_type), INTENT (IN), OPTIONAL :: side
        END SUBROUTINE gb_diag_scale_z
        SUBROUTINE gb_diag_scale_s(d,a,m,kl,side)
          USE blas_operator_arguments, ONLY : blas_side_type
          USE blas_precision, ONLY : wp => sp
          REAL (wp), INTENT (IN) :: d(:)
          REAL (wp), INTENT (INOUT) :: a(:,:)
          INTEGER, INTENT (IN) :: m, kl
          TYPE (blas_side_type), INTENT (IN), OPTIONAL :: side
        END SUBROUTINE gb_diag_scale_s
        SUBROUTINE gb_diag_scale_c(d,a,m,kl,side)
          USE blas_operator_arguments, ONLY : blas_side_type
          USE blas_precision, ONLY : wp => sp
          COMPLEX (wp), INTENT (IN) :: d(:)
          COMPLEX (wp), INTENT (INOUT) :: a(:,:)
          INTEGER, INTENT (IN) :: m, kl
          TYPE (blas_side_type), INTENT (IN), OPTIONAL :: side
        END SUBROUTINE gb_diag_scale_c
      END INTERFACE

      INTERFACE ge_lrscale
        ! a has shape (m,n)
        ! dl has shape (m)
        ! dr has shape (n)
        SUBROUTINE ge_lrscale_d(dl,dr,a)
          USE blas_precision, ONLY : wp => dp
          REAL (wp), INTENT (IN) :: dl(:), dr(:)
          REAL (wp), INTENT (INOUT) :: a(:,:)
        END SUBROUTINE ge_lrscale_d
        SUBROUTINE ge_lrscale_z(dl,dr,a)
          USE blas_precision, ONLY : wp => dp
          COMPLEX (wp), INTENT (IN) :: dl(:), dr(:)
          COMPLEX (wp), INTENT (INOUT) :: a(:,:)
        END SUBROUTINE ge_lrscale_z
        SUBROUTINE ge_lrscale_s(dl,dr,a)
          USE blas_precision, ONLY : wp => sp
          REAL (wp), INTENT (IN) :: dl(:), dr(:)
          REAL (wp), INTENT (INOUT) :: a(:,:)
        END SUBROUTINE ge_lrscale_s
        SUBROUTINE ge_lrscale_c(dl,dr,a)
          USE blas_precision, ONLY : wp => sp
          COMPLEX (wp), INTENT (IN) :: dl(:), dr(:)
          COMPLEX (wp), INTENT (INOUT) :: a(:,:)
        END SUBROUTINE ge_lrscale_c
      END INTERFACE

      INTERFACE gb_lrscale
        ! a has shape (kl+ku+1,n), ku=SIZE(a,1)-1-kl
        ! dl has shape (m)
        ! dr has shape (n)
        SUBROUTINE gb_lrscale_d(dl,dr,a,m,kl)
          USE blas_precision, ONLY : wp => dp
          REAL (wp), INTENT (IN) :: dl(:), dr(:)
          REAL (wp), INTENT (INOUT) :: a(:,:)
          INTEGER, INTENT (IN) :: m, kl
        END SUBROUTINE gb_lrscale_d
        SUBROUTINE gb_lrscale_z(dl,dr,a,m,kl)
          USE blas_precision, ONLY : wp => dp
          COMPLEX (wp), INTENT (IN) :: dl(:), dr(:)
          COMPLEX (wp), INTENT (INOUT) :: a(:,:)
          INTEGER, INTENT (IN) :: m, kl
        END SUBROUTINE gb_lrscale_z
        SUBROUTINE gb_lrscale_s(dl,dr,a,m,kl)
          USE blas_precision, ONLY : wp => sp
          REAL (wp), INTENT (IN) :: dl(:), dr(:)
          REAL (wp), INTENT (INOUT) :: a(:,:)
          INTEGER, INTENT (IN) :: m, kl
        END SUBROUTINE gb_lrscale_s
        SUBROUTINE gb_lrscale_c(dl,dr,a,m,kl)
          USE blas_precision, ONLY : wp => sp
          COMPLEX (wp), INTENT (IN) :: dl(:), dr(:)
          COMPLEX (wp), INTENT (INOUT) :: a(:,:)
          INTEGER, INTENT (IN) :: m, kl
        END SUBROUTINE gb_lrscale_c
      END INTERFACE

      INTERFACE sy_lrscale
        ! a has shape (n,n)
        ! d has shape (n)
        SUBROUTINE sy_lrscale_d(d,a,uplo)
          USE blas_operator_arguments, ONLY : blas_uplo_type
          USE blas_precision, ONLY : wp => dp
          REAL (wp), INTENT (IN) :: d(:)
          REAL (wp), INTENT (INOUT) :: a(:,:)
          TYPE (blas_uplo_type), INTENT (IN), OPTIONAL :: uplo
        END SUBROUTINE sy_lrscale_d
        SUBROUTINE sy_lrscale_z(d,a,uplo)
          USE blas_operator_arguments, ONLY : blas_uplo_type
          USE blas_precision, ONLY : wp => dp
          COMPLEX (wp), INTENT (IN) :: d(:)
          COMPLEX (wp), INTENT (INOUT) :: a(:,:)
          TYPE (blas_uplo_type), INTENT (IN), OPTIONAL :: uplo
        END SUBROUTINE sy_lrscale_z
        SUBROUTINE sy_lrscale_s(d,a,uplo)
          USE blas_operator_arguments, ONLY : blas_uplo_type
          USE blas_precision, ONLY : wp => sp
          REAL (wp), INTENT (IN) :: d(:)
          REAL (wp), INTENT (INOUT) :: a(:,:)
          TYPE (blas_uplo_type), INTENT (IN), OPTIONAL :: uplo
        END SUBROUTINE sy_lrscale_s
        SUBROUTINE sy_lrscale_c(d,a,uplo)
          USE blas_operator_arguments, ONLY : blas_uplo_type
          USE blas_precision, ONLY : wp => sp
          COMPLEX (wp), INTENT (IN) :: d(:)
          COMPLEX (wp), INTENT (INOUT) :: a(:,:)
          TYPE (blas_uplo_type), INTENT (IN), OPTIONAL :: uplo
        END SUBROUTINE sy_lrscale_c
      END INTERFACE

      INTERFACE sb_lrscale
        ! a has shape (k+1,n), k=band width=size(a,1)-1
        ! d has shape (n)
        SUBROUTINE sb_lrscale_d(d,a,uplo)
          USE blas_operator_arguments, ONLY : blas_uplo_type
          USE blas_precision, ONLY : wp => dp
          REAL (wp), INTENT (IN) :: d(:)
          REAL (wp), INTENT (INOUT) :: a(:,:)
          TYPE (blas_uplo_type), INTENT (IN), OPTIONAL :: uplo
        END SUBROUTINE sb_lrscale_d
        SUBROUTINE sb_lrscale_z(d,a,uplo)
          USE blas_operator_arguments, ONLY : blas_uplo_type
          USE blas_precision, ONLY : wp => dp
          COMPLEX (wp), INTENT (IN) :: d(:)
          COMPLEX (wp), INTENT (INOUT) :: a(:,:)
          TYPE (blas_uplo_type), INTENT (IN), OPTIONAL :: uplo
        END SUBROUTINE sb_lrscale_z
        SUBROUTINE sb_lrscale_s(d,a,uplo)
          USE blas_operator_arguments, ONLY : blas_uplo_type
          USE blas_precision, ONLY : wp => sp
          REAL (wp), INTENT (IN) :: d(:)
          REAL (wp), INTENT (INOUT) :: a(:,:)
          TYPE (blas_uplo_type), INTENT (IN), OPTIONAL :: uplo
        END SUBROUTINE sb_lrscale_s
        SUBROUTINE sb_lrscale_c(d,a,uplo)
          USE blas_operator_arguments, ONLY : blas_uplo_type
          USE blas_precision, ONLY : wp => sp
          COMPLEX (wp), INTENT (IN) :: d(:)
          COMPLEX (wp), INTENT (INOUT) :: a(:,:)
          TYPE (blas_uplo_type), INTENT (IN), OPTIONAL :: uplo
        END SUBROUTINE sb_lrscale_c
      END INTERFACE

      INTERFACE sp_lrscale
        ! ap has shape ((n+1)*n/2)
        ! d has shape (n)
        SUBROUTINE sp_lrscale_d(d,ap,uplo)
          USE blas_operator_arguments, ONLY : blas_uplo_type
          USE blas_precision, ONLY : wp => dp
          REAL (wp), INTENT (IN) :: d(:)
          REAL (wp), INTENT (INOUT) :: ap(:)
          TYPE (blas_uplo_type), INTENT (IN), OPTIONAL :: uplo
        END SUBROUTINE sp_lrscale_d
        SUBROUTINE sp_lrscale_z(d,ap,uplo)
          USE blas_operator_arguments, ONLY : blas_uplo_type
          USE blas_precision, ONLY : wp => dp
          COMPLEX (wp), INTENT (IN) :: d(:)
          COMPLEX (wp), INTENT (INOUT) :: ap(:)
          TYPE (blas_uplo_type), INTENT (IN), OPTIONAL :: uplo
        END SUBROUTINE sp_lrscale_z
        SUBROUTINE sp_lrscale_s(d,ap,uplo)
          USE blas_operator_arguments, ONLY : blas_uplo_type
          USE blas_precision, ONLY : wp => sp
          REAL (wp), INTENT (IN) :: d(:)
          REAL (wp), INTENT (INOUT) :: ap(:)
          TYPE (blas_uplo_type), INTENT (IN), OPTIONAL :: uplo
        END SUBROUTINE sp_lrscale_s
        SUBROUTINE sp_lrscale_c(d,ap,uplo)
          USE blas_operator_arguments, ONLY : blas_uplo_type
          USE blas_precision, ONLY : wp => sp
          COMPLEX (wp), INTENT (IN) :: d(:)
          COMPLEX (wp), INTENT (INOUT) :: ap(:)
          TYPE (blas_uplo_type), INTENT (IN), OPTIONAL :: uplo
        END SUBROUTINE sp_lrscale_c
      END INTERFACE

      INTERFACE he_lrscale
        ! a has shape (n,n)
        ! d has shape (n)
        SUBROUTINE he_lrscale_z(d,a,uplo)
          USE blas_operator_arguments, ONLY : blas_uplo_type
          USE blas_precision, ONLY : wp => dp
          COMPLEX (wp), INTENT (IN) :: d(:)
          COMPLEX (wp), INTENT (INOUT) :: a(:,:)
          TYPE (blas_uplo_type), INTENT (IN), OPTIONAL :: uplo
        END SUBROUTINE he_lrscale_z
        SUBROUTINE he_lrscale_c(d,a,uplo)
          USE blas_operator_arguments, ONLY : blas_uplo_type
          USE blas_precision, ONLY : wp => sp
          COMPLEX (wp), INTENT (IN) :: d(:)
          COMPLEX (wp), INTENT (INOUT) :: a(:,:)
          TYPE (blas_uplo_type), INTENT (IN), OPTIONAL :: uplo
        END SUBROUTINE he_lrscale_c
      END INTERFACE

      INTERFACE hb_lrscale
        ! a has shape (k+1,n), k=band width=size(a,1)-1
        ! d has shape (n)
        SUBROUTINE hb_lrscale_z(d,a,uplo)
          USE blas_operator_arguments, ONLY : blas_uplo_type
          USE blas_precision, ONLY : wp => dp
          COMPLEX (wp), INTENT (IN) :: d(:)
          COMPLEX (wp), INTENT (INOUT) :: a(:,:)
          TYPE (blas_uplo_type), INTENT (IN), OPTIONAL :: uplo
        END SUBROUTINE hb_lrscale_z
        SUBROUTINE hb_lrscale_c(d,a,uplo)
          USE blas_operator_arguments, ONLY : blas_uplo_type
          USE blas_precision, ONLY : wp => sp
          COMPLEX (wp), INTENT (IN) :: d(:)
          COMPLEX (wp), INTENT (INOUT) :: a(:,:)
          TYPE (blas_uplo_type), INTENT (IN), OPTIONAL :: uplo
        END SUBROUTINE hb_lrscale_c
      END INTERFACE

      INTERFACE hp_lrscale
        ! ap has shape ((n+1)*n/2)
        ! d has shape (n)
        SUBROUTINE hp_lrscale_z(d,ap,uplo)
          USE blas_operator_arguments, ONLY : blas_uplo_type
          USE blas_precision, ONLY : wp => dp
          COMPLEX (wp), INTENT (IN) :: d(:)
          COMPLEX (wp), INTENT (INOUT) :: ap(:)
          TYPE (blas_uplo_type), INTENT (IN), OPTIONAL :: uplo
        END SUBROUTINE hp_lrscale_z
        SUBROUTINE hp_lrscale_c(d,ap,uplo)
          USE blas_operator_arguments, ONLY : blas_uplo_type
          USE blas_precision, ONLY : wp => sp
          COMPLEX (wp), INTENT (IN) :: d(:)
          COMPLEX (wp), INTENT (INOUT) :: ap(:)
          TYPE (blas_uplo_type), INTENT (IN), OPTIONAL :: uplo
        END SUBROUTINE hp_lrscale_c
      END INTERFACE

      INTERFACE ge_diag_scale_acc
        ! a and b have shape (m,n)
        ! d has shape (n)
        SUBROUTINE ge_diag_scale_acc_d(b,d,a)
          USE blas_precision, ONLY : wp => dp
          REAL (wp), INTENT (IN) :: b(:,:), d(:)
          REAL (wp), INTENT (INOUT) :: a(:,:)
        END SUBROUTINE ge_diag_scale_acc_d
        SUBROUTINE ge_diag_scale_acc_z(b,d,a)
          USE blas_precision, ONLY : wp => dp
          COMPLEX (wp), INTENT (IN) :: b(:,:), d(:)
          COMPLEX (wp), INTENT (INOUT) :: a(:,:)
        END SUBROUTINE ge_diag_scale_acc_z
        SUBROUTINE ge_diag_scale_acc_s(b,d,a)
          USE blas_precision, ONLY : wp => sp
          REAL (wp), INTENT (IN) :: b(:,:), d(:)
          REAL (wp), INTENT (INOUT) :: a(:,:)
        END SUBROUTINE ge_diag_scale_acc_s
        SUBROUTINE ge_diag_scale_acc_c(b,d,a)
          USE blas_precision, ONLY : wp => sp
          COMPLEX (wp), INTENT (IN) :: b(:,:), d(:)
          COMPLEX (wp), INTENT (INOUT) :: a(:,:)
        END SUBROUTINE ge_diag_scale_acc_c
      END INTERFACE

      INTERFACE gb_diag_scale_acc
        ! a has shape (m,n)
        ! b has shape (kl+ku+1,n), ku=SIZE(a,1)-1-kl
        ! d has shape (n)
        SUBROUTINE gb_diag_scale_acc_d(b,m,kl,d,a)
          USE blas_precision, ONLY : wp => dp
          REAL (wp), INTENT (IN) :: b(:,:), d(:)
          REAL (wp), INTENT (INOUT) :: a(:,:)
          INTEGER, INTENT (IN) :: m, kl
        END SUBROUTINE gb_diag_scale_acc_d
        SUBROUTINE gb_diag_scale_acc_z(b,m,kl,d,a)
          USE blas_precision, ONLY : wp => dp
          COMPLEX (wp), INTENT (IN) :: b(:,:), d(:)
          COMPLEX (wp), INTENT (INOUT) :: a(:,:)
          INTEGER, INTENT (IN) :: m, kl
        END SUBROUTINE gb_diag_scale_acc_z
        SUBROUTINE gb_diag_scale_acc_s(b,m,kl,d,a)
          USE blas_precision, ONLY : wp => sp
          REAL (wp), INTENT (IN) :: b(:,:), d(:)
          REAL (wp), INTENT (INOUT) :: a(:,:)
          INTEGER, INTENT (IN) :: m, kl
        END SUBROUTINE gb_diag_scale_acc_s
        SUBROUTINE gb_diag_scale_acc_c(b,m,kl,d,a)
          USE blas_precision, ONLY : wp => sp
          COMPLEX (wp), INTENT (IN) :: b(:,:), d(:)
          COMPLEX (wp), INTENT (INOUT) :: a(:,:)
          INTEGER, INTENT (IN) :: m, kl
        END SUBROUTINE gb_diag_scale_acc_c
      END INTERFACE

      INTERFACE ge_acc
        ! a and b have shape (m,n)
        SUBROUTINE ge_acc_d(a,b,trans,alpha,beta)
          USE blas_operator_arguments, ONLY : blas_trans_type
          USE blas_precision, ONLY : wp => dp
          REAL (wp), INTENT (IN) :: a(:,:)
          REAL (wp), INTENT (INOUT) :: b(:,:)
          REAL (wp), INTENT (IN), OPTIONAL :: alpha, beta
          TYPE (blas_trans_type), INTENT (IN), OPTIONAL :: trans
        END SUBROUTINE ge_acc_d
        SUBROUTINE ge_acc_z(a,b,trans,alpha,beta)
          USE blas_operator_arguments, ONLY : blas_trans_type
          USE blas_precision, ONLY : wp => dp
          COMPLEX (wp), INTENT (IN) :: a(:,:)
          COMPLEX (wp), INTENT (INOUT) :: b(:,:)
          COMPLEX (wp), INTENT (IN), OPTIONAL :: alpha, beta
          TYPE (blas_trans_type), INTENT (IN), OPTIONAL :: trans
        END SUBROUTINE ge_acc_z
        SUBROUTINE ge_acc_s(a,b,trans,alpha,beta)
          USE blas_operator_arguments, ONLY : blas_trans_type
          USE blas_precision, ONLY : wp => sp
          REAL (wp), INTENT (IN) :: a(:,:)
          REAL (wp), INTENT (INOUT) :: b(:,:)
          REAL (wp), INTENT (IN), OPTIONAL :: alpha, beta
          TYPE (blas_trans_type), INTENT (IN), OPTIONAL :: trans
        END SUBROUTINE ge_acc_s
        SUBROUTINE ge_acc_c(a,b,trans,alpha,beta)
          USE blas_operator_arguments, ONLY : blas_trans_type
          USE blas_precision, ONLY : wp => sp
          COMPLEX (wp), INTENT (IN) :: a(:,:)
          COMPLEX (wp), INTENT (INOUT) :: b(:,:)
          COMPLEX (wp), INTENT (IN), OPTIONAL :: alpha, beta
          TYPE (blas_trans_type), INTENT (IN), OPTIONAL :: trans
        END SUBROUTINE ge_acc_c
      END INTERFACE

      INTERFACE gb_acc
        ! a and b have shape (kl+ku+1,n), ku=SIZE(a,1)-1-kl
        SUBROUTINE gb_acc_d(a,m,kl,b,alpha,beta)
          USE blas_precision, ONLY : wp => dp
          REAL (wp), INTENT (IN) :: a(:,:)
          INTEGER, INTENT (IN) :: m, kl
          REAL (wp), INTENT (INOUT) :: b(:,:)
          REAL (wp), INTENT (IN), OPTIONAL :: alpha, beta
        END SUBROUTINE gb_acc_d
        SUBROUTINE gb_acc_z(a,m,kl,b,alpha,beta)
          USE blas_precision, ONLY : wp => dp
          COMPLEX (wp), INTENT (IN) :: a(:,:)
          INTEGER, INTENT (IN) :: m, kl
          COMPLEX (wp), INTENT (INOUT) :: b(:,:)
          COMPLEX (wp), INTENT (IN), OPTIONAL :: alpha, beta
        END SUBROUTINE gb_acc_z
        SUBROUTINE gb_acc_s(a,m,kl,b,alpha,beta)
          USE blas_precision, ONLY : wp => sp
          REAL (wp), INTENT (IN) :: a(:,:)
          INTEGER, INTENT (IN) :: m, kl
          REAL (wp), INTENT (INOUT) :: b(:,:)
          REAL (wp), INTENT (IN), OPTIONAL :: alpha, beta
        END SUBROUTINE gb_acc_s
        SUBROUTINE gb_acc_c(a,m,kl,b,alpha,beta)
          USE blas_precision, ONLY : wp => sp
          COMPLEX (wp), INTENT (IN) :: a(:,:)
          INTEGER, INTENT (IN) :: m, kl
          COMPLEX (wp), INTENT (INOUT) :: b(:,:)
          COMPLEX (wp), INTENT (IN), OPTIONAL :: alpha, beta
        END SUBROUTINE gb_acc_c
      END INTERFACE

      INTERFACE sy_acc
        ! a and b have shape (n,n)
        SUBROUTINE sy_acc_d(a,b,uplo,trans,alpha,beta)
          USE blas_operator_arguments, ONLY : blas_uplo_type, blas_trans_type
          USE blas_precision, ONLY : wp => dp
          REAL (wp), INTENT (IN) :: a(:,:)
          REAL (wp), INTENT (INOUT) :: b(:,:)
          REAL (wp), INTENT (IN), OPTIONAL :: alpha, beta
          TYPE (blas_uplo_type), INTENT (IN), OPTIONAL :: uplo
          TYPE (blas_trans_type), INTENT (IN), OPTIONAL :: trans
        END SUBROUTINE sy_acc_d
        SUBROUTINE sy_acc_z(a,b,uplo,trans,alpha,beta)
          USE blas_operator_arguments, ONLY : blas_uplo_type, blas_trans_type
          USE blas_precision, ONLY : wp => dp
          COMPLEX (wp), INTENT (IN) :: a(:,:)
          COMPLEX (wp), INTENT (INOUT) :: b(:,:)
          COMPLEX (wp), INTENT (IN), OPTIONAL :: alpha, beta
          TYPE (blas_uplo_type), INTENT (IN), OPTIONAL :: uplo
          TYPE (blas_trans_type), INTENT (IN), OPTIONAL :: trans
        END SUBROUTINE sy_acc_z
        SUBROUTINE sy_acc_s(a,b,uplo,trans,alpha,beta)
          USE blas_operator_arguments, ONLY : blas_uplo_type, blas_trans_type
          USE blas_precision, ONLY : wp => sp
          REAL (wp), INTENT (IN) :: a(:,:)
          REAL (wp), INTENT (INOUT) :: b(:,:)
          REAL (wp), INTENT (IN), OPTIONAL :: alpha, beta
          TYPE (blas_uplo_type), INTENT (IN), OPTIONAL :: uplo
          TYPE (blas_trans_type), INTENT (IN), OPTIONAL :: trans
        END SUBROUTINE sy_acc_s
        SUBROUTINE sy_acc_c(a,b,uplo,trans,alpha,beta)
          USE blas_operator_arguments, ONLY : blas_uplo_type, blas_trans_type
          USE blas_precision, ONLY : wp => sp
          COMPLEX (wp), INTENT (IN) :: a(:,:)
          COMPLEX (wp), INTENT (INOUT) :: b(:,:)
          COMPLEX (wp), INTENT (IN), OPTIONAL :: alpha, beta
          TYPE (blas_uplo_type), INTENT (IN), OPTIONAL :: uplo
          TYPE (blas_trans_type), INTENT (IN), OPTIONAL :: trans
        END SUBROUTINE sy_acc_c
      END INTERFACE

      INTERFACE sb_acc
        ! a and b have shape (k+1,n), k=band width=size(a,1)-1
        SUBROUTINE sb_acc_d(a,b,uplo,trans,alpha,beta)
          USE blas_operator_arguments, ONLY : blas_uplo_type, blas_trans_type
          USE blas_precision, ONLY : wp => dp
          REAL (wp), INTENT (IN) :: a(:,:)
          REAL (wp), INTENT (INOUT) :: b(:,:)
          REAL (wp), INTENT (IN), OPTIONAL :: alpha, beta
          TYPE (blas_uplo_type), INTENT (IN), OPTIONAL :: uplo
          TYPE (blas_trans_type), INTENT (IN), OPTIONAL :: trans
        END SUBROUTINE sb_acc_d
        SUBROUTINE sb_acc_z(a,b,uplo,trans,alpha,beta)
          USE blas_operator_arguments, ONLY : blas_uplo_type, blas_trans_type
          USE blas_precision, ONLY : wp => dp
          COMPLEX (wp), INTENT (IN) :: a(:,:)
          COMPLEX (wp), INTENT (INOUT) :: b(:,:)
          COMPLEX (wp), INTENT (IN), OPTIONAL :: alpha, beta
          TYPE (blas_uplo_type), INTENT (IN), OPTIONAL :: uplo
          TYPE (blas_trans_type), INTENT (IN), OPTIONAL :: trans
        END SUBROUTINE sb_acc_z
        SUBROUTINE sb_acc_s(a,b,uplo,trans,alpha,beta)
          USE blas_operator_arguments, ONLY : blas_uplo_type, blas_trans_type
          USE blas_precision, ONLY : wp => sp
          REAL (wp), INTENT (IN) :: a(:,:)
          REAL (wp), INTENT (INOUT) :: b(:,:)
          REAL (wp), INTENT (IN), OPTIONAL :: alpha, beta
          TYPE (blas_uplo_type), INTENT (IN), OPTIONAL :: uplo
          TYPE (blas_trans_type), INTENT (IN), OPTIONAL :: trans
        END SUBROUTINE sb_acc_s
        SUBROUTINE sb_acc_c(a,b,uplo,trans,alpha,beta)
          USE blas_operator_arguments, ONLY : blas_uplo_type, blas_trans_type
          USE blas_precision, ONLY : wp => sp
          COMPLEX (wp), INTENT (IN) :: a(:,:)
          COMPLEX (wp), INTENT (INOUT) :: b(:,:)
          COMPLEX (wp), INTENT (IN), OPTIONAL :: alpha, beta
          TYPE (blas_uplo_type), INTENT (IN), OPTIONAL :: uplo
          TYPE (blas_trans_type), INTENT (IN), OPTIONAL :: trans
        END SUBROUTINE sb_acc_c
      END INTERFACE

      INTERFACE sp_acc
        ! ap and bp have shape ((n+1)*n/2)
        SUBROUTINE sp_acc_d(ap,bp,uplo,trans,alpha,beta)
          USE blas_operator_arguments, ONLY : blas_uplo_type, blas_trans_type
          USE blas_precision, ONLY : wp => dp
          REAL (wp), INTENT (IN) :: ap(:)
          REAL (wp), INTENT (INOUT) :: bp(:)
          REAL (wp), INTENT (IN), OPTIONAL :: alpha, beta
          TYPE (blas_uplo_type), INTENT (IN), OPTIONAL :: uplo
          TYPE (blas_trans_type), INTENT (IN), OPTIONAL :: trans
        END SUBROUTINE sp_acc_d
        SUBROUTINE sp_acc_z(ap,bp,uplo,trans,alpha,beta)
          USE blas_operator_arguments, ONLY : blas_uplo_type, blas_trans_type
          USE blas_precision, ONLY : wp => dp
          COMPLEX (wp), INTENT (IN) :: ap(:)
          COMPLEX (wp), INTENT (INOUT) :: bp(:)
          COMPLEX (wp), INTENT (IN), OPTIONAL :: alpha, beta
          TYPE (blas_uplo_type), INTENT (IN), OPTIONAL :: uplo
          TYPE (blas_trans_type), INTENT (IN), OPTIONAL :: trans
        END SUBROUTINE sp_acc_z
        SUBROUTINE sp_acc_s(ap,bp,uplo,trans,alpha,beta)
          USE blas_operator_arguments, ONLY : blas_uplo_type, blas_trans_type
          USE blas_precision, ONLY : wp => sp
          REAL (wp), INTENT (IN) :: ap(:)
          REAL (wp), INTENT (INOUT) :: bp(:)
          REAL (wp), INTENT (IN), OPTIONAL :: alpha, beta
          TYPE (blas_uplo_type), INTENT (IN), OPTIONAL :: uplo
          TYPE (blas_trans_type), INTENT (IN), OPTIONAL :: trans
        END SUBROUTINE sp_acc_s
        SUBROUTINE sp_acc_c(ap,bp,uplo,trans,alpha,beta)
          USE blas_operator_arguments, ONLY : blas_uplo_type, blas_trans_type
          USE blas_precision, ONLY : wp => sp
          COMPLEX (wp), INTENT (IN) :: ap(:)
          COMPLEX (wp), INTENT (INOUT) :: bp(:)
          COMPLEX (wp), INTENT (IN), OPTIONAL :: alpha, beta
          TYPE (blas_uplo_type), INTENT (IN), OPTIONAL :: uplo
          TYPE (blas_trans_type), INTENT (IN), OPTIONAL :: trans
        END SUBROUTINE sp_acc_c
      END INTERFACE

      INTERFACE tr_acc
        ! a and b have shape (n,n)
        SUBROUTINE tr_acc_d(a,b,uplo,diag,alpha,beta)
          USE blas_operator_arguments, ONLY : blas_uplo_type, blas_diag_type
          USE blas_precision, ONLY : wp => dp
          REAL (wp), INTENT (IN) :: a(:,:)
          REAL (wp), INTENT (INOUT) :: b(:,:)
          REAL (wp), INTENT (IN), OPTIONAL :: alpha, beta
          TYPE (blas_uplo_type), INTENT (IN), OPTIONAL :: uplo
          TYPE (blas_diag_type), INTENT (IN), OPTIONAL :: diag
        END SUBROUTINE tr_acc_d
        SUBROUTINE tr_acc_z(a,b,uplo,diag,alpha,beta)
          USE blas_operator_arguments, ONLY : blas_uplo_type, blas_diag_type
          USE blas_precision, ONLY : wp => dp
          COMPLEX (wp), INTENT (IN) :: a(:,:)
          COMPLEX (wp), INTENT (INOUT) :: b(:,:)
          COMPLEX (wp), INTENT (IN), OPTIONAL :: alpha, beta
          TYPE (blas_uplo_type), INTENT (IN), OPTIONAL :: uplo
          TYPE (blas_diag_type), INTENT (IN), OPTIONAL :: diag
        END SUBROUTINE tr_acc_z
        SUBROUTINE tr_acc_s(a,b,uplo,diag,alpha,beta)
          USE blas_operator_arguments, ONLY : blas_uplo_type, blas_diag_type
          USE blas_precision, ONLY : wp => sp
          REAL (wp), INTENT (IN) :: a(:,:)
          REAL (wp), INTENT (INOUT) :: b(:,:)
          REAL (wp), INTENT (IN), OPTIONAL :: alpha, beta
          TYPE (blas_uplo_type), INTENT (IN), OPTIONAL :: uplo
          TYPE (blas_diag_type), INTENT (IN), OPTIONAL :: diag
        END SUBROUTINE tr_acc_s
        SUBROUTINE tr_acc_c(a,b,uplo,diag,alpha,beta)
          USE blas_operator_arguments, ONLY : blas_uplo_type, blas_diag_type
          USE blas_precision, ONLY : wp => sp
          COMPLEX (wp), INTENT (IN) :: a(:,:)
          COMPLEX (wp), INTENT (INOUT) :: b(:,:)
          COMPLEX (wp), INTENT (IN), OPTIONAL :: alpha, beta
          TYPE (blas_uplo_type), INTENT (IN), OPTIONAL :: uplo
          TYPE (blas_diag_type), INTENT (IN), OPTIONAL :: diag
        END SUBROUTINE tr_acc_c
      END INTERFACE

      INTERFACE tb_acc
        ! a and b have shape (k+1,n), k=band width=size(a,1)-1
        SUBROUTINE tb_acc_d(a,b,uplo,diag,alpha,beta)
          USE blas_operator_arguments, ONLY : blas_uplo_type, blas_diag_type
          USE blas_precision, ONLY : wp => dp
          REAL (wp), INTENT (IN) :: a(:,:)
          REAL (wp), INTENT (INOUT) :: b(:,:)
          REAL (wp), INTENT (IN), OPTIONAL :: alpha, beta
          TYPE (blas_uplo_type), INTENT (IN), OPTIONAL :: uplo
          TYPE (blas_diag_type), INTENT (IN), OPTIONAL :: diag
        END SUBROUTINE tb_acc_d
        SUBROUTINE tb_acc_z(a,b,uplo,diag,alpha,beta)
          USE blas_operator_arguments, ONLY : blas_uplo_type, blas_diag_type
          USE blas_precision, ONLY : wp => dp
          COMPLEX (wp), INTENT (IN) :: a(:,:)
          COMPLEX (wp), INTENT (INOUT) :: b(:,:)
          COMPLEX (wp), INTENT (IN), OPTIONAL :: alpha, beta
          TYPE (blas_uplo_type), INTENT (IN), OPTIONAL :: uplo
          TYPE (blas_diag_type), INTENT (IN), OPTIONAL :: diag
        END SUBROUTINE tb_acc_z
        SUBROUTINE tb_acc_s(a,b,uplo,diag,alpha,beta)
          USE blas_operator_arguments, ONLY : blas_uplo_type, blas_diag_type
          USE blas_precision, ONLY : wp => sp
          REAL (wp), INTENT (IN) :: a(:,:)
          REAL (wp), INTENT (INOUT) :: b(:,:)
          REAL (wp), INTENT (IN), OPTIONAL :: alpha, beta
          TYPE (blas_uplo_type), INTENT (IN), OPTIONAL :: uplo
          TYPE (blas_diag_type), INTENT (IN), OPTIONAL :: diag
        END SUBROUTINE tb_acc_s
        SUBROUTINE tb_acc_c(a,b,uplo,diag,alpha,beta)
          USE blas_operator_arguments, ONLY : blas_uplo_type, blas_diag_type
          USE blas_precision, ONLY : wp => sp
          COMPLEX (wp), INTENT (IN) :: a(:,:)
          COMPLEX (wp), INTENT (INOUT) :: b(:,:)
          COMPLEX (wp), INTENT (IN), OPTIONAL :: alpha, beta
          TYPE (blas_uplo_type), INTENT (IN), OPTIONAL :: uplo
          TYPE (blas_diag_type), INTENT (IN), OPTIONAL :: diag
        END SUBROUTINE tb_acc_c
      END INTERFACE

      INTERFACE tp_acc
        ! a and b have shape (k+1,n), k=band width=size(a,1)-1
        SUBROUTINE tp_acc_d(ap,bp,uplo,diag,alpha,beta)
          USE blas_operator_arguments, ONLY : blas_uplo_type, blas_diag_type
          USE blas_precision, ONLY : wp => dp
          REAL (wp), INTENT (IN) :: ap(:)
          REAL (wp), INTENT (INOUT) :: bp(:)
          REAL (wp), INTENT (IN), OPTIONAL :: alpha, beta
          TYPE (blas_uplo_type), INTENT (IN), OPTIONAL :: uplo
          TYPE (blas_diag_type), INTENT (IN), OPTIONAL :: diag
        END SUBROUTINE tp_acc_d
        SUBROUTINE tp_acc_z(ap,bp,uplo,diag,alpha,beta)
          USE blas_operator_arguments, ONLY : blas_uplo_type, blas_diag_type
          USE blas_precision, ONLY : wp => dp
          COMPLEX (wp), INTENT (IN) :: ap(:)
          COMPLEX (wp), INTENT (INOUT) :: bp(:)
          COMPLEX (wp), INTENT (IN), OPTIONAL :: alpha, beta
          TYPE (blas_uplo_type), INTENT (IN), OPTIONAL :: uplo
          TYPE (blas_diag_type), INTENT (IN), OPTIONAL :: diag
        END SUBROUTINE tp_acc_z
        SUBROUTINE tp_acc_s(ap,bp,uplo,diag,alpha,beta)
          USE blas_operator_arguments, ONLY : blas_uplo_type, blas_diag_type
          USE blas_precision, ONLY : wp => sp
          REAL (wp), INTENT (IN) :: ap(:)
          REAL (wp), INTENT (INOUT) :: bp(:)
          REAL (wp), INTENT (IN), OPTIONAL :: alpha, beta
          TYPE (blas_uplo_type), INTENT (IN), OPTIONAL :: uplo
          TYPE (blas_diag_type), INTENT (IN), OPTIONAL :: diag
        END SUBROUTINE tp_acc_s
        SUBROUTINE tp_acc_c(ap,bp,uplo,diag,alpha,beta)
          USE blas_operator_arguments, ONLY : blas_uplo_type, blas_diag_type
          USE blas_precision, ONLY : wp => sp
          COMPLEX (wp), INTENT (IN) :: ap(:)
          COMPLEX (wp), INTENT (INOUT) :: bp(:)
          COMPLEX (wp), INTENT (IN), OPTIONAL :: alpha, beta
          TYPE (blas_uplo_type), INTENT (IN), OPTIONAL :: uplo
          TYPE (blas_diag_type), INTENT (IN), OPTIONAL :: diag
        END SUBROUTINE tp_acc_c
      END INTERFACE

      INTERFACE ge_add
        ! a, b and c have shape (m,n)
        SUBROUTINE ge_add_d(a,b,c,alpha,beta)
          USE blas_precision, ONLY : wp => dp
          REAL (wp), INTENT (IN) :: a(:,:), b(:,:)
          REAL (wp), INTENT (OUT) :: c(:,:)
          REAL (wp), INTENT (IN), OPTIONAL :: alpha, beta
        END SUBROUTINE ge_add_d
        SUBROUTINE ge_add_z(a,b,c,alpha,beta)
          USE blas_precision, ONLY : wp => dp
          COMPLEX (wp), INTENT (IN) :: a(:,:), b(:,:)
          COMPLEX (wp), INTENT (OUT) :: c(:,:)
          COMPLEX (wp), INTENT (IN), OPTIONAL :: alpha, beta
        END SUBROUTINE ge_add_z
        SUBROUTINE ge_add_s(a,b,c,alpha,beta)
          USE blas_precision, ONLY : wp => sp
          REAL (wp), INTENT (IN) :: a(:,:), b(:,:)
          REAL (wp), INTENT (OUT) :: c(:,:)
          REAL (wp), INTENT (IN), OPTIONAL :: alpha, beta
        END SUBROUTINE ge_add_s
        SUBROUTINE ge_add_c(a,b,c,alpha,beta)
          USE blas_precision, ONLY : wp => sp
          COMPLEX (wp), INTENT (IN) :: a(:,:), b(:,:)
          COMPLEX (wp), INTENT (OUT) :: c(:,:)
          COMPLEX (wp), INTENT (IN), OPTIONAL :: alpha, beta
        END SUBROUTINE ge_add_c
      END INTERFACE

      INTERFACE gb_add
        ! a, b and c have shape (kl+ku+1,n), ku=SIZE(a,1)-1-kl
        SUBROUTINE gb_add_d(a,m,kl,b,c,alpha,beta)
          USE blas_precision, ONLY : wp => dp
          REAL (wp), INTENT (IN) :: a(:,:), b(:,:)
          INTEGER, INTENT (IN) :: m, kl
          REAL (wp), INTENT (OUT) :: c(:,:)
          REAL (wp), INTENT (IN), OPTIONAL :: alpha, beta
        END SUBROUTINE gb_add_d
        SUBROUTINE gb_add_z(a,m,kl,b,c,alpha,beta)
          USE blas_precision, ONLY : wp => dp
          COMPLEX (wp), INTENT (IN) :: a(:,:), b(:,:)
          INTEGER, INTENT (IN) :: m, kl
          COMPLEX (wp), INTENT (OUT) :: c(:,:)
          COMPLEX (wp), INTENT (IN), OPTIONAL :: alpha, beta
        END SUBROUTINE gb_add_z
        SUBROUTINE gb_add_s(a,m,kl,b,c,alpha,beta)
          USE blas_precision, ONLY : wp => sp
          REAL (wp), INTENT (IN) :: a(:,:), b(:,:)
          INTEGER, INTENT (IN) :: m, kl
          REAL (wp), INTENT (OUT) :: c(:,:)
          REAL (wp), INTENT (IN), OPTIONAL :: alpha, beta
        END SUBROUTINE gb_add_s
        SUBROUTINE gb_add_c(a,m,kl,b,c,alpha,beta)
          USE blas_precision, ONLY : wp => sp
          COMPLEX (wp), INTENT (IN) :: a(:,:), b(:,:)
          INTEGER, INTENT (IN) :: m, kl
          COMPLEX (wp), INTENT (OUT) :: c(:,:)
          COMPLEX (wp), INTENT (IN), OPTIONAL :: alpha, beta
        END SUBROUTINE gb_add_c
      END INTERFACE

      INTERFACE sy_add
        ! a, b and c have shape (n,n)
        SUBROUTINE sy_add_d(a,b,c,uplo,alpha,beta)
          USE blas_operator_arguments, ONLY : blas_uplo_type
          USE blas_precision, ONLY : wp => dp
          REAL (wp), INTENT (IN) :: a(:,:), b(:,:)
          REAL (wp), INTENT (OUT) :: c(:,:)
          REAL (wp), INTENT (IN), OPTIONAL :: alpha, beta
          TYPE (blas_uplo_type), INTENT (IN), OPTIONAL :: uplo
        END SUBROUTINE sy_add_d
        SUBROUTINE sy_add_z(a,b,c,uplo,alpha,beta)
          USE blas_operator_arguments, ONLY : blas_uplo_type
          USE blas_precision, ONLY : wp => dp
          COMPLEX (wp), INTENT (IN) :: a(:,:), b(:,:)
          COMPLEX (wp), INTENT (OUT) :: c(:,:)
          COMPLEX (wp), INTENT (IN), OPTIONAL :: alpha, beta
          TYPE (blas_uplo_type), INTENT (IN), OPTIONAL :: uplo
        END SUBROUTINE sy_add_z
        SUBROUTINE sy_add_s(a,b,c,uplo,alpha,beta)
          USE blas_operator_arguments, ONLY : blas_uplo_type
          USE blas_precision, ONLY : wp => sp
          REAL (wp), INTENT (IN) :: a(:,:), b(:,:)
          REAL (wp), INTENT (OUT) :: c(:,:)
          REAL (wp), INTENT (IN), OPTIONAL :: alpha, beta
          TYPE (blas_uplo_type), INTENT (IN), OPTIONAL :: uplo
        END SUBROUTINE sy_add_s
        SUBROUTINE sy_add_c(a,b,c,uplo,alpha,beta)
          USE blas_operator_arguments, ONLY : blas_uplo_type
          USE blas_precision, ONLY : wp => sp
          COMPLEX (wp), INTENT (IN) :: a(:,:), b(:,:)
          COMPLEX (wp), INTENT (OUT) :: c(:,:)
          COMPLEX (wp), INTENT (IN), OPTIONAL :: alpha, beta
          TYPE (blas_uplo_type), INTENT (IN), OPTIONAL :: uplo
        END SUBROUTINE sy_add_c
      END INTERFACE

      INTERFACE sb_add
        ! a, b and c have shape (k+1,n), k=band width=size(a,1)-1
        SUBROUTINE sb_add_d(a,b,c,uplo,alpha,beta)
          USE blas_operator_arguments, ONLY : blas_uplo_type
          USE blas_precision, ONLY : wp => dp
          REAL (wp), INTENT (IN) :: a(:,:), b(:,:)
          REAL (wp), INTENT (OUT) :: c(:,:)
          REAL (wp), INTENT (IN), OPTIONAL :: alpha, beta
          TYPE (blas_uplo_type), INTENT (IN), OPTIONAL :: uplo
        END SUBROUTINE sb_add_d
        SUBROUTINE sb_add_z(a,b,c,uplo,alpha,beta)
          USE blas_operator_arguments, ONLY : blas_uplo_type
          USE blas_precision, ONLY : wp => dp
          COMPLEX (wp), INTENT (IN) :: a(:,:), b(:,:)
          COMPLEX (wp), INTENT (OUT) :: c(:,:)
          COMPLEX (wp), INTENT (IN), OPTIONAL :: alpha, beta
          TYPE (blas_uplo_type), INTENT (IN), OPTIONAL :: uplo
        END SUBROUTINE sb_add_z
        SUBROUTINE sb_add_s(a,b,c,uplo,alpha,beta)
          USE blas_operator_arguments, ONLY : blas_uplo_type
          USE blas_precision, ONLY : wp => sp
          REAL (wp), INTENT (IN) :: a(:,:), b(:,:)
          REAL (wp), INTENT (OUT) :: c(:,:)
          REAL (wp), INTENT (IN), OPTIONAL :: alpha, beta
          TYPE (blas_uplo_type), INTENT (IN), OPTIONAL :: uplo
        END SUBROUTINE sb_add_s
        SUBROUTINE sb_add_c(a,b,c,uplo,alpha,beta)
          USE blas_operator_arguments, ONLY : blas_uplo_type
          USE blas_precision, ONLY : wp => sp
          COMPLEX (wp), INTENT (IN) :: a(:,:), b(:,:)
          COMPLEX (wp), INTENT (OUT) :: c(:,:)
          COMPLEX (wp), INTENT (IN), OPTIONAL :: alpha, beta
          TYPE (blas_uplo_type), INTENT (IN), OPTIONAL :: uplo
        END SUBROUTINE sb_add_c
      END INTERFACE

      INTERFACE sp_add
        ! ap, bp and cp have shape ((n+1)*n/2)
        SUBROUTINE sp_add_d(ap,bp,cp,uplo,alpha,beta)
          USE blas_operator_arguments, ONLY : blas_uplo_type
          USE blas_precision, ONLY : wp => dp
          REAL (wp), INTENT (IN) :: ap(:), bp(:)
          REAL (wp), INTENT (OUT) :: cp(:)
          REAL (wp), INTENT (IN), OPTIONAL :: alpha, beta
          TYPE (blas_uplo_type), INTENT (IN), OPTIONAL :: uplo
        END SUBROUTINE sp_add_d
        SUBROUTINE sp_add_z(ap,bp,cp,uplo,alpha,beta)
          USE blas_operator_arguments, ONLY : blas_uplo_type
          USE blas_precision, ONLY : wp => dp
          COMPLEX (wp), INTENT (IN) :: ap(:), bp(:)
          COMPLEX (wp), INTENT (OUT) :: cp(:)
          COMPLEX (wp), INTENT (IN), OPTIONAL :: alpha, beta
          TYPE (blas_uplo_type), INTENT (IN), OPTIONAL :: uplo
        END SUBROUTINE sp_add_z
        SUBROUTINE sp_add_s(ap,bp,cp,uplo,alpha,beta)
          USE blas_operator_arguments, ONLY : blas_uplo_type
          USE blas_precision, ONLY : wp => sp
          REAL (wp), INTENT (IN) :: ap(:), bp(:)
          REAL (wp), INTENT (OUT) :: cp(:)
          REAL (wp), INTENT (IN), OPTIONAL :: alpha, beta
          TYPE (blas_uplo_type), INTENT (IN), OPTIONAL :: uplo
        END SUBROUTINE sp_add_s
        SUBROUTINE sp_add_c(ap,bp,cp,uplo,alpha,beta)
          USE blas_operator_arguments, ONLY : blas_uplo_type
          USE blas_precision, ONLY : wp => sp
          COMPLEX (wp), INTENT (IN) :: ap(:), bp(:)
          COMPLEX (wp), INTENT (OUT) :: cp(:)
          COMPLEX (wp), INTENT (IN), OPTIONAL :: alpha, beta
          TYPE (blas_uplo_type), INTENT (IN), OPTIONAL :: uplo
        END SUBROUTINE sp_add_c
      END INTERFACE

      INTERFACE tr_add
        ! a, b and c have shape (n,n)
        SUBROUTINE tr_add_d(a,b,c,uplo,diag,alpha,beta)
          USE blas_operator_arguments, ONLY : blas_uplo_type, blas_diag_type
          USE blas_precision, ONLY : wp => dp
          REAL (wp), INTENT (IN) :: a(:,:), b(:,:)
          REAL (wp), INTENT (OUT) :: c(:,:)
          REAL (wp), INTENT (IN), OPTIONAL :: alpha, beta
          TYPE (blas_uplo_type), INTENT (IN), OPTIONAL :: uplo
          TYPE (blas_diag_type), INTENT (IN), OPTIONAL :: diag
        END SUBROUTINE tr_add_d
        SUBROUTINE tr_add_z(a,b,c,uplo,diag,alpha,beta)
          USE blas_operator_arguments, ONLY : blas_uplo_type, blas_diag_type
          USE blas_precision, ONLY : wp => dp
          COMPLEX (wp), INTENT (IN) :: a(:,:), b(:,:)
          COMPLEX (wp), INTENT (OUT) :: c(:,:)
          COMPLEX (wp), INTENT (IN), OPTIONAL :: alpha, beta
          TYPE (blas_uplo_type), INTENT (IN), OPTIONAL :: uplo
          TYPE (blas_diag_type), INTENT (IN), OPTIONAL :: diag
        END SUBROUTINE tr_add_z
        SUBROUTINE tr_add_s(a,b,c,uplo,diag,alpha,beta)
          USE blas_operator_arguments, ONLY : blas_uplo_type, blas_diag_type
          USE blas_precision, ONLY : wp => sp
          REAL (wp), INTENT (IN) :: a(:,:), b(:,:)
          REAL (wp), INTENT (OUT) :: c(:,:)
          REAL (wp), INTENT (IN), OPTIONAL :: alpha, beta
          TYPE (blas_uplo_type), INTENT (IN), OPTIONAL :: uplo
          TYPE (blas_diag_type), INTENT (IN), OPTIONAL :: diag
        END SUBROUTINE tr_add_s
        SUBROUTINE tr_add_c(a,b,c,uplo,diag,alpha,beta)
          USE blas_operator_arguments, ONLY : blas_uplo_type, blas_diag_type
          USE blas_precision, ONLY : wp => sp
          COMPLEX (wp), INTENT (IN) :: a(:,:), b(:,:)
          COMPLEX (wp), INTENT (OUT) :: c(:,:)
          COMPLEX (wp), INTENT (IN), OPTIONAL :: alpha, beta
          TYPE (blas_uplo_type), INTENT (IN), OPTIONAL :: uplo
          TYPE (blas_diag_type), INTENT (IN), OPTIONAL :: diag
        END SUBROUTINE tr_add_c
      END INTERFACE

      INTERFACE tb_add
        ! a, b and c have shape (k+1,n), k=band width=size(a,1)-1
        SUBROUTINE tb_add_d(a,b,c,uplo,diag,alpha,beta)
          USE blas_operator_arguments, ONLY : blas_uplo_type, blas_diag_type
          USE blas_precision, ONLY : wp => dp
          REAL (wp), INTENT (IN) :: a(:,:), b(:,:)
          REAL (wp), INTENT (OUT) :: c(:,:)
          REAL (wp), INTENT (IN), OPTIONAL :: alpha, beta
          TYPE (blas_uplo_type), INTENT (IN), OPTIONAL :: uplo
          TYPE (blas_diag_type), INTENT (IN), OPTIONAL :: diag
        END SUBROUTINE tb_add_d
        SUBROUTINE tb_add_z(a,b,c,uplo,diag,alpha,beta)
          USE blas_operator_arguments, ONLY : blas_uplo_type, blas_diag_type
          USE blas_precision, ONLY : wp => dp
          COMPLEX (wp), INTENT (IN) :: a(:,:), b(:,:)
          COMPLEX (wp), INTENT (OUT) :: c(:,:)
          COMPLEX (wp), INTENT (IN), OPTIONAL :: alpha, beta
          TYPE (blas_uplo_type), INTENT (IN), OPTIONAL :: uplo
          TYPE (blas_diag_type), INTENT (IN), OPTIONAL :: diag
        END SUBROUTINE tb_add_z
        SUBROUTINE tb_add_s(a,b,c,uplo,diag,alpha,beta)
          USE blas_operator_arguments, ONLY : blas_uplo_type, blas_diag_type
          USE blas_precision, ONLY : wp => sp
          REAL (wp), INTENT (IN) :: a(:,:), b(:,:)
          REAL (wp), INTENT (OUT) :: c(:,:)
          REAL (wp), INTENT (IN), OPTIONAL :: alpha, beta
          TYPE (blas_uplo_type), INTENT (IN), OPTIONAL :: uplo
          TYPE (blas_diag_type), INTENT (IN), OPTIONAL :: diag
        END SUBROUTINE tb_add_s
        SUBROUTINE tb_add_c(a,b,c,uplo,diag,alpha,beta)
          USE blas_operator_arguments, ONLY : blas_uplo_type, blas_diag_type
          USE blas_precision, ONLY : wp => sp
          COMPLEX (wp), INTENT (IN) :: a(:,:), b(:,:)
          COMPLEX (wp), INTENT (OUT) :: c(:,:)
          COMPLEX (wp), INTENT (IN), OPTIONAL :: alpha, beta
          TYPE (blas_uplo_type), INTENT (IN), OPTIONAL :: uplo
          TYPE (blas_diag_type), INTENT (IN), OPTIONAL :: diag
        END SUBROUTINE tb_add_c
      END INTERFACE

      INTERFACE tp_add
        ! ap, bp and cp have shape ((n+1)*n/2)
        SUBROUTINE tp_add_d(ap,bp,cp,uplo,diag,alpha,beta)
          USE blas_operator_arguments, ONLY : blas_uplo_type, blas_diag_type
          USE blas_precision, ONLY : wp => dp
          REAL (wp), INTENT (IN) :: ap(:), bp(:)
          REAL (wp), INTENT (OUT) :: cp(:)
          REAL (wp), INTENT (IN), OPTIONAL :: alpha, beta
          TYPE (blas_uplo_type), INTENT (IN), OPTIONAL :: uplo
          TYPE (blas_diag_type), INTENT (IN), OPTIONAL :: diag
        END SUBROUTINE tp_add_d
        SUBROUTINE tp_add_z(ap,bp,cp,uplo,diag,alpha,beta)
          USE blas_operator_arguments, ONLY : blas_uplo_type, blas_diag_type
          USE blas_precision, ONLY : wp => dp
          COMPLEX (wp), INTENT (IN) :: ap(:), bp(:)
          COMPLEX (wp), INTENT (OUT) :: cp(:)
          COMPLEX (wp), INTENT (IN), OPTIONAL :: alpha, beta
          TYPE (blas_uplo_type), INTENT (IN), OPTIONAL :: uplo
          TYPE (blas_diag_type), INTENT (IN), OPTIONAL :: diag
        END SUBROUTINE tp_add_z
        SUBROUTINE tp_add_s(ap,bp,cp,uplo,diag,alpha,beta)
          USE blas_operator_arguments, ONLY : blas_uplo_type, blas_diag_type
          USE blas_precision, ONLY : wp => sp
          REAL (wp), INTENT (IN) :: ap(:), bp(:)
          REAL (wp), INTENT (OUT) :: cp(:)
          REAL (wp), INTENT (IN), OPTIONAL :: alpha, beta
          TYPE (blas_uplo_type), INTENT (IN), OPTIONAL :: uplo
          TYPE (blas_diag_type), INTENT (IN), OPTIONAL :: diag
        END SUBROUTINE tp_add_s
        SUBROUTINE tp_add_c(ap,bp,cp,uplo,diag,alpha,beta)
          USE blas_operator_arguments, ONLY : blas_uplo_type, blas_diag_type
          USE blas_precision, ONLY : wp => sp
          COMPLEX (wp), INTENT (IN) :: ap(:), bp(:)
          COMPLEX (wp), INTENT (OUT) :: cp(:)
          COMPLEX (wp), INTENT (IN), OPTIONAL :: alpha, beta
          TYPE (blas_uplo_type), INTENT (IN), OPTIONAL :: uplo
          TYPE (blas_diag_type), INTENT (IN), OPTIONAL :: diag
        END SUBROUTINE tp_add_c
      END INTERFACE
    END MODULE blas_dense_mat_op


program ballistic_current
  implicit none
  real, parameter :: pi=3.141592654           ! pi
  real, parameter :: ec=1.602176634e-19       ! electron elementary charge
  real, parameter :: kB=1.380649000e-23       ! Boltzmann constant
  real, parameter :: hbar=1.054571818e-34     ! Planck constant
  real, parameter :: epszero=8.85418781e-12   ! Vacuum permittivity
  real, parameter :: mzero=9.10938370e-31     ! electron mass
  real, parameter :: epsox=3.9*epszero        ! oxide insulator permittivity
  real, parameter :: epssi=11.8*epszero       ! silicon channel permittivity
  real, parameter :: mt=0.191*mzero           ! transverse effective mass of electron
  real, parameter :: ml=0.916*mzero           ! longitudinal effective mass of electron
  real, parameter :: mr=2/(1/ml+1/mt)         ! effective mass along radius direction in the cross section
  real, parameter :: gatewkfunc=4.5           ! workfunction of gate material
  real, parameter :: chelecaffi=4.17          ! electron affinity of channel material
  real, parameter :: wgc=gatewkfunc-chelecaffi! workfunction difference between gate and channel
  real, parameter :: vbi=0.23                 ! built-in voltage between the source-channel junction
  real, parameter :: T=300                    ! absolute room temperature
  real, parameter :: vt=kB*T/ec               ! thermal voltage
  real, parameter :: nm=1e-9                  ! nanometer
  real, parameter :: tox=0.5*nm               ! oxide thickness

  real, parameter :: R=2*nm                   ! channel radius
  !real, parameter :: Lg=15*nm                ! channel length

  real :: vgs, vds                            ! gate-source voltage, drain-source voltage,
  real :: ids                                 ! drain-source current
  real :: energlvl                            ! energy level of an electron

end program ballistic_current


Real Function rmass(dmax, iseed)
  Common /rndf77/nseed
  Save
  dmin = 1.078
  If (dmax<1.232) Then
     fm = fdelta(dmax)
  Else
     fm = 1.
  End If
  If (fm==0.) fm = 1.E-06
  ntry1 = 0
10 dm = ranart(nseed)*(dmax-dmin) + dmin
  ntry1 = ntry1 + 1
  If ((ranart(nseed)>fdelta(dm)/fm) .And. (ntry1<=10)) Goto 10
  If (dm>1.47) Goto 10
  rmass = dm
  Return
End Function rmass