!    Copyright (C) 2012 The SPEED FOUNDATION
!    Author: Ilario Mazzieri
!
!    This file is part of SPEED.
!
!    SPEED is free software; you can redistribute it and/or modify it
!    under the terms of the GNU Affero General Public License as
!    published by the Free Software Foundation, either version 3 of the
!    License, or (at your option) any later version.
!
!    SPEED is distributed in the hope that it will be useful, but
!    WITHOUT ANY WARRANTY; without even the implied warranty of
!    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
!    Affero General Public License for more details.
!
!    You should have received a copy of the GNU Affero General Public License
!    along with SPEED.  If not, see <http://www.gnu.org/licenses/>.

!> @brief Computes DG matrices for jumps.
!! @author Ilario Mazzieri
!> @date September, 2013
!> @version 1.0
!> @param[in] x_pl  x-coord of Gauss Legendre node for the integration in Omega+
!> @param[in] y_pl  y-coord of Gauss Legendre node for the integration in Omega+
!> @param[in] z_pl  z-coord of Gauss Legendre node for the integration in Omega+
!> @param[in] wx_pl Gauss Legendre weight
!> @param[in] wy_pl Gauss Legendre weight
!> @param[in] wz_pl Gauss Legendre weight
!> @param[in] x_mn  x-coord. of Gauss Legendre nodes for the integration in Omega-
!> @param[in] y_mn  y-coord. of Gauss Legendre nodes for the integration in Omega-
!> @param[in] z_mn  z-coord. of Gauss Legendre nodes for the integration in Omega-
!> @param[in] nq  number of quadrature pints
!> @param[in] nn  polynomial degree in Omega+
!> @param[in] mm  polynomial degree in Omega-
!> @param[in] o_minus  matrix containing info about Omega- o_minus(0,i) = material,
!!            o_minus(1,i) = el index, o_minus(2,i) = face, o_minus(3,1) = neighbouring element in
!!            a local numeration
!> @param[in] alfa11 costant values for the bilinear map of Omega+
!> @param[in] alfa12 costant values for the bilinear map of Omega+
!> @param[in] alfa13 costant values for the bilinear map of Omega+
!> @param[in] alfa21 costant values for the bilinear map of Omega+
!> @param[in] alfa22 costant values for the bilinear map of Omega+
!> @param[in] alfa23 costant values for the bilinear map of Omega+
!> @param[in] alfa31 costant values for the bilinear map of Omega+
!> @param[in] alfa32 costant values for the bilinear map of Omega+
!> @param[in] alfa33 costant values for the bilinear map of Omega+
!> @param[in] beta11 costant values for the bilinear map of Omega+
!> @param[in] beta12 costant values for the bilinear map of Omega+
!> @param[in] beta13 costant values for the bilinear map of Omega+
!> @param[in] beta21 costant values for the bilinear map of Omega+
!> @param[in] beta22 costant values for the bilinear map of Omega+
!> @param[in] beta23 costant values for the bilinear map of Omega+
!> @param[in] beta31 costant values for the bilinear map of Omega+
!> @param[in] beta32 costant values for the bilinear map of Omega+
!> @param[in] beta33 costant values for the bilinear map of Omega+
!> @param[in] gamma1 costant values for the bilinear map of Omega+
!> @param[in] gamma2 costant values for the bilinear map of Omega+
!> @param[in] gamma3 costant values for the bilinear map of Omega+
!> @param[in] delta1 costant values for the bilinear map of Omega+
!> @param[in] delta2 costant values for the bilinear map of Omega+
!> @param[in] delta3 costant values for the bilinear map of Omega+
!> @param[in] ine index for neighbouring element
!> @param[in] alfa11_mn costant values for the bilinear map of Omega-
!> @param[in] alfa12_mn costant values for the bilinear map of Omega-
!> @param[in] alfa13_mn costant values for the bilinear map of Omega-
!> @param[in] alfa21_mn costant values for the bilinear map of Omega-
!> @param[in] alfa22_mn costant values for the bilinear map of Omega-
!> @param[in] alfa23_mn costant values for the bilinear map of Omega-
!> @param[in] alfa31_mn costant values for the bilinear map of Omega-
!> @param[in] alfa32_mn costant values for the bilinear map of Omega-
!> @param[in] alfa33_mn costant values for the bilinear map of Omega-
!> @param[in] beta11_mn costant values for the bilinear map of Omega-
!> @param[in] beta12_mn costant values for the bilinear map of Omega-
!> @param[in] beta13_mn costant values for the bilinear map of Omega-
!> @param[in] beta21_mn costant values for the bilinear map of Omega-
!> @param[in] beta22_mn costant values for the bilinear map of Omega-
!> @param[in] beta23_mn costant values for the bilinear map of Omega-
!> @param[in] beta31_mn costant values for the bilinear map of Omega-
!> @param[in] beta32_mn costant values for the bilinear map of Omega-
!> @param[in] beta33_mn costant values for the bilinear map of Omega-
!> @param[in] gamma1_mn costant values for the bilinear map of Omega-
!> @param[in] gamma2_mn costant values for the bilinear map of Omega-
!> @param[in] gamma3_mn costant values for the bilinear map of Omega-
!> @param[in] delta1_mn costant values for the bilinear map of Omega-
!> @param[in] delta2_mn costant values for the bilinear map of Omega-
!> @param[in] delta3_mn costant values for the bilinear map of Omega-
!> @param[in] cp_a constant appearing in the interface integrals
!> @param[in] cp_b constant appearing in the interface integrals
!> @param[in] cp_c constant appearing in the interface integrals
!> @param[in] cp_d constant appearing in the interface integrals
!> @param[in] cp_e constant appearing in the interface integrals
!> @param[in] cp_f constant appearing in the interface integrals
!> @param[in] cp_g constant appearing in the interface integrals
!> @param[in] cp_n constant appearing in the interface integrals
!> @param[in] cp_p constant appearing in the interface integrals
!> @param[in] pen  penalty constant
!> @param[in] dg_cnst  -1 SIPG, 0 IIPG, 1 NIPG
!> @param[in] id_mpi  mpi process identity
!> @param[in] det_scal  determinant of the transformation used for computing interface integrals
!> @param[in] testmode 1 if testmode is active
!> @param[out] JP  jump matrix for the part +,+
!> @param[out] JM  jump matrix for the part +,-
!> @param[out] JP_uv  jump matrix for the part +,+ for testmode case
!> @param[out] JM_uv  jump matrix for the part +,- for testmode case

      subroutine MAKE_LOC_MATRIX_DG(x_pl, y_pl, z_pl, &
                       wx_pl,wy_pl, wz_pl,&
                       x_mn, y_mn, z_mn, &
                       nq, nn, mm, &
                       o_minus, &
                       alfa11,alfa12,alfa13,&
                       alfa21,alfa22,alfa23,&
                       alfa31,alfa32,alfa33,&
                       beta11,beta12,beta13,&
                       beta21,beta22,beta23,&
                       beta31,beta32,beta33,&
                       gamma1,gamma2,gamma3,&
                       delta1,delta2,delta3,&
                       ine,&
                       alfa11_mn,alfa12_mn,alfa13_mn,&
                       alfa21_mn,alfa22_mn,alfa23_mn,&
                       alfa31_mn,alfa32_mn,alfa33_mn,&
                       beta11_mn,beta12_mn,beta13_mn,&
                       beta21_mn,beta22_mn,beta23_mn,&
                       beta31_mn,beta32_mn,beta33_mn,&
                       gamma1_mn,gamma2_mn,gamma3_mn,&
                       delta1_mn,delta2_mn,delta3_mn,&
                       cp_a,cp_b,cp_c,cp_d,cp_e,cp_f,cp_g,cp_n,cp_p, &
                       pen, dg_cnst,JP,JM,id_mpi,det_scal, testmode,&
                       JP_uv, JM_uv)

     use max_var
     use str_mesh

     implicit none

     integer*4 :: i, id_mpi, testmode
     integer*4 :: ip1 , i1, j1, h1, m1, n1, p1, L1, K1
     integer*4 :: ip2 , i2, j2, h2, m2, n2, p2, L2, K2
     integer*4 :: ip3 , i3, j3, h3, m3, n3, p3, L3, K3
     !integer*4 :: nthreads,  OMP_GET_NUM_THREADS

     integer*4, intent(in) :: nn, nq, mm, ine

     integer*4, dimension(1:nq,0:3), intent(in) :: o_minus

     real*8 :: phi, dphi
     real*8 :: dxdx1,dxdy1,dxdz1,dydx1,dydy1,dydz1,dzdx1,dzdy1,dzdz1,det_j1, det_s1
     real*8 :: dxdx2,dxdy2,dxdz2,dydx2,dydy2,dydz2,dzdx2,dzdy2,dzdz2,det_j2, det_s2
     real*8 :: dxdx3,dxdy3,dxdz3,dydx3,dydy3,dydz3,dzdx3,dzdy3,dzdz3,det_j3, det_s3
     real*8 :: dxdu1, dydu1, dzdu1, dxdv1, dydv1, dzdv1
     real*8 :: dxdu2, dydu2, dzdu2, dxdv2, dydv2, dzdv2
     real*8 :: dxdu3, dydu3, dzdu3, dxdv3, dydv3, dzdv3
     real*8 :: dxdx_m,dxdy_m,dxdz_m,dydx_m,dydy_m,dydz_m,dzdx_m,dzdy_m,dzdz_m,det_j_m
     real*8 :: dpdc1, dpde1, dpdz1, dpdx1, dpdy1, dpdzt1, plx1, pkx1
     real*8 :: dpdc2, dpde2, dpdz2, dpdx2, dpdy2, dpdzt2, plx2, pkx2
     real*8 :: dpdc3, dpde3, dpdz3, dpdx3, dpdy3, dpdzt3, plx3, pkx3
     real*8 :: tempo1, tempo2

     real*8, intent(in) :: alfa11, alfa12, alfa13, alfa21, alfa22, alfa23, alfa31, alfa32, alfa33
     real*8, intent(in) :: beta11, beta12, beta13, beta21, beta22, beta23, beta31, beta32, beta33
     real*8, intent(in) :: gamma1, gamma2, gamma3, delta1, delta2, delta3
     real*8, intent(in) :: alfa11_mn, alfa12_mn, alfa13_mn
     real*8, intent(in) :: alfa21_mn, alfa22_mn, alfa23_mn
     real*8, intent(in) :: alfa31_mn, alfa32_mn, alfa33_mn
     real*8, intent(in) :: beta11_mn, beta12_mn, beta13_mn
     real*8, intent(in) :: beta21_mn, beta22_mn, beta23_mn
     real*8, intent(in) :: beta31_mn, beta32_mn, beta33_mn
     real*8, intent(in) :: gamma1_mn, gamma2_mn, gamma3_mn
     real*8, intent(in) :: delta1_mn, delta2_mn, delta3_mn
     real*8, intent(in) :: cp_a, cp_b, cp_c, cp_d, cp_e, cp_f, cp_g, cp_n, cp_p
     real*8, intent(in) :: pen, dg_cnst, det_scal
     real*8, dimension(nq), intent(in) :: x_pl, y_pl, z_pl, wx_pl, wy_pl, wz_pl, x_mn, y_mn, z_mn
     real*8, dimension(nn) :: ctp
     real*8, dimension(mm) :: ctm

     real*8, dimension(:,:), allocatable :: DD,EE,FF,GG,HH,II,QQ
     real*8, dimension(:,:), allocatable :: AA,BB,CC,PP
     real*8, dimension(3*nn**3,3*nn**3), intent(out)  :: JP, JP_uv
     real*8, dimension(3*nn**3,3*mm**3), intent(out)  :: JM, JM_uv

    call MAKE_LGL_NODES(nn,ctp)
    call MAKE_LGL_NODES(mm,ctm)

!********************************************************************************************!
!   MATRICES (+,+)                                                                           !
!********************************************************************************************!

  allocate(AA(nn**3,nn**3),BB(nn**3,nn**3),CC(nn**3,nn**3),PP(nn**3,nn**3))

    AA = 0.d0
    BB = 0.d0
    CC = 0.d0
    PP = 0.d0

    allocate(DD(nn**3,mm**3),EE(nn**3,mm**3),FF(nn**3,mm**3),QQ(nn**3,mm**3))

    DD = 0.d0
    EE = 0.d0
    FF = 0.d0
    QQ = 0.d0

    allocate(GG(nn**3,mm**3),HH(nn**3,mm**3),II(nn**3,mm**3))
    GG = 0.d0
    HH = 0.d0
    II = 0.d0

!!$OMP PARALLEL
!!$OMP SECTIONS

!!$OMP SECTION

     do p1 = 1, nn
        do n1 = 1, nn
          do m1 = 1, nn
             L1 = m1 + (n1-1)*nn + (p1-1)*nn*nn

             do h1 = 1, nn
                do j1 = 1, nn
                   do i1 = 1, nn
                      K1 = i1 + (j1-1)*nn + (h1-1)*nn*nn

                      do  ip1 = 1, nq

                          if( o_minus(ip1,1) .eq. ine) then

               dxdx1 = alfa11 + beta12*z_pl(ip1) + beta13*y_pl(ip1) + gamma1*y_pl(ip1)*z_pl(ip1)
               dydx1 = alfa21 + beta22*z_pl(ip1) + beta23*y_pl(ip1) + gamma2*y_pl(ip1)*z_pl(ip1)
               dzdx1 = alfa31 + beta32*z_pl(ip1) + beta33*y_pl(ip1) + gamma3*y_pl(ip1)*z_pl(ip1)

               dxdy1 = alfa12 + beta11*z_pl(ip1) + beta13*x_pl(ip1) + gamma1*z_pl(ip1)*x_pl(ip1)
               dydy1 = alfa22 + beta21*z_pl(ip1) + beta23*x_pl(ip1) + gamma2*z_pl(ip1)*x_pl(ip1)
               dzdy1 = alfa32 + beta31*z_pl(ip1) + beta33*x_pl(ip1) + gamma3*z_pl(ip1)*x_pl(ip1)

               dxdz1 = alfa13 + beta11*y_pl(ip1) + beta12*x_pl(ip1) + gamma1*x_pl(ip1)*y_pl(ip1)
               dydz1 = alfa23 + beta21*y_pl(ip1) + beta22*x_pl(ip1) + gamma2*x_pl(ip1)*y_pl(ip1)
               dzdz1 = alfa33 + beta31*y_pl(ip1) + beta32*x_pl(ip1) + gamma3*x_pl(ip1)*y_pl(ip1)

               det_j1 = dxdz1 * (dydx1*dzdy1 - dzdx1*dydy1) &
                     - dydz1 * (dxdx1*dzdy1 - dzdx1*dxdy1) &
                     + dzdz1 * (dxdx1*dydy1 - dydx1*dxdy1)

              dpdc1 = dphi(nn-1, ctp(i1), x_pl(ip1)) * phi(nn-1, ctp(j1), y_pl(ip1)) * phi(nn-1, ctp(h1), z_pl(ip1))
              dpde1 = phi(nn-1, ctp(i1), x_pl(ip1)) * dphi(nn-1, ctp(j1), y_pl(ip1)) * phi(nn-1, ctp(h1), z_pl(ip1))
              dpdz1 = phi(nn-1, ctp(i1), x_pl(ip1)) * phi(nn-1, ctp(j1), y_pl(ip1)) * dphi(nn-1, ctp(h1), z_pl(ip1))

                plx1 = phi(nn-1, ctp(m1), x_pl(ip1)) * phi(nn-1, ctp(n1), y_pl(ip1)) * phi(nn-1, ctp(p1), z_pl(ip1))
                pkx1 = phi(nn-1, ctp(i1), x_pl(ip1)) * phi(nn-1, ctp(j1), y_pl(ip1)) * phi(nn-1, ctp(h1), z_pl(ip1))

              dpdx1 = (dydx1*(dzdy1*dpdz1 - dzdz1*dpde1) - dydy1*(dzdx1*dpdz1 - dzdz1*dpdc1) + &
                       dydz1*(dzdx1*dpde1 - dzdy1*dpdc1))/det_j1

              dpdy1 = (dzdx1*(dxdy1*dpdz1 - dxdz1*dpde1) - dzdy1*(dxdx1*dpdz1 - dxdz1*dpdc1) + &
                      dzdz1*(dxdx1*dpde1 - dxdy1*dpdc1))/det_j1

             dpdzt1 = (dxdx1*(dydy1*dpdz1 - dydz1*dpde1) - dxdy1*(dydx1*dpdz1 - dydz1*dpdc1) +  &
                      dxdz1*(dydx1*dpde1 - dydy1*dpdc1))/det_j1

            det_s1 = det_scal/4.d0

              AA(L1,K1) = AA(L1,K1)  +  det_s1 * wx_pl(ip1)*wy_pl(ip1)*wz_pl(ip1) * dpdx1 * plx1
              BB(L1,K1) = BB(L1,K1)  +  det_s1 * wx_pl(ip1)*wy_pl(ip1)*wz_pl(ip1) * dpdy1 * plx1
              CC(L1,K1) = CC(L1,K1)  +  det_s1 * wx_pl(ip1)*wy_pl(ip1)*wz_pl(ip1) * dpdzt1 * plx1
              PP(L1,K1) = PP(L1,K1)  +  det_s1 * wx_pl(ip1)*wy_pl(ip1)*wz_pl(ip1) * pkx1 * plx1

                           endif

                      enddo   ! end loop on ip1

                  enddo
               enddo
            enddo  !end loop on K

        enddo
     enddo
  enddo    !end loop in L

!********************************************************************************************!
!   MATRICES (-,+)                                                                           !
!********************************************************************************************!

!!$OMP SECTION

       do p2 = 1, nn
        do n2 = 1, nn
          do m2 = 1, nn
             L2 = m2 + (n2-1)*nn + (p2-1)*nn*nn

             do h2 = 1, mm
                do j2 = 1, mm
                   do i2 = 1, mm
                      K2 = i2 + (j2-1)*mm + (h2-1)*mm*mm

                      do  ip2 = 1, nq

                          if( o_minus(ip2,1) .eq. ine) then

               dxdx2 = alfa11 + beta12*z_pl(ip2) + beta13*y_pl(ip2) + gamma1*y_pl(ip2)*z_pl(ip2)
               dydx2 = alfa21 + beta22*z_pl(ip2) + beta23*y_pl(ip2) + gamma2*y_pl(ip2)*z_pl(ip2)
               dzdx2 = alfa31 + beta32*z_pl(ip2) + beta33*y_pl(ip2) + gamma3*y_pl(ip2)*z_pl(ip2)

               dxdy2 = alfa12 + beta11*z_pl(ip2) + beta13*x_pl(ip2) + gamma1*z_pl(ip2)*x_pl(ip2)
               dydy2 = alfa22 + beta21*z_pl(ip2) + beta23*x_pl(ip2) + gamma2*z_pl(ip2)*x_pl(ip2)
               dzdy2 = alfa32 + beta31*z_pl(ip2) + beta33*x_pl(ip2) + gamma3*z_pl(ip2)*x_pl(ip2)

               dxdz2 = alfa13 + beta11*y_pl(ip2) + beta12*x_pl(ip2) + gamma1*x_pl(ip2)*y_pl(ip2)
               dydz2 = alfa23 + beta21*y_pl(ip2) + beta22*x_pl(ip2) + gamma2*x_pl(ip2)*y_pl(ip2)
               dzdz2 = alfa33 + beta31*y_pl(ip2) + beta32*x_pl(ip2) + gamma3*x_pl(ip2)*y_pl(ip2)

               dxdx_m = alfa11_mn + beta12_mn*z_mn(ip2) + beta13_mn*y_mn(ip2) + gamma1_mn*y_mn(ip2)*z_mn(ip2)
               dydx_m = alfa21_mn + beta22_mn*z_mn(ip2) + beta23_mn*y_mn(ip2) + gamma2_mn*y_mn(ip2)*z_mn(ip2)
               dzdx_m = alfa31_mn + beta32_mn*z_mn(ip2) + beta33_mn*y_mn(ip2) + gamma3_mn*y_mn(ip2)*z_mn(ip2)

               dxdy_m = alfa12_mn + beta11_mn*z_mn(ip2) + beta13_mn*x_mn(ip2) + gamma1_mn*z_mn(ip2)*x_mn(ip2)
               dydy_m = alfa22_mn + beta21_mn*z_mn(ip2) + beta23_mn*x_mn(ip2) + gamma2_mn*z_mn(ip2)*x_mn(ip2)
               dzdy_m = alfa32_mn + beta31_mn*z_mn(ip2) + beta33_mn*x_mn(ip2) + gamma3_mn*z_mn(ip2)*x_mn(ip2)

               dxdz_m = alfa13_mn + beta11_mn*y_mn(ip2) + beta12_mn*x_mn(ip2) + gamma1_mn*x_mn(ip2)*y_mn(ip2)
               dydz_m = alfa23_mn + beta21_mn*y_mn(ip2) + beta22_mn*x_mn(ip2) + gamma2_mn*x_mn(ip2)*y_mn(ip2)
               dzdz_m = alfa33_mn + beta31_mn*y_mn(ip2) + beta32_mn*x_mn(ip2) + gamma3_mn*x_mn(ip2)*y_mn(ip2)

               det_j_m = dxdz_m * (dydx_m*dzdy_m - dzdx_m*dydy_m) &
                       - dydz_m * (dxdx_m*dzdy_m - dzdx_m*dxdy_m) &
                       + dzdz_m * (dxdx_m*dydy_m - dydx_m*dxdy_m)

              dpdc2 = dphi(mm-1, ctm(i2), x_mn(ip2)) * phi(mm-1, ctm(j2), y_mn(ip2)) * phi(mm-1, ctm(h2), z_mn(ip2))
              dpde2 = phi(mm-1, ctm(i2), x_mn(ip2)) * dphi(mm-1, ctm(j2), y_mn(ip2)) * phi(mm-1, ctm(h2), z_mn(ip2))
              dpdz2 = phi(mm-1, ctm(i2), x_mn(ip2)) * phi(mm-1, ctm(j2), y_mn(ip2)) * dphi(mm-1, ctm(h2), z_mn(ip2))

                plx2 = phi(nn-1, ctp(m2), x_pl(ip2)) * phi(nn-1, ctp(n2), y_pl(ip2)) * phi(nn-1, ctp(p2), z_pl(ip2))
                pkx2 = phi(mm-1, ctm(i2), x_mn(ip2)) * phi(mm-1, ctm(j2), y_mn(ip2)) * phi(mm-1, ctm(h2), z_mn(ip2))

              dpdx2 = (dydx_m*(dzdy_m*dpdz2 - dzdz_m*dpde2) - dydy_m*(dzdx_m*dpdz2 - dzdz_m*dpdc2) + &
                       dydz_m*(dzdx_m*dpde2 - dzdy_m*dpdc2))/det_j_m

              dpdy2 = (dzdx_m*(dxdy_m*dpdz2 - dxdz_m*dpde2) - dzdy_m*(dxdx_m*dpdz2 - dxdz_m*dpdc2) + &
                      dzdz_m*(dxdx_m*dpde2 - dxdy_m*dpdc2))/det_j_m

             dpdzt2 = (dxdx_m*(dydy_m*dpdz2 - dydz_m*dpde2) - dxdy_m*(dydx_m*dpdz2 - dydz_m*dpdc2) + &
                      dxdz_m*(dydx_m*dpde2 - dydy_m*dpdc2))/det_j_m

              det_s2 = det_scal/4.d0

              DD(L2,K2) = DD(L2,K2)  +  det_s2 * wx_pl(ip2)*wy_pl(ip2)*wz_pl(ip2) * dpdx2 * plx2
              EE(L2,K2) = EE(L2,K2)  +  det_s2 * wx_pl(ip2)*wy_pl(ip2)*wz_pl(ip2) * dpdy2 * plx2
              FF(L2,K2) = FF(L2,K2)  +  det_s2 * wx_pl(ip2)*wy_pl(ip2)*wz_pl(ip2) * dpdzt2 * plx2
              QQ(L2,K2) = QQ(L2,K2)  +  det_s2 * wx_pl(ip2)*wy_pl(ip2)*wz_pl(ip2) * pkx2 * plx2

                           endif

                      enddo   ! end loop on ip2

                  enddo
               enddo
            enddo  !end loop on K

        enddo
     enddo
  enddo    !end loop on L

!********************************************************************************************!
!   MATRICES (+,-)                                                                           !
!********************************************************************************************!

!!$OMP SECTION

       do p3 = 1, nn
        do n3 = 1, nn
          do m3 = 1, nn
             L3 = m3 + (n3-1)*nn + (p3-1)*nn*nn

             do h3 = 1, mm
                do j3 = 1, mm
                   do i3 = 1, mm
                      K3 = i3 + (j3-1)*mm + (h3-1)*mm*mm

                      do  ip3 = 1, nq

                          if( o_minus(ip3,1) .eq. ine) then

               dxdx3 = alfa11 + beta12*z_pl(ip3) + beta13*y_pl(ip3) + gamma1*y_pl(ip3)*z_pl(ip3)
               dydx3 = alfa21 + beta22*z_pl(ip3) + beta23*y_pl(ip3) + gamma2*y_pl(ip3)*z_pl(ip3)
               dzdx3 = alfa31 + beta32*z_pl(ip3) + beta33*y_pl(ip3) + gamma3*y_pl(ip3)*z_pl(ip3)

               dxdy3 = alfa12 + beta11*z_pl(ip3) + beta13*x_pl(ip3) + gamma1*z_pl(ip3)*x_pl(ip3)
               dydy3 = alfa22 + beta21*z_pl(ip3) + beta23*x_pl(ip3) + gamma2*z_pl(ip3)*x_pl(ip3)
               dzdy3 = alfa32 + beta31*z_pl(ip3) + beta33*x_pl(ip3) + gamma3*z_pl(ip3)*x_pl(ip3)

               dxdz3 = alfa13 + beta11*y_pl(ip3) + beta12*x_pl(ip3) + gamma1*x_pl(ip3)*y_pl(ip3)
               dydz3 = alfa23 + beta21*y_pl(ip3) + beta22*x_pl(ip3) + gamma2*x_pl(ip3)*y_pl(ip3)
               dzdz3 = alfa33 + beta31*y_pl(ip3) + beta32*x_pl(ip3) + gamma3*x_pl(ip3)*y_pl(ip3)

               det_j3 = dxdz3 * (dydx3*dzdy3 - dzdx3*dydy3) &
                     - dydz3 * (dxdx3*dzdy3 - dzdx3*dxdy3) &
                     + dzdz3 * (dxdx3*dydy3 - dydx3*dxdy3)

              dpdc3 = dphi(nn-1, ctp(m3), x_pl(ip3)) * phi(nn-1, ctp(n3), y_pl(ip3)) * phi(nn-1, ctp(p3), z_pl(ip3))
              dpde3 = phi(nn-1, ctp(m3), x_pl(ip3)) * dphi(nn-1, ctp(n3), y_pl(ip3)) * phi(nn-1, ctp(p3), z_pl(ip3))
              dpdz3 = phi(nn-1, ctp(m3), x_pl(ip3)) * phi(nn-1, ctp(n3), y_pl(ip3)) * dphi(nn-1, ctp(p3), z_pl(ip3))

                pkx3 = phi(mm-1, ctm(i3), x_mn(ip3)) * phi(mm-1, ctm(j3), y_mn(ip3)) * phi(mm-1, ctm(h3), z_mn(ip3))

              dpdx3 = (dydx3*(dzdy3*dpdz3 - dzdz3*dpde3) - dydy3*(dzdx3*dpdz3 - dzdz3*dpdc3) + &
                       dydz3*(dzdx3*dpde3 - dzdy3*dpdc3))/det_j3

              dpdy3 = (dzdx3*(dxdy3*dpdz3 - dxdz3*dpde3) - dzdy3*(dxdx3*dpdz3 - dxdz3*dpdc3) + &
                      dzdz3*(dxdx3*dpde3 - dxdy3*dpdc3))/det_j3

             dpdzt3 = (dxdx3*(dydy3*dpdz3 - dydz3*dpde3) - dxdy3*(dydx3*dpdz3 - dydz3*dpdc3) + &
                      dxdz3*(dydx3*dpde3 - dydy3*dpdc3))/det_j3

              det_s3 = det_scal/4.d0

              GG(L3,K3) = GG(L3,K3)  +  det_s3 * wx_pl(ip3)*wy_pl(ip3)*wz_pl(ip3) * dpdx3 * pkx3
              HH(L3,K3) = HH(L3,K3)  +  det_s3 * wx_pl(ip3)*wy_pl(ip3)*wz_pl(ip3) * dpdy3 * pkx3
              II(L3,K3) = II(L3,K3)  +  det_s3 * wx_pl(ip3)*wy_pl(ip3)*wz_pl(ip3) * dpdzt3 * pkx3

                           endif

                      enddo   ! end loop on ip3

                  enddo
               enddo
            enddo  !end loop on K

        enddo
     enddo
  enddo    !end loop on L

!!$OMP END SECTIONS
!!$OMP BARRIER
!!$OMP END PARALLEL

  JP = 0.d0
  JP(1 : nn**3, 1 : nn**3) =  pen*PP - cp_a*AA - cp_c*BB - cp_d*CC &
               + dg_cnst*cp_a*transpose(AA) + dg_cnst*cp_c*transpose(BB) + dg_cnst*cp_d*transpose(CC)

  JP(1 : nn**3, nn**3+1 : 2*nn**3) = - cp_c*AA - cp_b*BB &
               + dg_cnst*cp_g*transpose(AA) + dg_cnst*cp_e*transpose(BB)

  JP(1 : nn**3, 2*nn**3+1 : 3*nn**3) = - cp_d*AA - cp_b*CC &
               + dg_cnst*cp_p*transpose(AA) + dg_cnst*cp_e*transpose(CC)

! write(*,*) JP(1 : nn**3, 2*nn**3+1 : 3*nn**3)

  JP(nn**3+1 : 2*nn**3, 1 : nn**3) = - cp_g*AA - cp_e*BB &
               + dg_cnst*cp_c*transpose(AA) + dg_cnst*cp_b*transpose(BB)

  JP(nn**3+1 : 2*nn**3, nn**3+1 : 2*nn**3) = pen*PP - cp_e*AA - cp_f*BB - cp_d*CC &
               + dg_cnst*cp_e*transpose(AA) + dg_cnst*cp_f*transpose(BB) + dg_cnst*cp_d*transpose(CC)

  JP(nn**3+1 : 2*nn**3, 2*nn**3+1 : 3*nn**3) = - cp_d*BB - cp_g*CC &
               + dg_cnst*cp_p*transpose(BB) + dg_cnst*cp_c*transpose(CC)

  JP(2*nn**3+1 : 3*nn**3, 1 : nn**3) = - cp_p*AA - cp_e*CC &
               + dg_cnst*cp_d*transpose(AA) + dg_cnst*cp_b*transpose(CC)

  JP(2*nn**3+1 : 3*nn**3, nn**3+1 : 2*nn**3) = - cp_p*BB - cp_c*CC &
               + dg_cnst*cp_d*transpose(BB) + dg_cnst*cp_g*transpose(CC)

  JP(2*nn**3+1 : 3*nn**3, 2*nn**3+1 : 3*nn**3) = pen*PP - cp_e*AA - cp_c*BB - cp_n*CC &
               + dg_cnst*cp_e*transpose(AA) + dg_cnst*cp_c*transpose(BB) + dg_cnst*cp_n*transpose(CC)

  JM = 0.d0
  JM(1 : nn**3, 1 : mm**3) = - pen*QQ - cp_a*DD - cp_c*EE - cp_d*FF &
                             - dg_cnst*cp_a*GG -dg_cnst*cp_c*HH - dg_cnst*cp_d*II

  JM(1 : nn**3, mm**3+1 : 2*mm**3) = - cp_c*DD - cp_b*EE - dg_cnst*cp_g*GG - dg_cnst*cp_e*HH

  JM(1 : nn**3, 2*mm**3+1 : 3*mm**3) = - cp_d*DD - cp_b*FF - dg_cnst*cp_p*GG - dg_cnst*cp_e*II

  JM(nn**3+1 : 2*nn**3, 1 : mm**3) = - cp_g*DD - cp_e*EE - dg_cnst*cp_c*GG - dg_cnst*cp_b*HH

  JM(nn**3+1 : 2*nn**3, mm**3+1 : 2*mm**3) = - pen*QQ - cp_e*DD - cp_f*EE - cp_d*FF &
                                             - dg_cnst*cp_e*GG - dg_cnst*cp_f*HH - dg_cnst*cp_d*II

  JM(nn**3+1 : 2*nn**3, 2*mm**3+1 : 3*mm**3) = - cp_d*EE - cp_g*FF - dg_cnst*cp_p*HH - dg_cnst*cp_c*II

  JM(2*nn**3+1 : 3*nn**3, 1 : mm**3) = - cp_p*DD - cp_e*FF - dg_cnst*cp_d*GG - dg_cnst*cp_b*II

  JM(2*nn**3+1 : 3*nn**3, mm**3+1 : 2*mm**3) = - cp_p*EE - cp_c*FF - dg_cnst*cp_d*HH - dg_cnst*cp_g*II

  JM(2*nn**3+1 : 3*nn**3, 2*mm**3+1 : 3*mm**3) = - pen*QQ - cp_e*DD - cp_c*EE - cp_n*FF &
                                             - dg_cnst*cp_e*GG - dg_cnst*cp_c*HH - dg_cnst*cp_n*II

   if(testmode .eq. 1) then

     JP_uv = 0.d0
     JP_uv(1 : nn**3, 1 : nn**3) =  pen*PP
     JP_uv(nn**3+1 : 2*nn**3, nn**3+1 : 2*nn**3) = pen*PP
     JP_uv(2*nn**3+1 : 3*nn**3, 2*nn**3+1 : 3*nn**3) = pen*PP

     JM_uv = 0.d0
     JM_uv(1 : nn**3, 1 : mm**3) = - pen*QQ
     JM_uv(nn**3+1 : 2*nn**3, mm**3+1 : 2*mm**3) = - pen*QQ
     JM_uv(2*nn**3+1 : 3*nn**3, 2*mm**3+1 : 3*mm**3) = - pen*QQ

   endif

   deallocate(AA,BB,CC,PP)
   deallocate(DD,EE,FF,QQ)
   deallocate(GG,HH,II)

   end subroutine MAKE_LOC_MATRIX_DG


c
c	This subroutine is responsible for deteriming the total electron
c	density as a function of position within the ionosphere and
c	plasmasphere.
c
c     dlg June 3, 2009  fixed a problem with obtaining density below the F2 peak
c
c     dlg June 11, 2009 added switchon feature to field aligned bridge function
c                       so that the equatorial density would be reached without
c                       having to use hugh power-law function factors when the
c                       topside fitted power-law was above equatorial density
c                       at the equator.
c
	function ne_iri_ps_trough(r,al,alatr,amlt,akp,itime)
c
	real pi,amltrad,re,amlt_o,akp_o,al_o
	parameter (pi=3.1415927,amltrad=pi/12.0)
	real r,al,amlt,akp,ne_iri_ps_trough_eq
	real ne_iri_ps_trough,aheight,alatr,transh,alpha
	real outf(20,100),oarr(50),eq_iri_ps_trough
	real ano,co,along,eq_bridge,swtch1,switchon
	real switchh,switchw
	real*8 dno,rf2
	integer*4 itime(2),itime1_o,itime2_o,istat
	data re/6371.0/
	data amlt_o/-99.0/akp_o/-99.0/,al_o/-99.0/
	data itime1_o/-99/,itime2_o/-99/

c	  print*,'entering ne_iri_ps_trough with',r,al,alatr
c	  print*,'           and ',amlt,akp,itime
c
c  We don't do inside the earth; we're just not that kind of model, humph!
	if(r.le.1.0) then
	  ne_iri_ps_trough=0.0
	  return
	end if
c
c
c  altitude of point of interest
	aheight=(r-1.0)*re
	ahemisphere=sign(1.0,alatr)
c  density at the equator for given L-shell
	eq_iri_ps_trough=ne_iri_ps_trough_eq(al,amlt,akp,itime)
c	  print*,'back from ne_iri_ps_trough_eq=',eq_iri_ps_trough
c	  print*,'bridge? ',amlt,amlt_o,akp,akp_o,al,al_o
c	  print*,'      ? ',itime(1),itime1_o,itime(2),itime2_o
	if(amlt.ne.amlt_o .or. akp.ne.akp_o .or.
     &	itime(1).ne.itime1_o .or. itime(2).ne.itime2_o .or.
     &	abs(al-al_o).gt.1.0e-5 .or. istat.lt.0 .or.
     &  ahemisphere.ne.ahemisphere_o) then
c	  print*,'Evaluate field aligned power law function'
c	  print*,'showit:',(amlt-amlt_o),(akp-akp_o),(al-al_o)
c	  print*,(itime(1)-itime1_o),(itime(2)-itime2_o)
c
c  determine the height power law fit parameters that connect the
c  topside ionosphere to the equatorial density along given L-shell
	  call iri_ps_bridge(r,al,alatr,amlt,itime,eq_iri_ps_trough,
     &		transh,rf2,alpha,dno,co,switchh,switchw,istat)
	  if (istat.lt.0) then
	    along=(amlt-12.0)*amltrad
	    call iri_sm(alatr,along,r,itime,outf,oarr)
	    ne_iri_ps_trough=outf(1,1)
c	  print*,'back from iri_ps_bridge with stat<0'
c	  print*,'     ',r,alatr,along,ne_iri_ps_trough
	    return
	  endif
	  al_o=al
	  amlt_o=amlt
	  akp_o=akp
	  ahemisphere_o=ahemisphere
	  itime1_o=itime(1)
	  itime2_o=itime(2)
c	  print*,'ne_iri_ps_trough transh=',transh,alpha,dno,co,
c    &                  switchh,switchw,istat
c	  print*,'   >',r,al,alatr,amlt,itime,eq_iri_ps_trough
	end if

c  compute density as given by the bridge function
c        swtchb=switchon(aheight,switchh,switchw)
         if (aheight .le. (switchh-switchw)) then
           swtchb=0.0
         else
           if (aheight .ge. (switchh+switchw)) then
             swtchb=1.0
           else
             swtchb=(aheight-(switchh-switchw))/(2.0*switchw)
           endif
         endif
	  eq_bridge=(dno*aheight**(-alpha) + co)*(1.0-swtchb)
     &                 + swtchb*eq_iri_ps_trough
c	  print*,'bridge ne=',eq_bridge,dno,aheight,alpha,co

c  to call IRI or not to call IRI, that is the question...
	  if (aheight.lt.1000.0) then
	    along=(amlt-12.0)*amltrad
	    call iri_sm(alatr,along,r,itime,outf,oarr)
	    if (r .le. rf2) then
	      ne_iri_ps_trough=outf(1,1)
	    else
	      swtch1=switchon(aheight,transh,5.0)
	      ne_iri_ps_trough=outf(1,1)*(1.0-swtch1) + eq_bridge*swtch1
	      ne_iri_ps_trough=ne_iri_ps_trough*float(istat+1)
     &						+ outf(1,1)*float(iabs(istat))
c	  print*,'swtch',outf(1,1),eq_bridge,swtch1,ne_iri_ps_trough
          endif
	  else

	    ne_iri_ps_trough=eq_bridge
	  end if
c	  print*,'leaving ne_iri_ps_trough=',ne_iri_ps_trough
c	  print*,'                        =',r,al,alatr,amlt,akp
c
c	  print*,'ne_iri_ps_trough:',eq_bridge,ne_iri_ps_trough
	return
	end


! This code is from QEDMOD with minor modifications.
!
!   V.M. Shabaev, I.I. Tupitsyn, V.A. Yerokhin, QEDMOD: Fortran program for calculating
!   the model Lamb-shift operator, Computer Physics Communications, Volume 189, 2015,
!   Pages 175-181, ISSN 0010-4655, http://dx.doi.org/10.1016/j.cpc.2014.12.002.
!
! For a description of the changes made, see the README.
!
! Original code is distributed under the CPC non-profit use licence
! (http://cpc.cs.qub.ac.uk/licence/licence.html). Redistributed here as part of
! GRASP2K with permission from the authors.
!
! Originally from: f/common/integr.f
!
c       =================================================
        function SHAB_tint(k,p,q,a,b,r,v)
c       - - - - - - - - - - - - - - - - - - - - - - - - -
c       This function computes the matrix elements of r^k
c       tint= <p,q|r^k|a,b>
c       Numerical integration is performed by Simpson's rule
c
c       Input:
c       p(i) - the upper radial component of the left wave function
c       q(i) - the lower radial component of the left wave function
c       a(i) - the upper radial component of the right wave function
c       b(i) - the lower radial component of the right wave function
c       r(i) - the radial grid
c       v(i) - the weights of the Simpson formula for nonuniform grid
c
c       Common parameters:
c       h    - grid step
c       ii   - Number of grid points
c
c       - - - - - - - - - - - - - - - - - - - - - - - - -
        implicit real*8 (a-h,o-z)
c       - - - - - - - - - - - - - - - - - - - - - - - - -
        include 'qedmod.inc'
c       - - - - - - - - - - - - - - - - - - - - - - - - -
        common /SHAB_grd/h,r1,r2,al,bt,ii
        real*8 p(maxii),q(maxii),a(maxii),b(maxii)
        real*8 r(maxii),v(maxii)
c       - - - - - - - - - - - - - - - - - - - - - - - - -
        i0=1
        r0=r(i0)
c       - - - - - - - - - - - - - - - - - - - - - - - - -
        imax=ii
        do i=ii,1,-1
          d=dabs(p(i))+dabs(q(i))+dabs(a(i))+dabs(b(i))
          if (d.gt.1.d-20) goto 200
          imax=i
        enddo
c       - - - - - - - - - - - - - - - - - - - - - - - - -
c       Integration from 0 to r1
c       - - - - - - - - - - - - - - - - - - - - - - - - -
200     f1=(p(1)*a(1)+q(1)*b(1))*r(1)**k
        f5=(p(5)*a(5)+q(5)*b(5))*r(5)**k
        g=dlog(f5/f1)/dlog(r(5)/r(1))
        t0=r(1)*f1/(g+1)
        if(t0 /= t0) then
c         This should be relatively safe to do, since t0 is basically always
c         insignificant.
          print '(a,"[",a,"]: ",a)', "qedmod::shab_tint", "WARNING",
     &      "t0 estimation failed, setting to zero"
          t0 = 0.0d0
        endif
c       - - - - - - - - - - - - - - - - - - - - - - - - -
        ds=0.d0
        i1=1
        i2=imax
c       - - - - - - - - - - - - - - - - - - - - - - - - -
c       If the number of points is even we use four-point
c       Simpson's rule for first 4 points. The number
c       of the rest points is odd
c       - - - - - - - - - - - - - - - - - - - - - - - - -
        if (2*(imax/2).eq.imax) then
          i=i1
          f1=(p(i)*a(i)+q(i)*b(i))*v(i)*r(i)**k
          i=i1+1
          f2=(p(i)*a(i)+q(i)*b(i))*v(i)*r(i)**k
          i=i1+2
          f3=(p(i)*a(i)+q(i)*b(i))*v(i)*r(i)**k
          i=i1+3
          f4=(p(i)*a(i)+q(i)*b(i))*v(i)*r(i)**k
          ds=ds+3.d0/8.d0*h*(f1+3*f2+3*f3+f4)
          i1=i1+3
        endif
c       - - - - - - - - - - - - - - - - - - - - - - - - -
c       Simpson's rule for the odd number of points.
c       - - - - - - - - - - - - - - - - - - - - - - - - -
        dt1=0.d0
        do i=i1,i2,2
          fi=(p(i)*a(i)+q(i)*b(i))*v(i)*r(i)**k
          dt1=dt1+fi
        enddo
        f1=(p(i1)*a(i1)+q(i1)*b(i1))*v(i1)*r(i1)**k
        f2=(p(i2)*a(i2)+q(i2)*b(i2))*v(i2)*r(i2)**k
        dt1=2*dt1-f1-f2
c
        dt2=0.d0
        do i=i1+1,i2-1,2
          fi=(p(i)*a(i)+q(i)*b(i))*v(i)*r(i)**k
          dt2=dt2+fi
        enddo
        dt2=4*dt2
        dt=h*(dt1+dt2)/3.d0
c       - - - - - - - - - - - - - - - - - - - - - - - - -
        SHAB_tint=ds+dt+t0
c       - - - - - - - - - - - - - - - - - - - - - - - - -
        return
        end
c       =================================================
        function SHAB_sint(c,p,q,a,b,r,v)
c       - - - - - - - - - - - - - - - - - - - - - - - - -
c       This function computes the matrix element
c       sint=<p,q|c(r)/r|a,b>.
c       Numerical integration is performed by Simpson's rule
c
c       Input:
c       p(i) - the upper radial component of the left wave function
c       q(i) - the lower radial component of the left wave function
c       a(i) - the upper radial component of the right wave function
c       b(i) - the lower radial component of the right wave function
c       r(i) - the radial grid
c       v(i) - the weights of the Simpson formula for nonuniform grid
c
c       Common parameters:
c       h    - grid step
c       ii   - Number of grid points
c
c       - - - - - - - - - - - - - - - - - - - - - - - - -
        implicit real*8 (a-h,o-z)
c       - - - - - - - - - - - - - - - - - - - - - - - - -
        include 'qedmod.inc'
c       - - - - - - - - - - - - - - - - - - - - - - - - -
        common /SHAB_grd/h,r1,r2,al,bt,ii
        real*8 c(maxii),p(maxii),q(maxii),a(maxii),b(maxii)
        real*8 r(maxii),v(maxii)
c       - - - - - - - - - - - - - - - - - - - - - - - - -
        i0=1
        r0=r(i0)
c       - - - - - - - - - - - - - - - - - - - - - - - - -
        imax=ii
        do i=ii,1,-1
          d=dabs(p(i))+dabs(q(i))+dabs(a(i))+dabs(b(i))+dabs(c(i))
          if (d.gt.1.d-20) goto 200
          imax=i-1
        enddo
c       - - - - - - - - - - - - - - - - - - - - - - - - -
c       Integration from 0 to r1
c       - - - - - - - - - - - - - - - - - - - - - - - - -
200     f1=c(1)*(p(1)*a(1)+q(1)*b(1))/r(1)
        f5=c(5)*(p(5)*a(5)+q(5)*b(5))/r(5)
        g=dlog(f5/f1)/dlog(r(5)/r(1))
        t0=r(1)*f1/(g+1)
c       - - - - - - - - - - - - - - - - - - - - - - - - -
        SHAB_sint=0.d0
        i1=1
        i2=imax
c       - - - - - - - - - - - - - - - - - - - - - - - - -
c       If the number of points is even we use four-point
c       Simpson's rule for first 4 points. The number
c       of the rest points is odd
c       - - - - - - - - - - - - - - - - - - - - - - - - -
        if (2*(imax/2).eq.imax) then
          i=i1
          f1=(p(i)*a(i)+q(i)*b(i))*c(i)*v(i)/r(i)
          i=i1+1
          f2=(p(i)*a(i)+q(i)*b(i))*c(i)*v(i)/r(i)
          i=i1+2
          f3=(p(i)*a(i)+q(i)*b(i))*c(i)*v(i)/r(i)
          i=i1+3
          f4=(p(i)*a(i)+q(i)*b(i))*c(i)*v(i)/r(i)
          SHAB_sint=SHAB_sint+3.d0/8.d0*h*(f1+3*f2+3*f3+f4)
          i1=i1+3
        endif
c       - - - - - - - - - - - - - - - - - - - - - - - - -
c       Simpson's rule for the odd number of points.
c       - - - - - - - - - - - - - - - - - - - - - - - - -
        dt1=0.d0
        do i=i1,i2,2
          fi=(p(i)*a(i)+q(i)*b(i))*c(i)*v(i)/r(i)
          dt1=dt1+fi
        enddo
        f1=(p(i1)*a(i1)+q(i1)*b(i1))*c(i1)*v(i1)/r(i1)
        f2=(p(i2)*a(i2)+q(i2)*b(i2))*c(i2)*v(i2)/r(i2)
        dt1=2*dt1-f1-f2
c
        dt2=0.d0
        do i=i1+1,i2-1,2
          fi=(p(i)*a(i)+q(i)*b(i))*c(i)*v(i)/r(i)
          dt2=dt2+fi
        enddo
        dt2=4*dt2
        dt=h*(dt1+dt2)/3.d0
c       - - - - - - - - - - - - - - - - - - - - - - - - -
        SHAB_sint=SHAB_sint+dt+t0
c       - - - - - - - - - - - - - - - - - - - - - - - - -
        return
        end


c !DEC$ IF DEFINED (NEED_BLAS)
      SUBROUTINE saxpy(N, SA, SX, INCX, SY, INCY)
      USE LAPREC, ONLY: WP => SP
      IMPLICIT NONE
C-----------------------------------------------
C   D U M M Y   A R G U M E N T S
C-----------------------------------------------
      INTEGER, INTENT(IN) :: N, INCX, INCY
      REAL(WP), INTENT(IN) :: SA, SX(*)
      REAL(WP), INTENT(INOUT) :: SY(*)
C-----------------------------------------------
C   L O C A L   P A R A M E T E R S
C-----------------------------------------------
      REAL(WP), PARAMETER :: ZERO = 0
C-----------------------------------------------
C   L O C A L   V A R I A B L E S
C-----------------------------------------------
      INTEGER :: IX, IY
C-----------------------------------------------
C
      IF (n .le. 0) RETURN
      IF (sa .eq. zero) RETURN

      IF (incx.ne.1 .or. incy.ne.1) THEN
c
c     code for unequal increments or equal increments
c     not equal to 1
c
         ix = 1
         iy = 1
         IF (incx .lt. 0)ix = (-n+1)*incx + 1
         IF (incy .lt. 0)iy = (-n+1)*incy + 1

         sy(iy:(n-1)*incy+iy:incy) = sy(iy:(n-1)*incy+iy:incy)
     1            + sa * sx(ix:(n-1)*incx+ix:incx)
      ELSE
c
c     code for both increments equal to 1
c
         sy(:n) = sy(:n) + sa*sx(:n)
      END IF

      END SUBROUTINE saxpy

      SUBROUTINE daxpy(N, SA, SX, INCX, SY, INCY)
      USE LAPREC, ONLY: WP => DP
      IMPLICIT NONE
C-----------------------------------------------
C   D U M M Y   A R G U M E N T S
C-----------------------------------------------
      INTEGER, INTENT(IN) :: N, INCX, INCY
      REAL(WP), INTENT(IN) :: SA, SX(*)
      REAL(WP), INTENT(INOUT) :: SY(*)
C-----------------------------------------------
C   L O C A L   P A R A M E T E R S
C-----------------------------------------------
      REAL(WP), PARAMETER :: ZERO = 0
C-----------------------------------------------
C   L O C A L   V A R I A B L E S
C-----------------------------------------------
      INTEGER :: IX, IY
C-----------------------------------------------
C
      IF (n .le. 0) RETURN
      IF (sa .eq. zero) RETURN

      IF (incx.ne.1 .or. incy.ne.1) THEN
c
c     code for unequal increments or equal increments
c     not equal to 1
c
         ix = 1
         iy = 1
         IF (incx .lt. 0)ix = (-n+1)*incx + 1
         IF (incy .lt. 0)iy = (-n+1)*incy + 1

         sy(iy:(n-1)*incy+iy:incy) = sy(iy:(n-1)*incy+iy:incy)
     1            + sa * sx(ix:(n-1)*incx+ix:incx)
      ELSE
c
c     code for both increments equal to 1
c
         sy(:n) = sy(:n) + sa*sx(:n)
      END IF

      END SUBROUTINE daxpy
c !DEC$ ELSE
c       SUBROUTINE bla_stub
c       END SUBROUTINE bla_stub
c !DEC$ ENDIF


submodule(stdlib_bitsets) stdlib_bitsets_large
    implicit none

contains

    elemental module function all_large( self ) result(all)
!     Returns .TRUE. if all bits in SELF are 1, .FALSE. otherwise.
        logical                         :: all
        class(bitset_large), intent(in) :: self

        integer(bits_kind) :: block, full_blocks, pos

        all = .true.
        full_blocks = bits(self)/block_size
        do block = 1_bits_kind, full_blocks
            if ( self % blocks(block) /= -1_block_kind ) then
                all = .false.
                return
            end if
        end do

        if ( full_blocks == size(self % blocks) ) return

        do pos=0_bits_kind, modulo( bits(self), block_size )-1
            if ( .not. btest(self % blocks(full_blocks+1), pos) ) then
                all = .false.
                return
            end if
        end do

    end function all_large

    elemental module subroutine and_large(set1, set2)
!
!     Sets the bits in SET1 to the bitwise AND of the original bits in SET1
!     and SET2. It is required that SET1 have the same number of bits as
!     SET2 otherwise the result is undefined.
!
        type(bitset_large), intent(inout) :: set1
        type(bitset_large), intent(in)    :: set2

        integer(bits_kind) :: block_

        do block_ = 1_bits_kind, size(set1 % blocks, kind=bits_kind)
            set1 % blocks(block_) = iand( set1 % blocks(block_), &
                                          set2 % blocks(block_) )
        end do

    end subroutine and_large

    elemental module subroutine and_not_large(set1, set2)
!
!     Sets the bits in SET1 to the bitwise and of the original bits in SET1
!     with the bitwise negation of SET2. SET1 and SET2 must have the same
!     number of bits otherwise the result is undefined.
!
        type(bitset_large), intent(inout) :: set1
        type(bitset_large), intent(in)    :: set2

        integer(bits_kind) :: block_

        do block_ = 1_bits_kind, size( set1 % blocks, kind=bits_kind )
            set1 % blocks(block_) =                                      &
                iand( set1 % blocks(block_), not( set2 % blocks(block_) ) )
        end do

    end subroutine and_not_large

    elemental module function any_large(self) result(any)
!     Returns .TRUE. if any bit in SELF is 1, .FALSE. otherwise.
        logical                         :: any
        class(bitset_large), intent(in) :: self

        integer(bits_kind) :: block_

        do block_ = 1_bits_kind, size(self % blocks, kind=bits_kind)
            if ( self % blocks(block_) /= 0 ) then
                any = .true.
                return
            end if
        end do
        any = .false.

    end function any_large

    pure module subroutine assign_large( set1, set2 )
!     Used to define assignment for bitset_large
        type(bitset_large), intent(out) :: set1
        type(bitset_large), intent(in)  :: set2

        set1 % num_bits = set2 % num_bits
        allocate( set1 % blocks( size( set2 % blocks, kind=bits_kind ) ) )
        set1 % blocks(:) = set2 % blocks(:)

    end subroutine assign_large

    pure module subroutine assign_logint32_large( self, logical_vector )
!     Used to define assignment from an array of type logical for bitset_large
        type(bitset_large), intent(out) :: self
        logical(int32), intent(in)       :: logical_vector(:)

        integer(bits_kind) :: blocks
        integer(bits_kind) :: log_size
        integer(bits_kind) :: index

        log_size = size( logical_vector, kind=bits_kind )
        self % num_bits = log_size
        if ( log_size == 0 ) then
            blocks = 0
        else
            blocks = (log_size-1)/block_size + 1
        end if
        allocate( self % blocks( blocks ) )
        self % blocks(:) = 0

        do index=0_bits_kind, log_size-1
            if ( logical_vector(index+1) ) then
                call self % set( index )
            end if
        end do

    end subroutine assign_logint32_large

    pure module subroutine logint32_assign_large( logical_vector, set )
!     Used to define assignment to an array of type logical for bitset_large
        logical(int32), intent(out), allocatable :: logical_vector(:)
        type(bitset_large), intent(in)          :: set

        integer(bits_kind) :: index

        allocate( logical_vector( set % num_bits ) )
        do index=0_bits_kind, set % num_bits-1
            if ( set % value( index ) == 1 ) then
                logical_vector(index+1) = .true.
            else
                logical_vector(index+1) = .false.
            end if
        end do

    end subroutine logint32_assign_large

    elemental module function bit_count_large(self) result(bit_count)
!     Returns the number of non-zero bits in SELF.
        integer(bits_kind)              ::  bit_count
        class(bitset_large), intent(in) :: self

        integer(bits_kind) :: block_, pos

        bit_count = 0
        do block_ = 1_bits_kind, size(self % blocks, kind=bits_kind) - 1
            do pos = 0, block_size-1
                if ( btest( self % blocks(block_), pos ) ) &
                    bit_count = bit_count + 1
            end do

        end do

        do pos = 0_bits_kind, self % num_bits - (block_-1)*block_size - 1
            if ( btest( self % blocks(block_), pos ) ) bit_count = bit_count + 1
        end do

    end function bit_count_large

    elemental module subroutine clear_bit_large(self, pos)
!
!     Sets to zero the POS position in SELF. If POS is less than zero or
!     greater than BITS(SELF)-1 it is ignored.
!
        class(bitset_large), intent(inout) :: self
        integer(bits_kind), intent(in)     :: pos

        integer :: clear_block, block_bit

        if ( pos < 0 .OR. (pos > self % num_bits-1) ) return
        clear_block = pos / block_size + 1
        block_bit   = pos - (clear_block - 1) * block_size
        self % blocks(clear_block) = &
            ibclr( self % blocks(clear_block), block_bit )

    end subroutine clear_bit_large

    pure module subroutine clear_range_large(self, start_pos, stop_pos)
!
!     Sets to zero all bits from the START_POS to STOP_POS positions in SELF.
!     If STOP_POS < START_POS then no bits are modified. Positions outside
!     the range 0 to BITS(SELF)-1 are ignored.
!
        class(bitset_large), intent(inout) :: self
        integer(bits_kind), intent(in)     :: start_pos, stop_pos

        integer(bits_kind) :: bit, block_, first_block, last_block, &
                              true_first, true_last

        true_first = max( 0_bits_kind, start_pos )
        true_last  = min( self % num_bits-1, stop_pos )
        if ( true_last < true_first ) return

        first_block = true_first / block_size + 1
        last_block  = true_last / block_size + 1
        if ( first_block == last_block ) then
!     TRUE_FIRST and TRUE_LAST are in the same block
            call mvbits( all_zeros,                               &
                         true_first - (first_block-1)*block_size, &
                         true_last - true_first + 1,              &
                         self % blocks(first_block),              &
                         true_first - (first_block-1)*block_size )
            return
        end if

!     Do "partial" black containing FIRST
        bit = true_first - (first_block-1)*block_size
        call mvbits( all_zeros,                  &
                     bit,                        &
                     block_size - bit,           &
                     self % blocks(first_block), &
                     bit )

!     Do "partial" black containing LAST
        bit = true_last - (last_block-1)*block_size
        call mvbits( all_zeros,                 &
                     0,                         &
                     bit+1,                     &
                     self % blocks(last_block), &
                     0 )

!     Do intermediate blocks
        do block_ = first_block+1, last_block-1
            self % blocks(block_) = all_zeros
        end do

    end subroutine clear_range_large

    elemental module function eqv_large(set1, set2) result(eqv)
!
!     Returns .TRUE. if all bits in SET1 and SET2 have the same value,
!     .FALSE.  otherwise.  The sets must have the same number of bits
!     otherwise the results are undefined.
!
        logical                        :: eqv
        type(bitset_large), intent(in) :: set1, set2

        integer(bits_kind) :: block, common_blocks

        eqv = .false.
        common_blocks = size(set1 % blocks, kind=bits_kind)
        do block = 1, common_blocks
            if ( set1 % blocks(block) /= set2 % blocks(block) ) return
        end do
        eqv = .true.

    end function eqv_large

    module subroutine extract_large(new, old, start_pos, stop_pos, status)
!    Creates a new bitset, NEW, from a range, START_POS to STOP_POS, in bitset
!    OLD. If START_POS is greater than STOP_POS the new bitset is empty.
!    If START_POS is less than zero or STOP_POS is greater than BITS(OLD)-1
!    then if STATUS is present it has the value INDEX_INVALID_ERROR,
!    otherwise processing stops with an informative message.
        type(bitset_large), intent(out) :: new
        type(bitset_large), intent(in)  :: old
        integer(bits_kind), intent(in)  :: start_pos, stop_pos
        integer, intent(out), optional  :: status

        integer(bits_kind) :: bits, blocks, ex_block, i, j, k, old_block
        character(*), parameter :: procedure = 'EXTRACT'

        if ( start_pos < 0 ) then
            call error_handler( 'had a START_POS less than 0.', &
                                index_invalid_error, status,    &
                                module_name, procedure )
            return
        end if
        if ( stop_pos >= old % num_bits ) then
            call error_handler( 'had a STOP_POS greater than BITS(OLD)-1.', &
                                index_invalid_error, status,                &
                                module_name, procedure )
            return
        end if
        bits = stop_pos - start_pos + 1

        if ( bits <= 0 ) then
            new % num_bits = 0
            allocate( new % blocks(0) )
            return
        end if

        blocks = ((bits-1) / block_size) + 1

        new % num_bits = bits
        allocate( new % blocks(blocks) )
        new % blocks(:) = 0

        do i=0_bits_kind, bits-1
            ex_block = i / block_size + 1
            j = i - (ex_block-1) * block_size
            old_block = (start_pos + i) / block_size + 1
            k = (start_pos + i) - (old_block-1) * block_size
            if ( btest( old % blocks(old_block), k ) ) then
                new % blocks(ex_block) = ibset(new % blocks(ex_block), j)
            end if
        end do

        if ( present(status) ) status = success

    end subroutine extract_large

    elemental module subroutine flip_bit_large(self, pos)
!
!     Flips the value at the POS position in SELF, provided the position is
!     valid. If POS is less than 0 or greater than BITS(SELF)-1, no value is
!     changed.
!
        class(bitset_large), intent(inout) :: self
        integer(bits_kind), intent(in)     :: pos

        integer(bits_kind) :: flip_block, block_bit

        if ( pos < 0 .OR. pos > self % num_bits-1 ) return

        flip_block = pos / block_size + 1
        block_bit  = pos - (flip_block - 1) * block_size
        if ( btest( self % blocks(flip_block), block_bit ) ) then
            self % blocks(flip_block) = ibclr( self % blocks(flip_block), &
                                               block_bit )
        else
            self % blocks(flip_block) = ibset( self % blocks(flip_block), &
                                               block_bit )
        end if

    end subroutine flip_bit_large

    pure module subroutine flip_range_large(self, start_pos, stop_pos)
!
!     Flips all valid bits from the START_POS to the STOP_POS positions in
!     SELF. If STOP_POS < START_POS no bits are flipped. Positions less than
!     0 or greater than BITS(SELF)-1 are ignored.
!
        class(bitset_large), intent(inout) :: self
        integer(bits_kind), intent(in)     :: start_pos, stop_pos

        integer(bits_kind) :: bit, block_, end_bit, first_block, last_block, &
                              start_bit

        start_bit = max( 0_bits_kind, start_pos )
        end_bit   = min( stop_pos , self % num_bits-1 )
        if ( end_bit < start_bit ) return

        first_block = start_bit / block_size + 1
        last_block  = end_bit / block_size + 1
        if (first_block == last_block) then
!         FIRST and LAST are in the same block
            call mvbits( not(self % blocks(first_block)),        &
                         start_bit - (first_block-1)*block_size, &
                         end_bit - start_bit + 1,                &
                         self % blocks(first_block),             &
                         start_bit - (first_block-1)*block_size )
            return
        end if

!     Do "partial" black containing FIRST
        bit = start_bit - (first_block-1)*block_size
        call mvbits( not(self % blocks(first_block) ), &
                     bit,                              &
                     block_size - bit,                 &
                     self % blocks(first_block),       &
                     bit )

!     Do "partial" black containing LAST
        bit = end_bit - (last_block-1)*block_size
        call mvbits( not( self % blocks(last_block) ), &
                     0,                                &
                     bit+1,                            &
                     self % blocks(last_block),        &
                     0 )

!     Do remaining blocks
        do block_ = first_block+1, last_block-1
            self % blocks(block_) = not( self % blocks(block_) )
        end do

    end subroutine flip_range_large

    module subroutine from_string_large(self, string, status)
!     Initializes the bitset `self` treating `string` as a binary literal
!     `status` may have the values:
!         `success` - if no problems were found,
!         `alloc_fault` - if allocation of the bitset failed
!         `char_string_too_large_error` - if `string` was too large, or
!         `char_string_invalid_error` - if string had an invalid character.
        class(bitset_large), intent(out) :: self
        character(*), intent(in)         :: string
        integer, intent(out), optional   :: status

        character(*), parameter :: procedure = 'FROM_STRING'
        integer(int64) :: bit
        integer(int64) :: bits
        character(1)   :: char

        bits = len(string, kind=int64)
        if ( bits > huge(0_bits_kind) ) then
            call error_handler( 'STRING was too long for a ' //      &
                                'BITSET_LARGE SELF.',                &
                                char_string_too_large_error, status, &
                                module_name, procedure )
            return
        end if

        call init_zero_large( self, int(bits, kind=bits_kind), status )

        if ( present(status) ) then
            if ( status /= success ) return
        end if

        do bit = 1_bits_kind, bits
            char = string(bit:bit)
            if ( char == '0' ) then
                call self % clear( int(bits-bit, kind=bits_kind) )
            else if ( char == '1' ) then
                call self % set( int(bits-bit, kind=bits_kind) )
            else
                call error_handler( 'STRING had a character other than ' // &
                                    '0 or 1.',                              &
                                    char_string_invalid_error, status,      &
                                    module_name, procedure )
                return
            end if
        end do

        if ( present(status) ) status = success

    end subroutine from_string_large

    elemental module function ge_large(set1, set2) result(ge)
!
!     Returns .TRUE. if the bits in SET1 and SET2 are the same or the
!     highest order different bit is set to 1 in SET1 and to 0 in set2.
!     .FALSE.  otherwise.  The sets must have the same number of bits
!     otherwise the results are undefined.
!
        logical                        :: ge
        type(bitset_large), intent(in) :: set1, set2

        integer(bits_kind) :: block_

        do block_ = size(set1 % blocks, kind=bits_kind), 1_bits_kind, -1
            if ( set1 % blocks(block_) == set2 % blocks(block_) ) then
                cycle
            else if ( bgt(set1 % blocks(block_), set2 % blocks(block_) ) ) then
                ge = .true.
                return
            else
                ge = .false.
                return
            end if
        end do
        ge = .true.

    end function ge_large

    elemental module function gt_large(set1, set2) result(gt)
!
!     Returns .TRUE. if the bits in SET1 and SET2 differ and the
!     highest order different bit is set to 1 in SET1 and to 0 in set2.
!     .FALSE.  otherwise.  The sets must have the same number of bits
!     otherwise the results are undefined.
!
        logical                        :: gt
        type(bitset_large), intent(in) :: set1, set2

        integer(bits_kind) :: block_

        do block_ = size(set1 % blocks, kind=bits_kind), 1_bits_kind, -1
            if ( set1 % blocks(block_) == set2 % blocks(block_) ) then
                cycle
            else if ( bgt( set1 % blocks(block_),    &
                           set2 % blocks(block_) ) ) then
                gt = .true.
                return
            else
                gt = .false.
                return
            end if
        end do
        gt = .false.

    end function gt_large

    module subroutine init_zero_large(self, bits, status)
!
!  Creates the bitset, `self`, of size `bits`, with all bits initialized to
!  zero. `bits` must be non-negative.  If an error occurs and `status` is
!  absent then processing stops with an informative stop code. `status`
!  will have one of the values;
!  * `success` -  if no problems were found,
!  * `array_size_invalid_error` - if `bits` is either negative or larger
!    than 64 with `self` of class `bitset_64`, or
!  * `alloc_fault` - if memory allocation failed
!
        class(bitset_large), intent(out) :: self
        integer(bits_kind), intent(in)   :: bits
        integer, intent(out), optional   :: status

        character(len=120)      :: message
        character(*), parameter :: procedure = "INIT"
        integer                 :: blocks, ierr

        message = ''
        if ( bits < 0 ) then
            call error_handler( 'BITS had a negative value.',    &
                                array_size_invalid_error, status, &
                                module_name, procedure )
            return
        end if

        if (bits == 0) then
            self % num_bits = 0
            allocate( self % blocks(0), stat=ierr, errmsg=message )
            if (ierr /= 0) go to 998
            return
        else
            blocks = ((bits-1) / block_size) + 1
        end if

        self % num_bits = bits
        allocate( self % blocks(blocks), stat=ierr, errmsg=message )
        if (ierr /= 0) go to 998

        self % blocks(:) = all_zeros

        if ( present(status) ) status = success

        return

998     call error_handler( 'Allocation failure for SELF.', &
                            alloc_fault, status,            &
                            module_name, procedure )

    end subroutine init_zero_large

    module subroutine input_large(self, unit, status)
!
! Reads the components of the bitset, `self`, from the unformatted I/O
! unit, `unit`, assuming that the components were written using `output`.
! If an error occurs and `status` is absent then processing stops with
! an informative stop code. `status` has one of the values:
! * `success` - if no problem was found
! * `alloc_fault` - if it failed during allocation of memory for `self`, or
! * `array_size_invalid_error` if the `bits(self)` in `unit` is negative
!   or greater than 64 for a `bitset_64` input.
! * `read_failure` - if it failed during the reads from `unit`
!
        class(bitset_large), intent(out) :: self
        integer, intent(in)              :: unit
        integer, intent(out), optional   :: status

        integer(bits_kind)      :: bits
        integer                 :: ierr
        character(len=120)      :: message
        character(*), parameter :: procedure = 'INPUT'
        integer                 :: stat

        read(unit, iostat=ierr, iomsg=message) bits
        if (ierr /= 0) then
            call error_handler( 'Failure on a READ statement for UNIT.', &
                                read_failure, status, module_name, procedure )
            return
        end if

        if ( bits < 0 ) then
            call error_handler( 'BITS in UNIT had a negative value.', &
                                array_size_invalid_error, status,     &
                                module_name, procedure )
            return
        end if

        call self % init(bits, stat)
        if (stat /= success) then
            call error_handler( 'Allocation failure for SELF.', &
                                alloc_fault, status, module_name, procedure )
            return
        end if

        if (bits < 1) return

        read(unit, iostat=ierr, iomsg=message) self % blocks(:)
        if (ierr /= 0) then
            call error_handler( 'Failure on a READ statement for UNIT.', &
                                read_failure, status, module_name, procedure )
            return
        end if

        if ( present(status) ) status = success

    end subroutine input_large

    elemental module function le_large(set1, set2) result(le)
!
!     Returns .TRUE. if the bits in SET1 and SET2 are the same or the
!     highest order different bit is set to 0 in SET1 and to 1 in set2.
!     .FALSE.  otherwise.  The sets must have the same number of bits
!     otherwise the results are undefined.
!
        logical                        :: le
        type(bitset_large), intent(in) :: set1, set2

        integer(bits_kind) :: block_

        do block_ = size(set1 % blocks, kind=bits_kind), 1_bits_kind, -1
            if ( set1 % blocks(block_) == set2 % blocks(block_) ) then
                cycle
            else if ( blt( set1 % blocks(block_), &
                           set2 % blocks(block_) ) ) then
                le = .true.
                return
            else
                le = .false.
                return
            end if
        end do

        le = .true.

    end function le_large

    elemental module function lt_large(set1, set2) result(lt)
!
!     Returns .TRUE. if the bits in SET1 and SET2 differ and the
!     highest order different bit is set to 0 in SET1 and to 1 in set2.
!     .FALSE.  otherwise.  The sets must have the same number of bits
!     otherwise the results are undefined.
!
        logical                        :: lt
        type(bitset_large), intent(in) :: set1, set2

        integer(bits_kind) :: block_

        do block_ = size(set1 % blocks, kind=bits_kind), 1_bits_kind, -1
            if ( set1 % blocks(block_) == set2 % blocks(block_) ) then
                cycle
            else if ( blt( set1 % blocks(block_), &
                           set2 % blocks(block_) ) ) then
                lt = .true.
                return
            else
                lt = .false.
                return
            end if
        end do
        lt = .false.

    end function lt_large

    elemental module function neqv_large(set1, set2) result(neqv)
!
!     Returns .TRUE. if any bits in SET1 and SET2 differ in  value,
!     .FALSE.  otherwise. The sets must have the same number of bits
!     otherwise the results are undefined.
!
        logical                        :: neqv
        type(bitset_large), intent(in) :: set1, set2

        integer(bits_kind) :: block_

        neqv = .true.
        do block_ = 1_bits_kind, size(set1 % blocks, kind=bits_kind)
            if ( set1 % blocks(block_) /= set2 % blocks(block_) ) return
        end do
        neqv = .false.

    end function neqv_large

    elemental module function none_large(self) result(none)
!
!     Returns .TRUE. if none of the bits in SELF have the value 1.
!
        logical ::  none
        class(bitset_large), intent(in) :: self

        integer(bits_kind) :: block

        none = .true.
        do block = 1_bits_kind, size(self % blocks, kind=bits_kind)
            if (self % blocks(block) /= 0) then
                none = .false.
                return
            end if
        end do

    end function none_large

    elemental module subroutine not_large(self)
!
!     Sets the bits in SELF to their logical complement
!
        class(bitset_large), intent(inout) :: self

        integer(bits_kind) :: bit, full_blocks, block
        integer :: remaining_bits

        if ( self % num_bits == 0 ) return
        full_blocks = self % num_bits  / block_size
        do block = 1_bits_kind, full_blocks
            self % blocks(block) = not( self % blocks(block) )
        end do
        remaining_bits = self % num_bits - full_blocks * block_size

        do bit=0, remaining_bits - 1
            if ( btest( self % blocks( block ), bit ) ) then
                self % blocks( block ) = ibclr( self % blocks(block), bit )
            else
                self % blocks( block ) = ibset( self % blocks(block), bit )
            end if
        end do

    end subroutine not_large

    elemental module subroutine or_large(set1, set2)
!
!     Sets the bits in SET1 to the bitwise OR of the original bits in SET1
!     and SET2. SET1 and SET2 must have the same number of bits otherwise
!     the result is undefined.
!
        type(bitset_large), intent(inout) :: set1
        type(bitset_large), intent(in)    :: set2

        integer(bits_kind) :: block_

        do block_ = 1, size( set1 % blocks, kind=bits_kind )
            set1 % blocks(block_) = ior( set1 % blocks(block_), &
                                         set2 % blocks(block_) )
        end do

    end subroutine or_large

    module subroutine output_large(self, unit, status)
!
!     Writes the components of the bitset, SELF, to the unformatted I/O
!     unit, UNIT, in a unformatted sequence compatible with INPUT. If
!     STATUS is absent an error results in an error stop with an
!     informative stop code. If STATUS is present it has the default
!     value of SUCCESS, or the value WRITE_FAILURE if the write failed.
!
        class(bitset_large), intent(in) :: self
        integer, intent(in)             :: unit
        integer, intent(out), optional  :: status

        integer                 :: ierr
        character(len=120)      :: message
        character(*), parameter :: procedure = "OUTPUT"

        write(unit, iostat=ierr, iomsg=message) self % num_bits
        if (ierr /= 0) go to 999

        if (self % num_bits < 1) return
        write(unit, iostat=ierr, iomsg=message) self % blocks(:)
        if (ierr /= 0) go to 999

        return

999     call error_handler( 'Failure on a WRITE statement for UNIT.', &
                            write_failure, status, module_name, procedure )

    end subroutine output_large

    module subroutine read_bitset_string_large(self, string, status)
!
!     Uses the bitset literal in the default character `string`, to define
!     the bitset, `self`. The literal may be preceded by an an arbitrary
!     sequence of blank characters. If `status` is absent an error results
!     in an error stop with an informative stop code. If `status`
!     is present it has one of the values
!     * `success` - if no problems occurred,
!     * `alloc_fault` - if allocation of memory for SELF failed,
!     * `array_size_invalid_error - if `bits(self)` in `string` is greater
!       than 64 for a `bitset_64`,
!     * `char_string_invalid_error` - if the bitset literal has an invalid
!       character,
!     * `char_string_too_small_error - if the string ends before all the bits
!       are read.
!     * `integer_overflow_error` - if the bitset literal has a `bits(self)`
!       value too large to be represented,
!
        class(bitset_large), intent(out) :: self
        character(len=*), intent(in)    :: string
        integer, intent(out), optional  :: status

        integer(bits_kind)      :: bit, bits
        integer(bits_kind)      :: digits, pos
        character(*), parameter :: procedure = "READ_BITSET"
        integer                 :: stat

        pos = 1
        find_start: do pos=1_bits_kind, len(string, kind=bits_kind)
            if ( string(pos:pos) /= ' ' ) exit
        end do find_start

        if ( pos > len(string) - 8 ) go to 999

        if ( string(pos:pos) /= 's' .AND. string(pos:pos) /= 'S' ) go to 999

        pos = pos + 1
        bits = 0
        digits = 0

        do
            select case( iachar( string(pos:pos) ) )
            case(ia0:ia9)
                digits = digits + 1
                if ( digits == max_digits .AND. bits > overflow_bits ) go to 996
                if ( digits > max_digits ) go to 996
                bits = bits*10 + iachar( string(pos:pos) ) - ia0
                if ( bits < 0 ) go to 996
            case(iachar('b'), iachar('B'))
                exit
            case default
                call error_handler( 'There was an invalid character ' // &
                                    'in STRING',                         &
                                    char_string_invalid_error, status,   &
                                    module_name, procedure )
                return
            end select

            pos = pos + 1
        end do

        if ( bits + pos > len(string) ) then
            call error_handler( 'STRING was too small for the number of ' // &
                                'bits specified by STRING.',                 &
                                char_string_too_small_error, status,         &
                                module_name, procedure )
            return
        end if
        call self % init( bits, stat )
        if (stat /= success) then
            call error_handler( 'There was an allocation fault for SELF.', &
                                alloc_fault, status, module_name, procedure )
            return
        end if

        pos = pos + 1
        bit = bits - 1
        do
            if ( string(pos:pos) == '0' ) then
                call self % clear( bit )
            else if ( string(pos:pos) == '1' ) then
                call self % set( bit )
            else
                go to 999
            end if
            pos = pos + 1
            bit = bit - 1
            if ( bit < 0 ) exit
        end do

        if ( present(status) ) status = success

        return

996     call error_handler( 'There was an integer overflow in reading' // &
                            'size of bitset literal from UNIT',           &
                            integer_overflow_error, status,               &
                            module_name, procedure )
        return

999     call error_handler( 'There was an invalid character in STRING', &
                            char_string_invalid_error, status,          &
                            module_name, procedure )

    end subroutine read_bitset_string_large

    module subroutine read_bitset_unit_large(self, unit, advance, status)
!
!     Uses the bitset literal at the current position in the formatted
!     file with I/O unit, `unit`, to define the bitset, `self`. The literal
!     may be preceded by an arbitrary sequence of blank characters.
!     If `advance` is present it must be either 'YES' or 'NO'. If absent
!     it has the default value of 'YES' to determine whether advancing
!     I/O occurs. If `status` is absent an error results in an error stop
!     with an informative stop code. If `status` is present it has one of
!     the values:
!     * `success` - if no problem occurred,
!     * `alloc_fault` - if allocation of `self` failed,
!     * `array_size_invalid_error` - if `bits(self)` in the bitset literal
!       is greater than 64 for a `bitset_64`.
!     * `char_string_invalid_error` - if the read of the bitset literal found
!       an invalid character,
!     * `eof_failure` - if a `read` statement reaches an end-of-file before
!       completing the read of the bitset literal,
!     * `integer_overflow_error` - if the bitset literal has a `bits(self)`
!       value too large to be represented,
!     * `read_failure` - if a `read` statement fails,
!
        class(bitset_large), intent(out)   :: self
        integer, intent(in)                :: unit
        character(*), intent(in), optional :: advance
        integer, intent(out), optional     :: status

        integer(bits_kind)            :: bit, bits, digits
        integer                       :: ierr
        character(len=128)            :: message
        character(*), parameter       :: procedure = "READ_BITSET"
        character(len=1)              :: char

        do
            read( unit,         &
                  advance='NO', &
                  FMT='(A1)',   &
                  err=997,      &
                  end=998,      &
                  iostat=ierr,  &
                  iomsg=message ) char
            select case( char )
            case( ' ' )
                cycle
            case( 's', 'S' )
                exit
            case default
                go to 999
            end select
        end do

        bits = 0
        digits = 0
        do
            read( unit,         &
                  advance='NO', &
                  FMT='(A1)',   &
                  err=997,      &
                  end=998,      &
                  iostat=ierr,  &
                  iomsg=message ) char
            if ( char == 'b' .or. char == 'B' ) exit
            select case( char )
            case( '0', '1', '2', '3', '4', '5', '6', '7', '8', '9' )
                digits = digits + 1
                if (  digits == max_digits .AND. bits > overflow_bits ) &
                    go to 996
                if ( digits > max_digits ) go to 996
                bits = 10*bits + iachar(char) - iachar('0')
                if ( bits < 0 ) go to 996
            case default
                go to 999
            end select
        end do

        if ( bits < 0 .OR. digits == 0 .OR. digits > max_digits ) go to 999

        call self % init( bits, status )
        if ( present(status) ) then
            call error_handler( 'There was an allocation fault for SELF.', &
                                alloc_fault, status, module_name, procedure )
            return
        end if
        do bit = 1, bits-1
            read( unit,         &
                  advance='NO', &
                  FMT='(A1)',   &
                  err=997,      &
                  end=998,      &
                  iostat=ierr,  &
                  iomsg=message ) char
            if ( char == '0' ) then
                call self % clear( bits-bit )
            else if ( char == '1' ) then
                call self % set( bits-bit )
            else
                go to 999
            end if
        end do

        read( unit,                           &
              advance=optval(advance, 'YES'), &
              FMT='(A1)',                     &
              err=997,                        &
              end=998,                        &
              iostat=ierr,                    &
              iomsg=message ) char

        if ( char == '0' ) then
            call self % clear( bits-bit )
        else if ( char == '1' ) then
            call self % set( bits-bit )
        else
            go to 999
        end if

        if ( present(status) ) status = success

        return

996     call error_handler( 'Integer overflow in reading size of ' // &
                            'bitset literal from UNIT.',              &
                            read_failure, status, module_name, procedure )
        return

997     call error_handler( 'Failure on read of UNIT.',                   &
                            read_failure, status, module_name, procedure )
        return

998     call error_handler( 'End of File of UNIT before finishing a ' // &
                            'bitset literal.',                           &
                            eof_failure, status, module_name, procedure )
        return

999     call error_handler( 'Invalid character in bitset literal in UNIT ', &
                            char_string_invalid_error, status,              &
                            module_name, procedure )

    end subroutine read_bitset_unit_large

    elemental module subroutine set_bit_large(self, pos)
!
!     Sets the value at the POS position in SELF, provided the position is
!     valid. If the position is less than 0 or greater than BITS(SELF)-1
!     then SELF is unchanged.
!
        class(bitset_large), intent(inout) :: self
        integer(bits_kind), intent(in)     :: pos

        integer(bits_kind) :: set_block, block_bit

        if ( pos < 0 .OR. pos > self % num_bits-1 ) return

        set_block = pos / block_size + 1
        block_bit = pos - (set_block - 1) * block_size
        self % blocks(set_block) = ibset( self % blocks(set_block), block_bit )

    end subroutine set_bit_large

    pure module subroutine set_range_large(self, start_pos, stop_pos)
!
!     Sets all valid bits to 1 from the START_POS to the STOP_POS positions
!     in SELF. If STOP_POA < START_POS no bits are changed. Positions outside
!     the range 0 to BITS(SELF)-1 are ignored.
!
        class(bitset_large), intent(inout) :: self
        integer(bits_kind), intent(in) :: start_pos, stop_pos

        integer(bits_kind) :: bit, block_, end_bit, first_block, last_block, &
                              start_bit

        start_bit = max( 0_bits_kind, start_pos )
        end_bit   = min( stop_pos, self % num_bits-1 )
        if ( end_bit < start_bit ) return

        first_block = start_bit / block_size + 1
        last_block  = end_bit / block_size + 1
        if ( first_block == last_block ) then
!         FIRST and LAST are in the same block
            call mvbits( all_ones,                               &
                         start_bit - (first_block-1)*block_size, &
                         end_bit - start_bit + 1,                &
                         self % blocks(first_block),             &
                         start_bit - (first_block-1)*block_size )
            return
        end if

!     Do "partial" black containing FIRST
        bit = start_bit - (first_block-1)*block_size
        call mvbits( all_ones,                   &
                     bit,                        &
                     block_size - bit,           &
                     self % blocks(first_block), &
                     bit )

!     Do "partial" black containing LAST
        bit = end_bit - (last_block-1)*block_size
        call mvbits( all_ones,                  &
                     0,                         &
                     bit+1,                     &
                     self % blocks(last_block), &
                     0 )

! Do remaining blocks
        do block_ = first_block+1, last_block-1
            self % blocks(block_) = all_ones
        end do

    end subroutine set_range_large

    elemental module function test_large(self, pos) result(test)
!
!     Returns .TRUE. if the POS position is set, .FALSE. otherwise. If POS
!     is negative or greater than BITS(SELF) - 1 the result is .FALSE..
!
        logical ::  test
        class(bitset_large), intent(in)    :: self
        integer(bits_kind), intent(in) :: pos

        integer(bits_kind) :: bit_block

        if ( pos < 0 .or. pos >= self % num_bits ) then
            test = .false.
        else
            bit_block = pos / block_size + 1
            test = btest( self % blocks(bit_block), &
                          pos - ( bit_block-1 ) * block_size )
        end if

    end function test_large

    module subroutine to_string_large(self, string, status)
!
!     Represents the value of SELF as a binary literal in STRING
!     Status may have the values SUCCESS or ALLOC_FAULT
!
        class(bitset_large), intent(in)            :: self
        character(len=:), allocatable, intent(out) :: string
        integer, intent(out), optional             :: status

        character(*), parameter :: procedure = 'TO_STRING'
        integer(bits_kind) :: bit, bit_count, pos
        integer :: stat

        bit_count = self % num_bits
        allocate( character(len=bit_count)::string, stat=stat )
        if ( stat > 0 ) then
            call error_handler( 'There was an allocation fault for STRING.', &
                                alloc_fault, status, module_name, procedure )
            return
        end if
        do bit=0_bits_kind, bit_count-1
            pos = bit_count - bit
            if ( self % test( bit) ) then
                string( pos:pos ) = '1'
            else
                string( pos:pos ) = '0'
            end if
        end do

        if ( present(status) ) status = success

    end subroutine to_string_large

    elemental module function value_large(self, pos) result(value)
!
!     Returns 1 if the POS position is set, 0 otherwise. If POS is negative
!     or greater than BITS(SELF) - 1 the result is 0.
!
        integer ::  value
        class(bitset_large), intent(in) :: self
        integer(bits_kind), intent(in)  :: pos

        integer :: bit_block

        if ( pos < 0 .or. pos >= self % num_bits ) then
            value = 0
        else
            bit_block = pos / block_size + 1
            if ( btest( self % blocks(bit_block), &
                pos - ( bit_block-1 ) * block_size ) ) then
                value = 1
            else
                value = 0
            end if
        end if

    end function value_large

    module subroutine write_bitset_string_large(self, string, status)
!
!     Writes a bitset literal to the allocatable default character STRING,
!     representing the individual bit values in the bitset_t, SELF.
!     If STATUS is absent an error results in an error stop with an
!     informative stop code. If STATUS is present it has the default
!     value of SUCCESS, or the value ALLOC_FAULT if allocation of
!     the output string failed.
!
        class(bitset_large), intent(in)            :: self
        character(len=:), allocatable, intent(out) :: string
        integer, intent(out), optional             :: status

        integer(bits_kind) :: bit,          &
                              bit_count,    &
                              count_digits, &
                              pos
        integer :: stat

        character(*), parameter :: procedure = 'WRITE_BITSET'

        bit_count = bits(self)

        call digit_count( self % num_bits, count_digits )

        allocate( character(len=count_digits+bit_count+2)::string, stat=stat )
        if ( stat > 0 ) then
            call error_handler( 'There was an allocation fault for STRING.', &
                                alloc_fault, status, module_name, procedure )
            return
        end if

        write( string, "('S', i0)" ) self % num_bits

        string( count_digits + 2:count_digits + 2 ) = "B"
        do bit=0_bits_kind, bit_count-1
            pos = count_digits + 2 + bit_count - bit
            if ( self % test( bit) ) then
                string( pos:pos ) = '1'
            else
                string( pos:pos ) = '0'
            end if
        end do

        if ( present(status) ) status = success

    contains

        subroutine digit_count( bits, digits )
            integer(bits_kind), intent(in)  :: bits
            integer(bits_kind), intent(out) :: digits

            integer(bits_kind) :: factor

            factor = bits

            if ( factor <= 0 ) then
                digits = 1
                return
            end if

            do digits = 1, 127
                factor = factor / 10
                if ( factor == 0 ) return
            end do

        end subroutine digit_count

    end subroutine write_bitset_string_large

    module subroutine write_bitset_unit_large(self, unit, advance, status)
!
!     Writes a bitset literal to the I/O unit, UNIT, representing the
!     individual bit values in the bitset_t, SELF. By default or if
!     ADVANCE is present with the value 'YES', advancing output is used.
!     If ADVANCE is present with the value 'NO', then the current record
!     is not advanced by the write. If STATUS is absent an error results
!     in an error stop with an informative stop code. If STATUS is
!     present it has the default value of SUCCESS, the value
!     ALLOC_FAULT if allocation of the output string failed, or
!     WRITE_FAILURE if the WRITE statement outputting the literal failed.
!
        class(bitset_large), intent(in)        :: self
        integer, intent(in)                    :: unit
        character(len=*), intent(in), optional :: advance
        integer, intent(out), optional         :: status

        integer                   :: ierr
        character(:), allocatable :: string
        character(len=120)        :: message
        character(*), parameter   :: procedure = "WRITE_BITSET"

        call self % write_bitset(string, status)

        if ( present(status) ) then
            if (status /= success ) return
        end if

        write( unit,                           &
               FMT='(A)',                      &
               advance=optval(advance, 'YES'), &
               iostat=ierr,                    &
               iomsg=message )                 &
               string
        if (ierr /= 0) then
            call error_handler( 'Failure on a WRITE statement for UNIT.', &
                                write_failure, status, module_name, procedure )
            return
        endif

    end subroutine write_bitset_unit_large

    elemental module subroutine xor_large(set1, set2)
!
!     Sets the bits in SET1 to the bitwise XOR of the original bits in SET1
!     and SET2. SET1 and SET2 must have the same number of bits otherwise
!     the result is undefined.
!
        type(bitset_large), intent(inout) :: set1
        type(bitset_large), intent(in)    :: set2

        integer(bits_kind) :: block_

        do block_ = 1_bits_kind, size(set1 % blocks, kind=bits_kind)
            set1 % blocks(block_) = ieor( set1 % blocks(block_), &
                                          set2 % blocks(block_) )
        end do

    end subroutine xor_large

end submodule stdlib_bitsets_large