      subroutine snom

!!    ~ ~ ~ PURPOSE ~ ~ ~
!!    this subroutine predicts daily snom melt when the average air
!!    temperature exceeds 0 degrees Celcius

!!    ~ ~ ~ INCOMING VARIABLES ~ ~ ~
!!    name         |units         |definition
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~
!!    elevb(:,:)   |m             |elevation at center of band
!!    elevb_fr(:,:)|none          |fraction of subbasin area within elevation
!!                                |band
!!    iida         |julian date   |day being simulated (current julian date)
!!    ihru         |none          |HRU number
!!    pcpband(:,:) |mm H2O        |precipitation for the day in band in HRU
!!    precipday    |mm H2O        |precipitation on the current day in the HRU
!!    sub_sftmp    |deg C         |Snowfall temperature
!!                                |Mean air temperature at which precipitation
!!                                |is equally likely to be rain as snow/freezing
!!                                |rain.
!!    sub_smfmn    |mm/deg C/day  |Minimum melt rate for snow during year (Dec.
!!                                |21) where deg C refers to the air temperature
!!    sub_smfmx    |mm/deg C/day  |Maximum melt rate for snow during year (June
!!                                |21) where deg C refers to the air temperature
!!                                |SMFMX and SMFMN allow the rate of snow melt
!!                                |to vary through the year. These parameters
!!                                |are accounting for the impact of soil
!!                                |temperature on snow melt.
!!    sub_smtmp    |deg C         |Snow melt base temperature
!!                                |Mean air temperature at which snow melt will
!!                                |occur.
!!    sno_hru(:)   |mm H2O        |amount of water in snow in HRU on current day
!!    snocov1      |none          |1st shape parameter for snow cover equation
!!                                |This parameter is determined by solving the
!!                                |equation for 50% snow cover
!!    snocov2      |none          |2nd shape parameter for snow cover equation
!!                                |This parameter is determined by solving the
!!                                |equation for 95% snow cover
!!    snocovmx     |mm H2O        |Minimum snow water content that corresponds
!!                                |to 100% snow cover. If the snow water content
!!                                |is less than SNOCOVMX, then a certain
!!                                |percentage of the ground will be bare.
!!    snoeb(:,:)   |mm H2O        |snow water content in elevation band on
!!                                |current day
!!    snotmp(:)    |deg C         |temperature of snow pack in HRU
!!    snotmpeb(:,:)|deg C         |temperature of snow pack in elevation band
!!    tavband(:,:) |deg C         |average temperature for the day in band in HRU
!!    sub_timp     |none          |Snow pack temperature lag factor (0-1)
!!                                |1 = no lag (snow pack temp=current day air
!!                                |temp) as the lag factor goes to zero, the
!!                                |snow pack's temperature will be less
!!                                |influenced by the current day's air
!!                                |temperature
!!    tmpav(:)     |deg C         |average air temperature on current day for
!!                                |HRU
!!    tmx(:)       |deg C         |maximum air temperature on current day for
!!                                |HRU
!!    tmxband(:,:) |deg C         |maximum temperature for the day in band in HRU
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~

!!    ~ ~ ~ OUTGOING VARIABLES ~ ~ ~
!!    name         |units         |definition
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~
!!    precipday    |mm H2O        |amount of water in effective precipitation
!!                                |in HRU
!!    precipdt(:)  |mm H2O        |precipitation for the time step during day
!!    sno_hru(:)   |mm H2O        |amount of water in snow in HRU on current day
!!    snoeb(:,:)   |mm H2O        |snow water content in elevation band on
!!                                |current day
!!    snofall      |mm H2O        |amount of precipitation falling as freezing
!!                                |rain/snow on day in HRU
!!    snomlt       |mm H2O        |amount of water in snow melt for the day in
!!                                |HRU
!!    snotmp(:)    |deg C         |temperature of snow pack in HRU
!!    snotmpeb(:,:)|deg C         |temperature of snow pack in elevation band
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~

!!    ~ ~ ~ LOCAL DEFINITIONS ~ ~ ~
!!    name        |units         |definition
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~
!!    ib          |none          |counter
!!    j           |none          |HRU number
!!    smfac       |
!!    smleb       |mm H2O        |amount of snow melt in elevation band on
!!                               |current day
!!    smp         |mm H2O        |precipitation on current day for HRU
!!    snocov      |none          |fraction of HRU area covered with snow
!!    sum         |mm H2O        |snow water content in HRU on current day
!!    xx          |none          |ratio of amount of current day's snow water
!!                               |content to the minimum amount needed to
!!                               |cover ground completely
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~

!!    ~ ~ ~ SUBROUTINES/FUNCTIONS CALLED ~ ~ ~
!!    Intrinsic: Real, Sin, Exp

!!    ~ ~ ~ ~ ~ ~ END SPECIFICATIONS ~ ~ ~ ~ ~ ~

      use parm

      integer :: j, ib
      real :: sum, smp, smfac, smleb
      real :: xx, snocov

      j = 0
      j = ihru
      sum =0.
      smp =0.
      isub = hru_sub(j)

      if (elevb(1,isub) > 0. .and. elevb_fr(1,isub) > 0.) then
!! elevation bands
        !! compute snow fall and melt for each elevation band
        do ib = 1, 10
          if (elevb_fr(ib,isub) < 0.) exit
          snotmpeb(ib,j) = snotmpeb(ib,j) * (1.-sub_timp(ib,isub)) +
     &                                tavband(ib,j) * sub_timp(ib,isub)

          if (tavband(ib,j) < sub_sftmp(ib,isub)) then

            !! compute snow fall if temperature is below sftmp
            snoeb(ib,j) = snoeb(ib,j) + pcpband(ib,j)
            snofall = snofall + pcpband(ib,j) * elevb_fr(ib,isub)

          else

            !! compute snow melt if temperature is above smtmp
            if (tmxband(ib,j) > sub_smtmp(ib,isub)) then
              smfac = 0.
              smleb = 0.
              smfac = (sub_smfmx(ib,isub) + sub_smfmn(ib,isub)) / 2. +
     &          Sin((iida - 81) / 58.09) *
     &          (sub_smfmx(ib,isub) - sub_smfmn(ib,isub)) / 2.    !! 365/2pi = 58.09
              smleb = smfac * (((snotmpeb(ib,j) + tmxband(ib,j)) / 2.)
     &                                             - sub_smtmp(ib,isub))

              !! adjust for areal extent of snow cover
              if (snoeb(ib,j) < snocovmx) then
                xx = 0.
                snocov = 0.
                xx = snoeb(ib,j) / snocovmx
                snocov = xx / (xx + Exp(snocov1 - snocov2 * xx))
              else
                snocov = 1.
              endif
              smleb = smleb * snocov
              if (smleb < 0.) smleb = 0.
              if (smleb > snoeb(ib,j)) smleb = snoeb(ib,j)
              snoeb(ib,j) = snoeb(ib,j) - smleb
              snomlt = snomlt + smleb * elevb_fr(ib,isub)
            endif
          endif
          sum = sum + snoeb(ib,j) * elevb_fr(ib,isub)
          smp = smp + pcpband(ib,j) * elevb_fr(ib,isub)

        end do

        !! add/sub aggregate snow fall and melt from effective precip
        !! and snow cover
        precipday = smp + snomlt - snofall
        if (precipday < 0.) precipday = 0.
        if (nstep > 0) then
          do ii = 1, nstep
            precipdt(ii+1) = precipdt(ii+1) + (snomlt - snofall) / nstep
            if (precipdt(ii+1) < 0.) precipdt(ii+1) = 0.
          end do
        end if
        sno_hru(j) = sum

      else
!! no elevation bands

	ib = 1

        !! estimate snow pack temperature
        snotmp(j)=snotmp(j) * (1. - sub_timp(ib,isub)) + tmpav(j) *
     &            sub_timp(ib,isub)

        if (tmpav(j) <= sub_sftmp(ib,isub)) then
          !! calculate snow fall
          sno_hru(j) = sno_hru(j) + precipday
          snofall = precipday
          precipday = 0.
          precipdt = 0.
        endif

        if (tmx(j) > sub_smtmp(ib,isub) .and. sno_hru(j) > 0.) then
          !! adjust melt factor for time of year
          smfac = 0.
          snomlt = 0.
          smfac = (sub_smfmx(ib,isub) + sub_smfmn(ib,isub)) / 2. +
     &       Sin((iida - 81) / 58.09) *
     &       (sub_smfmx(ib,isub) - sub_smfmn(ib,isub)) / 2.    !! 365/2pi = 58.09
          snomlt = smfac * (((snotmp(j)+tmx(j))/2.)-sub_smtmp(ib,isub))

          !! adjust for areal extent of snow cover
          if (sno_hru(j) < snocovmx) then
            xx = 0.
            xx = sno_hru(j) / snocovmx
            snocov = xx / (xx + Exp(snocov1 - snocov2 * xx))
          else
            snocov = 1.
          endif
          snomlt = snomlt * snocov
          if (snomlt < 0.) snomlt = 0.
          if (snomlt > sno_hru(j)) snomlt = sno_hru(j)
          sno_hru(j) = sno_hru(j) - snomlt
          precipday = precipday + snomlt
          if (nstep > 0) then
            do ii = 1, nstep
             precipdt(ii+1) = precipdt(ii+1) + snomlt / nstep
            end do
          end if
          if (precipday < 0.) precipday = 0.
        else
          snomlt = 0.
        end if
      end if
      return
      end


! mpiexec -np 4 bin/Debug/WGFM_test2.exe
program mainWGF_load_error
    use meshread_mod
    use linalg_mod
    use WGFM_matrices
    use spherePEC_mod
    use dipole_functions
    use planewave_sources
    use dipole_mod
    use currents_mod
    use mpi
    implicit none

    real(8), parameter :: pi = 4d0 * atan(1d0)
    complex(8), parameter :: IU = (0d0, 1d0)

    ! Variables
    type(Mesh) :: msh, msh_evl
    complex(8), allocatable :: Uvec(:), Vvec(:)
    complex(8), allocatable :: S1Pot(:, :, :)
    complex(8), allocatable :: D1Pot(:, :, :)
    complex(8), allocatable :: S2Pot(:, :, :)
    complex(8), allocatable :: D2Pot(:, :, :)

    complex(8), allocatable :: ESol(:, :)  ! WGFM electric field solution
    integer :: nEvl

    ! MPI variables
    integer :: ierr, N_procs, id

    ! Parameters
    real(8), parameter :: ep0 = 1d0 / (35950207149.4727056d0 * PI)  ! vacuum permittivity [F/m]
    real(8), parameter :: mu0 = PI * 4d-7                           ! vacuum permeability [H/m]

    real(8), parameter :: mu1 = mu0           ! upper half-space permeability [H/m]
    real(8), parameter :: mu2 = mu0           ! lower half-space permeability [H/m]
    real(8) :: ep1_r         ! upper half-space relative permittivity
    real(8) :: ep2_r         ! lower half-space relative permittivity
    real(8) :: ep1           ! upper half-space permittivity [F/m]
    real(8) :: ep2           ! lower half-space permittivity [F/m]

    real(8) :: w     ! angular frequency [rad/s]
    real(8) :: k0    ! free-space wavenumber [1/m]
    real(8) :: k1    ! upper half-space wavenumber [1/m]
    real(8) :: k2    ! lower half-space wavenumber [1/m]

    character(len=100), parameter :: file_msh = 'meshes/plane_mesh/plane_mesh_a20_h07.msh'
    character(len=100), parameter :: file_currents = 'results/WGFM_currents/plane_mesh_a20_h07.txt'
    character(len=100), parameter :: file_evl_msh = 'meshes/eval_msh/plane_evl_mesh_h013.msh'
    real(8) :: win_radius

    !************************************************************************************
    ! MPI init
    call mpi_init(ierr)
    call mpi_comm_size(MPI_COMM_WORLD, N_procs, ierr)
    call mpi_comm_rank(MPI_COMM_WORLD, id, ierr)
    print *, "Total processes:", N_procs, "Process id:", id

    ! Load mesh
    call load_gmsh(file_msh, msh)

    ! Load currents and data
    call load_msh_currents(file_currents, msh, k1, k2, w,  &
                           ep1_r, ep2_r, win_radius, Uvec, Vvec)
    ep1 = ep0 * ep1_r
    ep2 = ep0 * ep2_r
    k0 = w*sqrt(ep0*mu0)

    ! Set window type and size
    call set_circ_window(win_radius, c_in=0.7d0)

    ! Load eval mesh
    call load_gmsh(file_evl_msh, msh_evl)
    nEvl = size(msh_evl%POS, 1)

    ! Compute WGFM potencials
    if (id == 0) print *, "Pot"
    call genWGFMPot(msh, msh_evl%POS, k1, k2, S1Pot, D1Pot, S2Pot, D2Pot)

    ! Compute WGFM solution
    if (id == 0) then
        ! Adjust constants
        S1Pot = S1Pot * k1**2
        D1Pot = D1Pot * iu*w*mu1

        ! WGFM
        allocate(ESol(nEvl, 3))
        ESol(:,1) = matmul(S1Pot(:,:,1), Vvec) + matmul(D1Pot(:,:,1), Uvec)
        ESol(:,2) = matmul(S1Pot(:,:,2), Vvec) + matmul(D1Pot(:,:,2), Uvec)
        ESol(:,3) = matmul(S1Pot(:,:,3), Vvec) + matmul(D1Pot(:,:,3), Uvec)

        call saveToMesh(ESol, file_evl_msh, "abs_field", 'nodes', 'norm')
    end if

    call MPI_Finalize(ierr)
end program


subroutine qua (p,flux)

!multidimensional quadratic interpolation

use share, only: dp,ndim,indi,npix,n_p,ntot,ntimes,   &
                    f,ee,imap,                        &
		    f_format,f_access,fmtformat

implicit none

!input/output
real(dp),intent(in)	:: p(ndim)	!ndim vector of wanted pars [0-1]
real(dp),intent(out)	:: flux(npix)	!n vector of output flux

!local variables
integer			:: i,j,k,l	!dummy indices
real(dp)		:: t(ndim)	!input p's run 0-1, t's run 1-n_p(i)
real(dp)	 	:: wrk(npix,3**ndim) !(3**ndim) working matrix
real(dp)		:: delta	!t(indi(i))-int(t(indi(i)))
real(dp)                :: omdelta      !1-delta
real(dp)		:: delta3(3)    !array of 3 quanties derived from delta to be
					!passed to qbezier
real(dp)		:: yp		!temporary variable to hold qbezier call output
integer			:: offset(ndim) !offset=0 [-1,0,1], offset=1 [0,1,2]
integer			:: findex(3**ndim)!indices of rows in f needed for
					  !the interpolation

!write(*,*)'in qua'

!	get t's from p's. The p's run between 0-1, while t's run
!	from the min to the max value of the indices of f (1<ti<n_pi)
t(1:ndim)=p(1:ndim)*(n_p(1:ndim)-1)+1.0_dp

offset(1:ndim)=0
if (t(1) < 2) offset(1)=1
do i=2,ndim
	if (t(i) < 2) offset(i)=1
enddo

do i=1,3**ndim
   findex(i)=dot_product(ntimes,int(t(1:ndim))+ee(1:ndim,i)-2+offset(1:ndim))+1
enddo

!load wrk
if (f_access == 0) then
  do i=1,3**ndim
	wrk(1:npix,i)=f(1:npix,findex(imap(i)))
  enddo
else
 !$omp critical
 if (f_format == 0) then
  do i=1,3**ndim
  	read(10,fmtformat,rec=findex(imap(i))) wrk(1:npix,i)
  enddo
 else
  do i=1,3**ndim
  	read(10,rec=findex(imap(i))) wrk(1:npix,i)
  enddo
 endif
 !$omp end critical
endif

!interpolate
do i=1,ndim
	delta=t(indi(i))-int(t(indi(i)))
	omdelta=(1._dp-delta)
	delta3(1)=omdelta**2
	delta3(2)=delta**2
	delta3(3)=2._dp*delta*omdelta
	do j=1,3**(ndim-i)
		do l=1,npix
			call qbezier(wrk(l,3*j-2),wrk(l,3*j-1),wrk(l,3*j),&
				delta3,yp,offset(ndim-i+1))
			wrk(l,j)=yp
		enddo
	enddo
enddo
flux(1:npix)=wrk(1:npix,1)

!write(*,*)'exiting qua'

end subroutine qua


c# gridxy.f
      SUBROUTINE GRIDXY(IX,IY,RLONG,RLAT)
      COMMON /AZEL/ ZTLAT,ZTLON,ZTHT,ZRLAT,ZRLON,ZRHT,ZTAZ,ZRAZ,
     +              ZTELV,ZRELV,ZD,ZDGC,ZTAKOF,ZRAKOF
      COMMON /RGRID/ IPROJ,PLAT,PLON,XMIN,XMAX,YMIN,YMAX,NX,NY
      X=XMIN + FLOAT(IX-1)*(XMAX-XMIN)/FLOAT(NX-1)
      Y=YMIN + FLOAT(IY-1)*(YMAX-YMIN)/FLOAT(NY-1)
      IF(IPROJ.EQ.7) GO TO 70              !  GREAT CIRCLE PROJECTION
      RLONG=X                   !  LAT LONG PROJECTION
      RLAT=Y
      go to 100
70    ZTLAT=PLAT                !  CENTER OF GREAT CIRCLE PROJECTION
      ZTLON=PLON
      if(x.ne.0. .or. y.ne.0.) then
         ZTAZ=90.-ATAN2(Y,X)/.0174533         !  AZIMUTH
         IF(ZTAZ.LT.0.) ZTAZ=ZTAZ+360.
         ZDGC=SQRT(X*X+Y*Y)                   !  GREAT CIRCLE DISTANCE
ccc      write(*,1) ztlat,ztlon,ztaz,zdgc,x,y,ix,iy
ccc1     format(' ztlat,ztlon,ztaz,zdgc=',6f10.2,2i5)
         ZTHT=0.
         ZRHT=0.
         CALL DAZEL1
         RLONG=ZRLON
         RLAT=ZRLAT
      else
ccc      write(*,'("Center of projection  ix,iy=",2i5)') ix,iy
	 rlat=plat                         !  point is center of projection
	 rlong=plon
      end if
c          fix up RLONG so it is between 0 & 360.
100   if(rlong.lt.0.) rlong=rlong+360.
ccc      if(ix.eq.1) WRITE(6,2) Iy,nY,RLONG,RLAT,X,Y,ZTAZ,ZDGC
ccc 2    FORMAT(' GRIDXY=',I5,1h/,I5,2F10.4,2F10.1,F8.1,F8.0)
ccc      if(ix.eq.1) call lineup
      RETURN
      END
C------------------------------------------------------------------


!
! Copyright (C) 2001-2007 Quantum ESPRESSO group
! This file is distributed under the terms of the
! GNU General Public License. See the file `License'
! in the root directory of the present distribution,
! or http://www.gnu.org/copyleft/gpl.txt .
!
!
!----------------------------------------------------------------------
subroutine init_vloc()
  !----------------------------------------------------------------------
  !
  !    This routine computes the fourier coefficient of the local
  !    potential vloc(ig,it) for each type of atom
  !
  USE atom,       ONLY : msh, rgrid
  USE kinds,      ONLY : dp
  USE uspp_param, ONLY : upf
  USE ions_base,  ONLY : ntyp => nsp
  USE cell_base,  ONLY : omega, tpiba2
  USE vlocal,     ONLY : vloc
  USE gvect,      ONLY : ngl, gl
  !
  implicit none
  !
  integer :: nt
  ! counter on atomic types
  !
  call start_clock ('init_vloc')
  vloc(:,:) = 0._dp
  do nt = 1, ntyp
     !
     ! compute V_loc(G) for a given type of atom
     !
     IF ( .NOT. ASSOCIATED ( upf(nt)%vloc ) ) THEN
        !
        ! special case: pseudopotential is coulomb 1/r potential
        !
        call vloc_coul (upf(nt)%zp, tpiba2, ngl, gl, omega, vloc (1, nt) )
        !
     ELSE
        !
        ! normal case
        !
        call vloc_of_g (rgrid(nt)%mesh, msh (nt), rgrid(nt)%rab, rgrid(nt)%r, &
            upf(nt)%vloc(1), upf(nt)%zp, tpiba2, ngl, gl, omega, vloc (1, nt) )
        !
     END IF
  enddo
  call stop_clock ('init_vloc')
  return
end subroutine init_vloc


! -*- F90 -*-
      subroutine hknevolve(x,Q,f)
      implicit none
      integer nq,nx,nd,nff,nset, nhess
      PARAMETER (NQ=33, NX=117, ND=7, NFF=7, nhess=0)
      include 'parmsetup.inc'
      character*16 name(nmxset)
      character*512 setpath
      integer nmem(nmxset),ndef(nmxset),mmem,mem
      common/NAME/name,nmem,ndef,mmem
      double precision gridx(nmxgridx),gridq(nmxgridq)
      integer ngridx,ngridq,jx,jq
      CHARACTER*80 LINE
      double precision pdf(-6:6),x,q,q2
      double precision QG(NQ),XG(NX),PDFG(NX,NQ,ND,0:nhess),DNPDF(-4:4) &
     & ,BXG(NX,NQ,ND,0:nhess), CXG(NX,NQ,ND,0:nhess), DXG(NX,NQ,ND,0:nhess)
      double precision PDFJ1(ND), PDFJ2(ND)
      double precision T,DX
      integer iset,imem
      integer i,j,k,n
      integer iserch
      real*8 f(-6:6)
      real*8 alfas
      real*8 Eorder,Q2fit
      DATA QG / &
     &  1.000000D+00, 1.467799D+00, 2.154435D+00, &
     &  3.162278D+00, 4.641589D+00, 6.812921D+00, &
     &  1.000000D+01, 1.467799D+01, 2.154435D+01, &
     &  3.162278D+01, 4.641589D+01, 6.812921D+01, &
     &  1.000000D+02, 1.778279D+02, 3.162278D+02, 5.623413D+02, &
     &  1.000000D+03, 1.778279D+03, 3.162278D+03, 5.623413D+03, &
     &  1.000000D+04, 1.778279D+04, 3.162278D+04, 5.623413D+04, &
     &  1.000000D+05, 1.778279D+05, 3.162278D+05, 5.623413D+05, &
     &  1.000000D+06, 4.641589D+06, &
     &  1.000000D+07, 4.641589D+07, &
     &  1.000000D+08  /

      DATA XG / &
     &  1.000000D-09, 1.333521D-09, 1.778279D-09, 2.371374D-09, &
     &  3.162278D-09, 4.216965D-09, 5.623413D-09, 7.498942D-09, &
     &  1.000000D-08, 1.333521D-08, 1.778279D-08, 2.371374D-08, &
     &  3.162278D-08, 4.216965D-08, 5.623413D-08, 7.498942D-08, &
     &  1.000000D-07, 1.333521D-07, 1.778279D-07, 2.371374D-07, &
     &  3.162278D-07, 4.216965D-07, 5.623413D-07, 7.498942D-07, &
     &  1.000000D-06, 1.333521D-06, 1.778279D-06, 2.371374D-06, &
     &  3.162278D-06, 4.216965D-06, 5.623413D-06, 7.498942D-06, &
     &  1.000000D-05, 1.333521D-05, 1.778279D-05, 2.371374D-05, &
     &  3.162278D-05, 4.216965D-05, 5.623413D-05, 7.498942D-05, &
     &  1.000000D-04, 1.333521D-04, 1.778279D-04, 2.371374D-04, &
     &  3.162278D-04, 4.216965D-04, 5.623413D-04, 7.498942D-04, &
     &  1.000000D-03, 1.154782D-03, 1.333521D-03, 1.539927D-03, &
     &  1.778279D-03, 2.053525D-03, 2.371374D-03, 2.738420D-03, &
     &  3.162278D-03, 3.651741D-03, 4.216965D-03, 4.869675D-03, &
     &  5.623413D-03, 6.493816D-03, 7.498942D-03, 8.659643D-03, &
     &  1.000000D-02, 1.154782D-02, 1.333521D-02, 1.539927D-02, &
     &  1.778279D-02, 2.053525D-02, 2.371374D-02, 2.738420D-02, &
     &  3.162278D-02, 3.651741D-02, 4.216965D-02, 4.869675D-02, &
     &  5.623413D-02, 6.493816D-02, 7.498942D-02, 8.659643D-02, &
     &  1.000000D-1, 1.250000D-1, 1.500000D-1, 1.750000D-1, &
     &  2.000000D-1, 2.250000D-1, 2.500000D-1, 2.750000D-1, &
     &  3.000000D-1, 3.250000D-1, 3.500000D-1, 3.750000D-1, &
     &  4.000000D-1, 4.250000D-1, 4.500000D-1, 4.750000D-1, &
     &  5.000000D-1, 5.250000D-1, 5.500000D-1, 5.750000D-1, &
     &  6.000000D-1, 6.250000D-1, 6.500000D-1, 6.750000D-1, &
     &  7.000000D-1, 7.250000D-1, 7.500000D-1, 7.750000D-1, &
     &  8.000000D-1, 8.250000D-1, 8.500000D-1, 8.750000D-1, &
     &  9.000000D-1, 9.250000D-1, 9.500000D-1, 9.750000D-1, &
     &  1.000000D+0 /

      save

      call getnset(iset)
      call getnmem(iset,imem)

      DO I=-4,4
        DNPDF(I)=0.D0
      END DO

      q2 = q*q
! CHECK X AND Q2 VALUES.
      IF((X.LT.1.D-9).OR.(X.GT.1.D0)) THEN
        WRITE(*,1030) X
 1030   FORMAT (' ','FF WARNING: OUT OF RANGE --> X =', 1PE12.3)
        STOP
      ENDIF
      IF((Q2.LT.1.D0).OR.(Q2.GT.1.D8)) THEN
        WRITE(*,1040) Q2
 1040   FORMAT (' ','FF WARNING: OUT OF RANGE --> Q2 =', 1PE12.3)
        STOP
      ENDIF

! INTERPOLATION.
! X: CUBIC SPLINE INTERPOLATION, LOG(Q2): LINEAR INTERPOLATION.
      J=ISERCH(NQ,QG,Q2)
      IF(J.EQ.NQ) J=NQ-1
      K=ISERCH(NX,XG,X)
      DO I=1,ND
        DX=X-XG(K)
        PDFJ1(I)=PDFG(K,J,I,0) &
     &       +DX*(BXG(K,J,I,0)+DX*(CXG(K,J,I,0)+DX*DXG(K,J,I,0)))
        PDFJ2(I)=PDFG(K,J+1,I,0) &
     &       +DX*(BXG(K,J+1,I,0)+DX*(CXG(K,J+1,I,0)+DX*DXG(K,J+1,I,0)))

      ENDDO

! -- Nuclear PDF functions --
      T=(DLOG(Q2)-DLOG(QG(J)))/(DLOG(QG(J+1))-DLOG(QG(J)))
      f(0)=(1.D0-T)*PDFJ1(1)+T*PDFJ2(1)     ! g
      f(1)=(1.D0-T)*PDFJ1(3)+T*PDFJ2(3)     ! d
      f(2)=(1.D0-T)*PDFJ1(2)+T*PDFJ2(2)     ! u
      f(-1)=(1.D0-T)*PDFJ1(5)+T*PDFJ2(5)     ! db
      f(-2)=(1.D0-T)*PDFJ1(4)+T*PDFJ2(4)     ! ub
      f(-3)=(1.D0-T)*PDFJ1(6)+T*PDFJ2(6)     ! sb
      f(4)=(1.D0-T)*PDFJ1(7)+T*PDFJ2(7) !  c
      f(3)=f(-3) ! s=sb
      f(-4)=f(4) ! cb=c
      return

!
!cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
!
      entry hkngetgrid(nset,ngridx,ngridq,gridx,gridq)

      ngridx=NX
      do jx=1,ngridx
          gridx(jx)=XG(jx)
      enddo
      ngridq=NQ
      do jq=1,ngridq
          gridq(jq)=QG(jq)
      enddo

      return

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
      entry hknread(nset)
  !dummy read to get to the End: (stream 1 is still open)

      read(1,*)nmem(nset),ndef(nset)

      do n=0,nmem(nset)
        DO J=1,NQ
          DO K=1,NX-1
            READ(1,'(a)') line
          ENDDO
        ENDDO
      enddo

      return
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
      entry hknalfa(alfas,Q)
!        call alphamrs(4,alfas,q)
        call alphahkn(q,alfas)
      return
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
      entry hkninit(nset,Eorder,Q2fit)
      return
!
 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
      entry hknpdf(mem)

    call getnset(iset)
    call setnmem(iset,mem)

  ! here is the real read!!

  ! have to reopen stream 1
  call getsetpath(setpath)
  open(1,file=setpath(1:len_trim(setpath)),action='READ')

  line = ''
  do while (line(2:11).ne.'Evolution:')
     read(1,'(a)'),line
  enddo
  read(1,'(a)'),line
  read(1,'(a)'),line

  read(1,*)nmem(iset),ndef(iset)
  ! - dummy read up to the member requested
  do i=0,mem-1
     do j=1,nq
        do k=1,nx-1
           read(1,'(a)')line
        enddo
     enddo
  enddo
  !   Now read in the grids from the grid file.
      DO J=1,NQ
        DO K=1,NX-1
          READ(1,1025) (PDFG(K,J,I,0), I=1,NFF)
!         print *,
        ENDDO
      ENDDO
      DO I=1,ND
        DO J=1,NQ
          PDFG(NX,J,I,0)=0.D0 ! x=1 NPDF=0.D0
          CALL LSPLINE(NX,XG,PDFG,BXG,CXG,DXG,ISET,I,J,0)
        ENDDO
      ENDDO

      close(1)

 1025 FORMAT(1X,7(1PE14.6))

      return
!
      END
! ---------------------------------------------------------------------
      SUBROUTINE LSPLINE(N,X,Y,B,C,D,ISET,I,J,nmem)
! ---------------------------------------------------------------------
! CALCULATE THE COEFFICIENTS B,C,D IN A CUBIC SPLINE INTERPOLATION.
! INTERPOLATION SUBROUTINES ARE TAKEN FROM
! G.E. FORSYTHE, M.A. MALCOLM AND C.B. MOLER,
! COMPUTER METHODS FOR MATHEMATICAL COMPUTATIONS (PRENTICE-HALL, 1977).
      IMPLICIT REAL*8(A-H,O-Z)
      PARAMETER (NQ=33, NX=117, ND=7, nhess=12)
      DIMENSION Y(NX,NQ,ND,0:nhess),B(NX,NQ,ND,0:nhess),C(NX,NQ,ND,0:nhess),D(NX,NQ,ND,0:nhess) &
     &         ,X(NX)
      NM1=N-1
      IF(N.LT.2) RETURN
      IF(N.LT.3) GO TO 250
      D(1,J,I,nmem)=X(2)-X(1)
      C(2,J,I,nmem)=(Y(2,J,I,nmem)-Y(1,J,I,nmem))/D(1,J,I,nmem)
      DO 210 K=2,NM1
        D(K,J,I,nmem)=X(K+1)-X(K)
        B(K,J,I,nmem)=2.0D0*(D(K-1,J,I,nmem)+D(K,J,I,nmem))
        C(K+1,J,I,nmem)=(Y(K+1,J,I,nmem)-Y(K,J,I,nmem))/D(K,J,I,nmem)
        C(K,J,I,nmem)=C(K+1,J,I,nmem)-C(K,J,I,nmem)
  210 CONTINUE
      B(1,J,I,nmem)=-D(1,J,I,nmem)
      B(N,J,I,nmem)=-D(N-1,J,I,nmem)
      C(1,J,I,nmem)=0.0D0
      C(N,J,I,nmem)=0.0D0
      IF(N.EQ.3) GO TO 215
      C(1,J,I,nmem)=C(3,J,I,nmem)/(X(4)-X(2))-C(2,J,I,nmem)/(X(3)-X(1))
      C(N,J,I,nmem)=C(N-1,J,I,nmem)/(X(N)-X(N-2))-C(N-2,J,I,nmem)/(X(N-1)-X(N-3))
      C(1,J,I,nmem)=C(1,J,I,nmem)*D(1,J,I,nmem)**2.0D0/(X(4)-X(1))
      C(N,J,I,nmem)=-C(N,J,I,nmem)*D(N-1,J,I,nmem)**2.0D0/(X(N)-X(N-3))
  215 CONTINUE
      DO 220 K=2,N
        T=D(K-1,J,I,nmem)/B(K-1,J,I,nmem)
        B(K,J,I,nmem)=B(K,J,I,nmem)-T*D(K-1,J,I,nmem)
        C(K,J,I,nmem)=C(K,J,I,nmem)-T*C(K-1,J,I,nmem)
  220 CONTINUE
      C(N,J,I,nmem)=C(N,J,I,nmem)/B(N,J,I,nmem)
      DO 230 IB=1,NM1
        K=N-IB
        C(K,J,I,nmem)=(C(K,J,I,nmem)-D(K,J,I,nmem)*C(K+1,J,I,nmem))/B(K,J,I,nmem)
  230 CONTINUE
      B(N,J,I,nmem)=(Y(N,J,I,nmem)-Y(NM1,J,I,nmem))/D(NM1,J,I,nmem) &
     &        +D(NM1,J,I,nmem)*(C(NM1,J,I,nmem)+2.0D0*C(N,J,I,nmem))
      DO 240 K=1,NM1
        B(K,J,I,nmem)=(Y(K+1,J,I,nmem)-Y(K,J,I,nmem))/D(K,J,I,nmem) &
     &          -D(K,J,I,nmem)*(C(K+1,J,I,nmem)+2.0D0*C(K,J,I,nmem))
        D(K,J,I,nmem)=(C(K+1,J,I,nmem)-C(K,J,I,nmem))/D(K,J,I,nmem)
        C(K,J,I,nmem)=3.0D0*C(K,J,I,nmem)
  240 CONTINUE
      C(N,J,I,nmem)=3.0D0*C(N,J,I,nmem)
      D(N,J,I,nmem)=D(N-1,J,I,nmem)
      RETURN
  250 CONTINUE
      B(1,J,I,nmem)=(Y(2,J,I,nmem)-Y(1,J,I,nmem))/(X(2)-X(1))
      C(1,J,I,nmem)=0.0D0
      D(1,J,I,nmem)=0.0D0
      B(2,J,I,nmem)=B(1,J,I,nmem)
      C(2,J,I,nmem)=0.0D0
      D(2,J,I,nmem)=0.0D0
      RETURN
      END
! ---------------------------------------------------------------------
      INTEGER FUNCTION ISERCH(N,X,Y)
! ---------------------------------------------------------------------
! THIS FUNCTION SEARCHES "I" WHICH SATISFIES THE RELATION
! X(I) <= Y < X(I+1) BY USING A BINARY SEARCH.
      IMPLICIT REAL*8(A-H,O-Z)
      DIMENSION X(117)

      MIN=1
      MAX=N+1

   10 CONTINUE
      MID=(MIN+MAX)/2
      IF(Y.LT.X(MID)) THEN
        MAX=MID
      ELSE
        MIN=MID
      END IF
      IF((MAX-MIN).GT.1) GO TO 10

      ISERCH=MIN

      RETURN
      END
! *********************************************************************
! THE END OF THE PROGRAM.
! *********************************************************************
! ---------------------------------------------------------------------
!  IN: Q2=Q^2 [GeV^2], IORDER=1:LO, 2:NLO
! OUT: Alpha_s
!
      SUBROUTINE alphahkn(Q,ALPHA_S)
! ---------------------------------------------------------------------
! RUNNING COUPLING CONSTANTS.
      IMPLICIT REAL*8(A-H,O-Z)
      DATA DLAML,DLAMN/0.174D0, 0.3D0/
!      DATA THRE4,THRE5/1.35D0, 4.3D0/
      DATA THRE4,THRE5/1.35D0, 1.D+6/

      call getnset(nset)
      call GetOrderAsM(nset,iord)
      q2 = q*q
      iorder = iord + 1

      PI=4.D0*DATAN(1.D0)
      CTHRE=THRE4*THRE4
      BTHRE=THRE5*THRE5
      CF=4.D0/3.D0
      CG=3.D0
      TR=1.D0/2.D0

! Changing the number of the quark flavor at heavy quark mass threshold
      Q2thr=Q2
      IF(Q2thr.LT.CTHRE) F=3.D0
      IF((Q2thr.GE.CTHRE).AND.(Q2thr.LT.BTHRE)) F=4.D0
      IF(Q2thr.GE.BTHRE) F=5.D0

      B0=11.D0/3.D0*CG-4.D0/3.D0*TR*F
      B1=34.D0/3.D0*CG*CG-10.D0/3.D0*CG*F-2.D0*CF*F

! Changing Lambda_QCD for connecting alpah_s at the threshold
      IF(Q2thr.LT.CTHRE) then      ! Lambda_QCD (4to3)
        DLAMF=DLAML*(DSQRT(CTHRE)/DLAML)**(2.D0/3.D0/B0)
        DLAMFN=DLAMN*(DSQRT(CTHRE)/DLAMN)**(2.D0/27.D0) &
     &        *DLOG(CTHRE/(DLAMN*DLAMN))**(107.D0/2025.D0)

      ELSE IF((Q2thr.GE.CTHRE).AND.(Q2thr.LT.BTHRE)) then
        DLAMF=DLAML
        DLAMFN=DLAMN

      ELSE IF(Q2thr.GE.BTHRE) Then ! Lambda_QCD (4to5)
        DLAMF=DLAML*(DSQRT(BTHRE)/DLAML)**(-2.D0/3.D0/B0)
        DLAMFN=DLAMN*(DLAMN/DSQRT(BTHRE))**(2.D0/23.D0) &
     &        *DLOG(BTHRE/(DLAMN*DLAMN))**(-963.D0/13225.D0)
      END IF

! Calculating alpha_s(Q^2)
      IF(IORDER.EQ.2) DLAMF=DLAMFN
      DLNLAM=DLOG(DLAMF*DLAMF)
      DLNQ2=DLOG(Q2)-DLNLAM

      ALPHA=4.D0*PI/B0/DLNQ2    ! LO
      IF(IORDER.EQ.2) THEN      ! NLO
        ALPHA=ALPHA*(1.D0-B1*DLOG(DLNQ2)/(B0*B0*DLNQ2))
      END IF

      ALPHA_S=ALPHA

      RETURN
      END
! ---------------------------------------------------------------------


      subroutine asithf (y, x, strnrm, ien, fres, shgl, shp, Qwtf)

      include "common.h"

      dimension y(nshg,ndof),            fres(nshg,24)
      dimension x(numnp,nsd),            xl(npro,nenl,nsd)
      dimension ien(npro,nshl),        ycl(npro,nshl,ndof),
     &          fresl(npro,24),        WdetJ(npro),
     &          u1(npro),              u2(npro),
     &          u3(npro),              dxdxi(npro,nsd,nsd),
     &          strnrm(npro,maxsh),    dxidx(npro,nsd,nsd),
     &          shgl(nsd,nshl,maxsh),       shg(npro,nshl,nsd),
     &          shp(nshl,maxsh),
     &          fresli(npro,24),       Qwtf(ngaussf)

      dimension tmp(npro)

      call localy (y,      ycl,     ien,    5,  'gather  ')
      call localx (x,      xl,     ien,    3,  'gather  ')
c

      if(matflg(1,1).eq.0) then ! compressible
         ycl (:,:,1) = ycl(:,:,1) / (Rgas * ycl(:,:,5)) !get density
      else
         ycl(:,:,1) = one ! Even if density non unity, it would cancel out
      endif

      fresl = zero

      do intp = 1, ngaussf

c  calculate the metrics
c
c
c.... --------------------->  Element Metrics  <-----------------------
c
c.... compute the deformation gradient
c
        dxdxi = zero
c
          do n = 1, nenl
            dxdxi(:,1,1) = dxdxi(:,1,1) + xl(:,n,1) * shgl(1,n,intp)
            dxdxi(:,1,2) = dxdxi(:,1,2) + xl(:,n,1) * shgl(2,n,intp)
            dxdxi(:,1,3) = dxdxi(:,1,3) + xl(:,n,1) * shgl(3,n,intp)
            dxdxi(:,2,1) = dxdxi(:,2,1) + xl(:,n,2) * shgl(1,n,intp)
            dxdxi(:,2,2) = dxdxi(:,2,2) + xl(:,n,2) * shgl(2,n,intp)
            dxdxi(:,2,3) = dxdxi(:,2,3) + xl(:,n,2) * shgl(3,n,intp)
            dxdxi(:,3,1) = dxdxi(:,3,1) + xl(:,n,3) * shgl(1,n,intp)
            dxdxi(:,3,2) = dxdxi(:,3,2) + xl(:,n,3) * shgl(2,n,intp)
            dxdxi(:,3,3) = dxdxi(:,3,3) + xl(:,n,3) * shgl(3,n,intp)
          enddo
c
c.... compute the inverse of deformation gradient
c
        dxidx(:,1,1) =   dxdxi(:,2,2) * dxdxi(:,3,3)
     &                 - dxdxi(:,3,2) * dxdxi(:,2,3)
        dxidx(:,1,2) =   dxdxi(:,3,2) * dxdxi(:,1,3)
     &                 - dxdxi(:,1,2) * dxdxi(:,3,3)
        dxidx(:,1,3) =   dxdxi(:,1,2) * dxdxi(:,2,3)
     &                 - dxdxi(:,1,3) * dxdxi(:,2,2)
        tmp          = one / ( dxidx(:,1,1) * dxdxi(:,1,1)
     &                       + dxidx(:,1,2) * dxdxi(:,2,1)
     &                       + dxidx(:,1,3) * dxdxi(:,3,1) )
        dxidx(:,1,1) = dxidx(:,1,1) * tmp
        dxidx(:,1,2) = dxidx(:,1,2) * tmp
        dxidx(:,1,3) = dxidx(:,1,3) * tmp
        dxidx(:,2,1) = (dxdxi(:,2,3) * dxdxi(:,3,1)
     &                - dxdxi(:,2,1) * dxdxi(:,3,3)) * tmp
        dxidx(:,2,2) = (dxdxi(:,1,1) * dxdxi(:,3,3)
     &                - dxdxi(:,3,1) * dxdxi(:,1,3)) * tmp
        dxidx(:,2,3) = (dxdxi(:,2,1) * dxdxi(:,1,3)
     &                - dxdxi(:,1,1) * dxdxi(:,2,3)) * tmp
        dxidx(:,3,1) = (dxdxi(:,2,1) * dxdxi(:,3,2)
     &                - dxdxi(:,2,2) * dxdxi(:,3,1)) * tmp
        dxidx(:,3,2) = (dxdxi(:,3,1) * dxdxi(:,1,2)
     &                - dxdxi(:,1,1) * dxdxi(:,3,2)) * tmp
        dxidx(:,3,3) = (dxdxi(:,1,1) * dxdxi(:,2,2)
     &                - dxdxi(:,1,2) * dxdxi(:,2,1)) * tmp
c
c        wght=Qwt(lcsyst,intp)  ! may be different now
        wght=Qwtf(intp)
        WdetJ = wght / tmp
c
      fresli=zero
c
      if(matflg(1,1).eq.0) then ! compressible
         do i=1,nshl
            fresli(:,22) = fresli(:,22)+shp(i,intp)*ycl(:,i,1) !density at
                                !qpt
         enddo
      else   ! incompressible, set density
         fresli(:,22)= one ! reduce comp2incompr regardless of rho  datmat(1,1,1)
      endif
c
      do n = 1,nshl
        shg(:,n,1) = (shgl(1,n,intp) * dxidx(:,1,1)
     &              + shgl(2,n,intp) * dxidx(:,2,1)
     &              + shgl(3,n,intp) * dxidx(:,3,1))
        shg(:,n,2) = (shgl(1,n,intp) * dxidx(:,1,2)
     &              + shgl(2,n,intp) * dxidx(:,2,2)
     &              + shgl(3,n,intp) * dxidx(:,3,2))
        shg(:,n,3) = (shgl(1,n,intp) * dxidx(:,1,3)
     &              + shgl(2,n,intp) * dxidx(:,2,3)
     &              + shgl(3,n,intp) * dxidx(:,3,3))
      enddo

      do j=10,12  ! normal strainrate u_{i,i} no sum on i
       ig=j-9
       iv=j-8
       do i=1,nshl
        fresli(:,j) = fresli(:,j)+shg(:,i,ig)*ycl(:,i,iv)
       enddo
      enddo

c shear stresses  NOTE  there may be faster ways to do this
c                  check agains CM5 code for speed WTP

       do i=1,nshl
        fresli(:,13) = fresli(:,13)+shg(:,i,2)*ycl(:,i,2)
     &                             +shg(:,i,1)*ycl(:,i,3)
        fresli(:,14) = fresli(:,14)+shg(:,i,3)*ycl(:,i,2)
     &                             +shg(:,i,1)*ycl(:,i,4)
        fresli(:,15) = fresli(:,15)+shg(:,i,3)*ycl(:,i,3)
     &                             +shg(:,i,2)*ycl(:,i,4)
       enddo

      fresli(:,13) = pt5 * fresli(:,13)
      fresli(:,14) = pt5 * fresli(:,14)
      fresli(:,15) = pt5 * fresli(:,15)

      strnrm(:,intp) = fresli(:,22) * sqrt(
     &   two * (fresli(:,10)**2 + fresli(:,11)**2 + fresli(:,12)**2)
     &  + four * ( fresli(:,13)**2 + fresli(:,14)**2 +
     &    fresli(:,15)**2 ) )

c
c S_ij
c

      fresli(:,10) = fresli(:,10) * WdetJ ! u_{1,1}*WdetJ
      fresli(:,11) = fresli(:,11) * WdetJ ! u_{2,2}*WdetJ
      fresli(:,12) = fresli(:,12) * WdetJ ! u_{3,3}*WdetJ
      fresli(:,13) = fresli(:,13) * WdetJ ! (1/2)*(u_{1,2}+u_{2,1})*WdetJ
      fresli(:,14) = fresli(:,14) * WdetJ ! (1/2)*(u_{1,3}+u_{3,1})*WdetJ
      fresli(:,15) = fresli(:,15) * WdetJ ! (1/2)*(u_{2,3}+u_{3,2})*WdetJ

      fresli(:,22) = fresli(:,22) * WdetJ   !rho * WdetJ
c     fresli(:,24) = fresli(:,24) * WdetJ

      u1=zero
      u2=zero
      u3=zero
      do i=1,nshl
       u1 = u1 + shp(i,intp)*ycl(:,i,2)
       u2 = u2 + shp(i,intp)*ycl(:,i,3)
       u3 = u3 + shp(i,intp)*ycl(:,i,4)
      enddo

      fresli(:,1) = fresli(:,22) * u1   !rho u1 * WdetJ
      fresli(:,2) = fresli(:,22) * u2   !rho u2 * WdetJ
      fresli(:,3) = fresli(:,22) * u3   !rho u3 * WdetJ

      fresli(:,4) = fresli(:,1) * u1    !rho u1 u1 *WdetJ
      fresli(:,5) = fresli(:,2) * u2    !rho u2 u2 *WdetJ
      fresli(:,6) = fresli(:,3) * u3    !rho u3 u3 *WdetJ
      fresli(:,7) = fresli(:,1) * u2    !rho u1 u2 *WdetJ
      fresli(:,8) = fresli(:,1) * u3    !rho u1 u3 *WdetJ
      fresli(:,9) = fresli(:,2) * u3    !rho u2 u3 *WdetJ

      fresli(:,16) = strnrm(:,intp) * fresli(:,10) ! rho *|Eps| *Eps11 *WdetJ
      fresli(:,17) = strnrm(:,intp) * fresli(:,11) ! rho *|Eps| *Eps22 *WdetJ
      fresli(:,18) = strnrm(:,intp) * fresli(:,12) ! rho *|Eps| *Eps33 *WdetJ
      fresli(:,19) = strnrm(:,intp) * fresli(:,13) ! rho *|Eps| *Eps12 *WdetJ
      fresli(:,20) = strnrm(:,intp) * fresli(:,14) ! rho *|Eps| *Eps13 *WdetJ
      fresli(:,21) = strnrm(:,intp) * fresli(:,15) ! rho *|Eps| *Eps23 *WdetJ

      fresli(:,23) = WdetJ   !    Integral of 1 over the element
c
      do i = 1, 23
         fresl(:,i) = fresl(:,i) + fresli(:,i)
      enddo

      enddo !end of loop over integration points
c
      do j = 1,nshl
      do nel = 1,npro
        fres(ien(nel,j),:) = fres(ien(nel,j),:) + fresl(nel,:)
      enddo
      enddo

      return
      end


      SUBROUTINE Q4BMGD (DSHP,GPTH,BGPDT,GPNORM,PHI,BMATRX)
C
C     THIS ROUTINE ASSEMBLES PORTIONS OF B-MATRIX FOR QUAD4
C
      LOGICAL          MEMBRN,BENDNG,SHRFLX,MBCOUP,NORPTH,BADJ
      INTEGER          ROWFLG
      REAL             GPNORM(4,1),BGPDT(4,1)
      DOUBLE PRECISION BMATRX(1),PSITRN(9),BBAR(120),ATRANS(6),PHI(9),
     1                 DSHP(1),GPTH(1),DERIV,THICK,HZTA,TERM,DETJ,
     2                 UEV,UNV,ANGLEI,EDGEL,EDGSHR,BB1,BB2,BB3,
     3                 BSBAR1(6),BSBAR(48),TEE(9)
      COMMON /Q4DT  /  DETJ,HZTA,PSITRN,NNODE,BADJ,N1
      COMMON /TERMS /  MEMBRN,BENDNG,SHRFLX,MBCOUP,NORPTH
      COMMON /Q4COMD/  ANGLEI(4),EDGSHR(3,4),EDGEL(4),UNV(3,4),
     1                 UEV(3,4),ROWFLG,IORDER(4)
C*****
C     INITIALIZE
C*****
      NDOF =NNODE*6
      NDOF3=NNODE*3
      ND2=NDOF*2
      ND3=NDOF*3
      ND4=NDOF*4
      ND5=NDOF*5
      ND6=NDOF*6
C
C     SET THE SIZE OF B-MATRIX BASED ON THE ROW FLAG.
C     ROWFLG = 1      OUT OF PLANE SHEAR (LAST 2 ROWS)   ND2
C     ROWFLG = 2      IN-PLANE SHEAR (THIRD  ROW)        NDOF
C     ROWFLG = 3      THE FIRST SIX (THREE) ROWS         ND6 (ND3)
C
      NN = ND6
      IF (NORPTH) NN = ND3
      IF (ROWFLG .EQ. 1) NN = ND2
      IF (ROWFLG .EQ. 2) NN = ND2
C*****
C     SET UP TERMS TO BE FILLED IN B-MATRIX
C*****
      DO 50 K=1,NNODE
      KPOINT=6*(K-1)
      THICK =GPTH(K)
C
C     COMPUTE THE TERMS WHICH GO IN THE FIRST 6(3) ROWS.
C
      IF (ROWFLG .EQ. 1) GO TO 20
      ATRANS(1)=-PSITRN(2)*GPNORM(4,K)+PSITRN(3)*GPNORM(3,K)
      ATRANS(2)= PSITRN(1)*GPNORM(4,K)-PSITRN(3)*GPNORM(2,K)
      ATRANS(3)=-PSITRN(1)*GPNORM(3,K)+PSITRN(2)*GPNORM(2,K)
      ATRANS(4)=-PSITRN(5)*GPNORM(4,K)+PSITRN(6)*GPNORM(3,K)
      ATRANS(5)= PSITRN(4)*GPNORM(4,K)-PSITRN(6)*GPNORM(2,K)
      ATRANS(6)=-PSITRN(4)*GPNORM(3,K)+PSITRN(5)*GPNORM(2,K)
C
      DO 10 I=1,2
      IPOINT=ND3*(I-1)
      ITOT =IPOINT+KPOINT
      DERIV=DSHP(N1*(I-1)+K)
      BBAR(     1+ITOT)=DERIV*PSITRN(1)
      BBAR(     2+ITOT)=DERIV*PSITRN(2)
      BBAR(     3+ITOT)=DERIV*PSITRN(3)
      BBAR(NDOF+1+ITOT)=DERIV*PSITRN(4)
      BBAR(NDOF+2+ITOT)=DERIV*PSITRN(5)
      BBAR(NDOF+3+ITOT)=DERIV*PSITRN(6)
      TERM=HZTA*THICK*DERIV
      BBAR(     4+ITOT)=TERM*ATRANS(1)
      BBAR(     5+ITOT)=TERM*ATRANS(2)
      BBAR(     6+ITOT)=TERM*ATRANS(3)
      BBAR(NDOF+4+ITOT)=TERM*ATRANS(4)
      BBAR(NDOF+5+ITOT)=TERM*ATRANS(5)
      BBAR(NDOF+6+ITOT)=TERM*ATRANS(6)
   10 CONTINUE
      GO TO 50
C
C     COMPUTE THE TERMS WHICH GO IN THE LAST 2 ROWS.
C
   20 IF (.NOT.BENDNG) RETURN
      TEE(1)= 0.0D0
      TEE(2)=-GPNORM(4,K)
      TEE(3)= GPNORM(3,K)
      TEE(4)=-TEE(2)
      TEE(5)= 0.0D0
      TEE(6)=-GPNORM(2,K)
      TEE(7)=-TEE(3)
      TEE(8)=-TEE(6)
      TEE(9)= 0.0D0
C
      KP1=KPOINT*2
      KP2=KP1+7
      J=IORDER(K)
      I=J-1
      IF (I .EQ. 0) I=4
C
      IB=0
   30 IB=IB+1
      BB1=-UNV(IB,J)*EDGSHR(1,J)/EDGEL(J)
     1    +UNV(IB,I)*EDGSHR(1,I)/EDGEL(I)
      BB2=-UNV(IB,J)*EDGSHR(2,J)/EDGEL(J)
     1    +UNV(IB,I)*EDGSHR(2,I)/EDGEL(I)
      BB3=-UNV(IB,J)*EDGSHR(3,J)/EDGEL(J)
     1    +UNV(IB,I)*EDGSHR(3,I)/EDGEL(I)
      BSBAR(KP1+IB  )=PSITRN(1)*BB1+PSITRN(2)*BB2+PSITRN(3)*BB3
      BSBAR(KP1+IB+3)=PSITRN(4)*BB1+PSITRN(5)*BB2+PSITRN(6)*BB3
      IF (IB .LT. 3) GO TO 30
C
      IB=0
   40 IB=IB+1
      BB1=-(UEV(IB,J)*EDGSHR(1,J)+UEV(IB,I)*EDGSHR(1,I))*0.5D0
      BB2=-(UEV(IB,J)*EDGSHR(2,J)+UEV(IB,I)*EDGSHR(2,I))*0.5D0
      BB3=-(UEV(IB,J)*EDGSHR(3,J)+UEV(IB,I)*EDGSHR(3,I))*0.5D0
      BSBAR1(IB  )=PSITRN(1)*BB1+PSITRN(2)*BB2+PSITRN(3)*BB3
      BSBAR1(IB+3)=PSITRN(4)*BB1+PSITRN(5)*BB2+PSITRN(6)*BB3
      IF (IB .LT. 3) GO TO 40
      CALL GMMATD (BSBAR1,2,3,0,TEE,3,3,0,BSBAR(KP2))
C
C*****
C     FILL IN B-MATRIX FOR THE NORMAL PATH
C*****
C
   50 CONTINUE
      IF (.NOT.NORPTH) GO TO 200
      GO TO (140,120,100), ROWFLG
C
C     ROWFLG = 3       FIRST THREE ROWS
C
  100 DO 110 KBAR=1,NDOF
      BMATRX(KBAR     )=PHI(1)*BBAR(KBAR     )+PHI(2)*BBAR(KBAR+ND3 )
      BMATRX(KBAR+NDOF)=PHI(4)*BBAR(KBAR+NDOF)+PHI(5)*BBAR(KBAR+ND4 )
      BMATRX(KBAR+ND2 )=PHI(4)*BBAR(KBAR     )+PHI(1)*BBAR(KBAR+NDOF)
     1                 +PHI(5)*BBAR(KBAR+ND3 )+PHI(2)*BBAR(KBAR+ND4 )
  110 CONTINUE
      GO TO 300
C
C     ROWFLG = 2       IN-PLANE SHEAR (3RD ROW)
C
  120 DO 130 KBAR=1,NDOF
      BMATRX(KBAR)=PHI(4)*BBAR(KBAR    )+PHI(1)*BBAR(KBAR+NDOF)
     1            +PHI(5)*BBAR(KBAR+ND3)+PHI(2)*BBAR(KBAR+ND4 )
  130 CONTINUE
      GO TO 300
C
C     ROWFLG = 1       OUT-OF-PLANE SHEAR (LAST 2 ROWS)
C
  140 DO 150 KBAR=1,NDOF
      IBAR=((KBAR-1)/3)*3+KBAR
      BMATRX(KBAR+NDOF)=BSBAR(IBAR  )
      BMATRX(KBAR     )=BSBAR(IBAR+3)
  150 CONTINUE
      GO TO 300
C
C*****
C     FILL IN B-MATRIX FOR THE MIDI PATH
C*****
C
  200 DO 210 IJI=1,NN
  210 BMATRX(IJI)=0.0D0
      GO TO (280,260,220), ROWFLG
C
C     ROWFLG = 3       FIRST SIX ROWS
C
  220 IF (.NOT.MEMBRN) GO TO 240
      DO 230 KA=1,NNODE
      KK=(KA-1)*6
      DO 230 M=1,3
      BMATRX(M+KK     )=PHI(1)*BBAR(M+KK     )+PHI(2)*BBAR(M+KK+ND3)
      BMATRX(M+KK+NDOF)=PHI(4)*BBAR(M+KK+NDOF)+PHI(5)*BBAR(M+KK+ND4)
  230 CONTINUE
C
  240 IF (.NOT.BENDNG) GO TO 300
      DO 250 KA=1,NNODE
      KK=(KA-1)*6
      DO 250 N=4,6
      BMATRX(N+KK+ND3)=PHI(1)*BBAR(N+KK     )+PHI(2)*BBAR(N+KK+ND3)
      BMATRX(N+KK+ND4)=PHI(4)*BBAR(N+KK+NDOF)+PHI(5)*BBAR(N+KK+ND4)
  250 CONTINUE
      GO TO 300
C
C     ROWFLG = 2       IN-PLANE SHEAR (3RD AND 6TH ROWS)
C
  260 DO 270 KA=1,NNODE
      KK=(KA-1)*6
      DO 270 M=1,3
      N=3+M
      BMATRX(M+KK     )=PHI(4)*BBAR(M+KK    )+PHI(1)*BBAR(M+KK+NDOF)
     1                 +PHI(5)*BBAR(M+KK+ND3)+PHI(2)*BBAR(M+KK+ND4)
      BMATRX(N+KK+NDOF)=PHI(4)*BBAR(N+KK    )+PHI(1)*BBAR(N+KK+NDOF)
     1                 +PHI(5)*BBAR(N+KK+ND3)+PHI(2)*BBAR(N+KK+ND4)
  270 CONTINUE
      GO TO 300
C
C     ROWFLG = 1       OUT-OF-PLANE SHEAR (LAST 2 ROWS)
C
  280 DO 290 KA=1,NNODE
      KK=(KA-1)*6
      DO 290 M=1,3
      N=3+M
      KKK=KK*2
      BMATRX(M+KK+NDOF)=BSBAR(M+KKK  )
      BMATRX(N+KK+NDOF)=BSBAR(M+KKK+6)
      BMATRX(M+KK     )=BSBAR(N+KKK  )
      BMATRX(N+KK     )=BSBAR(N+KKK+6)
  290 CONTINUE
C
  300 CONTINUE
      RETURN
      END


      subroutine gcp(n,index,indic,np,nt,y,s,z,ys,zs,diag,b,x,d,g,eps)
c
c     methode de gradient preconditionne appliquee a l'equation
c     [a]*{x}={b}. ici [a] est definie par les vecteurs ({y}(i),
c     {s}(i), {z}(i), i=1,np).
c
      implicit  double precision (a-h,o-z)
      dimension x(n),b(n),y(nt,n),s(nt,n),z(nt,n),ys(nt),zs(nt),diag(n)
      dimension       g(n),d(n)
      integer   index(nt),indic(n)
c
c     initialisation
      eps0=1.e-5
      eps1=1.e-5
      do 100 i=1,n
         if(indic(i).gt.0) go to 100
         x(i)=-b(i)/diag(i)
100   continue
c
      call calbx(n,index,indic,nt,np,y,s,ys,z,zs,x,diag,g)
      do 110 i=1,n
         if(indic(i).gt.0) go to 110
         g(i)=g(i)+b(i)
110   continue
c
c     ----------
c     iteration 1
c     ------test de convergence
      s0=0
      do 120 i=1,n
         if(indic(i).gt.0) go to 120
         s0=s0+g(i)*g(i)/diag(i)
120   continue
      if(s0.lt.1.0d-18) return
      s1=s0
c     ------recherche de la direction de descente
      do 130 i=1,n
         if(indic(i).gt.0) go to 130
         d(i)=-g(i)/diag(i)
130   continue
c
c     ------step length
      dg=0.
      do 135 i=1,n
         if(indic(i).gt.0) go to 135
         dg=dg+d(i)*g(i)
135   continue
      call calbx(n,index,indic,nt,np,y,s,ys,z,zs,d,diag,g)
      d2a=0
      do 140 i=1,n
         if(indic(i).gt.0) go to 140
         d2a=d2a+d(i)*g(i)
140   continue
c
      ro=-dg/d2a
      do 150 i=1,n
         if(indic(i).gt.0) go to 150
         x(i)=x(i)+ro*d(i)
150   continue
      call calbx(n,index,indic,nt,np,y,s,ys,z,zs,x,diag,g)
      do 170 i=1,n
         if(indic(i).gt.0) go to 170
         g(i)=g(i)+b(i)
170   continue
c
c     iteration k
      iter=0
      itmax=2*np
10    iter=iter +1
      if(iter.gt.itmax)return
c     ------test de convergence
      s2=0
      do 200 i=1,n
         if(indic(i).gt.0) go to 200
         s2=s2+g(i)*g(i)/diag(i)
200   continue
      if((s2/s0).lt.eps) return
c     ------recherche de la direction de descente
      beta=s2/s1
      do 210 i=1,n
         if(indic(i).gt.0) go to 210
         d(i)=-g(i)/diag(i)+beta*d(i)
210   continue
      s1=s2
c
c     -----step length
      dg=0.
      do 215 i=1,n
         if(indic(i).gt.0) go to 215
         dg=dg+d(i)*g(i)
215   continue
      call calbx(n,index,indic,nt,np,y,s,ys,z,zs,d,diag,g)
      d2a=0.
      do 220 i=1,n
         if(indic(i).gt.0) go to 220
         d2a=d2a+d(i)*g(i)
220   continue
c
      ro=-dg/d2a
      do 230 i=1,n
         if(indic(i).gt.0) go to 230
         x(i)=x(i)+ro*d(i)
230   continue
      call calbx(n,index,indic,nt,np,y,s,ys,z,zs,x,diag,g)
      do 240 i=1,n
         if(indic(i).gt.0) go to 240
         g(i)=g(i)+b(i)
240   continue
      go to 10
      end


!=============================================================================!
        subroutine penta2p( np, nsys, nblk, mat, rhs, per, per2 )
!=============================================================================!
!
!  Solves a block pentadiagonal system of equations without pivoting.
!  Vectorized over the second index.
!
!  This routine solves a PERIODIC block pentadiagonal system.
!
!  WARNING: Since pivoting is not done, this algorithm could fail
!
!  input:
!    nsys       : number of systems to vectorize over
!    np         : number of rows in the systems
!    nblk       : dimension of the blocks in each row
!
!  inout:
!    mat        : the block pentadiagonal matrix to be solved
!    rhs        : the right hand side
!=============================================================================!
        implicit none

        integer np, nblk, nsys
        real mat(5,nblk,nblk,np,nsys), rhs(nblk,np,nsys)
        real per(2,nblk,nblk,np,nsys), per2(6,nblk,nblk,nsys)

        real mult, fact

!.... useful constants

        real zero, one
        parameter (zero = 0.0, one = 1.0)

!.... local variables

        integer nc, i, l, m, n, p, q, r, iv
!=============================================================================!

!.... don't solve for the redundant nodes

        n = np - 1

!$omp parallel do private(nc,i,l,m,p,q,r,iv,fact,mult)
        do iv = 1, nsys

!.... setup the periodic fillin vector

        do q = 1, nblk
           do m = 1, nblk
              per(1,m,q,1,iv) = mat(1,m,q,1,iv)
              per(2,m,q,1,iv) = mat(2,m,q,1,iv)
              per(1,m,q,2,iv) = zero
              per(2,m,q,2,iv) = mat(1,m,q,2,iv)

              per2(1,m,q,iv)  = mat(5,m,q,n-1,iv)
              per2(2,m,q,iv)  = zero
              per2(4,m,q,iv)  = mat(4,m,q,n,iv)
              per2(5,m,q,iv)  = mat(5,m,q,n,iv)
           end do
        end do

!=============================================================================!
!                     F O R W A R D   E L I M I N A T I O N
!=============================================================================!

        do i = 1, n - 6

!.... do the first four columns

           do nc = 1, nblk - 1

              do m = nc, nblk - 1
                 l = m + 1
                 mult = -mat(3,l,nc,i,iv) / mat(3,nc,nc,i,iv)
                 do q = nc + 1, nblk
                    mat(3,l,q,i,iv) = mat(3,l,q,i,iv) + mult * mat(3,nc,q,i,iv)
                 end do
                 do q = 1, nblk
                    mat(4,l,q,i,iv) = mat(4,l,q,i,iv) + mult * mat(4,nc,q,i,iv)
                    mat(5,l,q,i,iv) = mat(5,l,q,i,iv) + mult * mat(5,nc,q,i,iv)
                    per(1,l,q,i,iv) = per(1,l,q,i,iv) + mult * per(1,nc,q,i,iv)
                    per(2,l,q,i,iv) = per(2,l,q,i,iv) + mult * per(2,nc,q,i,iv)
                 end do
                 rhs(l,i,iv) = rhs(l,i,iv) + mult * rhs(nc,i,iv)
              end do

           end do               ! end of loop on nc

!.... for all columns

           nc = 1

           p = i + 1
           r = i + 2

           fact = one / mat(3,nc,nc,i,iv)
           do m = 1, nblk
              mult = -mat(2,m,nc,p,iv) * fact
              do q = nc + 1, nblk
                 mat(2,m,q,p,iv) = mat(2,m,q,p,iv) + mult * mat(3,nc,q,i,iv)
              end do
              do q = 1, nblk
                 mat(3,m,q,p,iv) = mat(3,m,q,p,iv) + mult * mat(4,nc,q,i,iv)
                 mat(4,m,q,p,iv) = mat(4,m,q,p,iv) + mult * mat(5,nc,q,i,iv)
                 per(1,m,q,p,iv) = per(1,m,q,p,iv) + mult * per(1,nc,q,i,iv)
                 per(2,m,q,p,iv) = per(2,m,q,p,iv) + mult * per(2,nc,q,i,iv)
              end do
              rhs(m,p,iv) = rhs(m,p,iv) + mult * rhs(nc,i,iv)

              mult = -mat(1,m,nc,r,iv) * fact
              do q = nc + 1, nblk
                 mat(1,m,q,r,iv) = mat(1,m,q,r,iv) + mult * mat(3,nc,q,i,iv)
              end do
              do q = 1, nblk
                 mat(2,m,q,r,iv) = mat(2,m,q,r,iv) + mult * mat(4,nc,q,i,iv)
                 mat(3,m,q,r,iv) = mat(3,m,q,r,iv) + mult * mat(5,nc,q,i,iv)
                 per(1,m,q,r,iv) = mult * per(1,nc,q,i,iv)
                 per(2,m,q,r,iv) = mult * per(2,nc,q,i,iv)
              end do
              rhs(m,r,iv) = rhs(m,r,iv) + mult * rhs(nc,i,iv)

!.... the periodic stuff on the next-to-the-last row

              mult = -per2(1,m,nc,iv) * fact
              do q = nc + 1, nblk
                 per2(1,m,q,iv) = per2(1,m,q,iv) + mult * mat(3,nc,q,i,iv)
              end do
              do q = 1, nblk
                 per2(2,m,q,iv) = per2(2,m,q,iv) + mult * mat(4,nc,q,i,iv)
                 per2(3,m,q,iv) = mult * mat(5,nc,q,i,iv)
                 mat(3,m,q,n-1,iv) = mat(3,m,q,n-1,iv) + mult * per(1,nc,q,i,iv)
                 mat(4,m,q,n-1,iv) = mat(4,m,q,n-1,iv) + mult * per(2,nc,q,i,iv)
              end do
              rhs(m,n-1,iv) = rhs(m,n-1,iv) + mult * rhs(nc,i,iv)

!.... the periodic stuff on the last row

              mult = -per2(4,m,nc,iv) * fact
              do q = nc + 1, nblk
                 per2(4,m,q,iv) = per2(4,m,q,iv) + mult * mat(3,nc,q,i,iv)
              end do
              do q = 1, nblk
                 per2(5,m,q,iv) = per2(5,m,q,iv) + mult * mat(4,nc,q,i,iv)
                 per2(6,m,q,iv) = mult * mat(5,nc,q,i,iv)
                 mat(2,m,q,n,iv) = mat(2,m,q,n,iv) + mult * per(1,nc,q,i,iv)
                 mat(3,m,q,n,iv) = mat(3,m,q,n,iv) + mult * per(2,nc,q,i,iv)
              end do
              rhs(m,n,iv) = rhs(m,n,iv) + mult * rhs(nc,i,iv)

           end do               ! end of loop on m

           do nc = 2, nblk

              p = i + 1
              r = i + 2

              fact = one / mat(3,nc,nc,i,iv)
              do m = 1, nblk
                 mult = -mat(2,m,nc,p,iv) * fact
                 do q = nc + 1, nblk
                    mat(2,m,q,p,iv) = mat(2,m,q,p,iv) + mult * mat(3,nc,q,i,iv)
                 end do
                 do q = 1, nblk
                    mat(3,m,q,p,iv) = mat(3,m,q,p,iv) + mult * mat(4,nc,q,i,iv)
                    mat(4,m,q,p,iv) = mat(4,m,q,p,iv) + mult * mat(5,nc,q,i,iv)
                    per(1,m,q,p,iv) = per(1,m,q,p,iv) + mult * per(1,nc,q,i,iv)
                    per(2,m,q,p,iv) = per(2,m,q,p,iv) + mult * per(2,nc,q,i,iv)
                 end do
                 rhs(m,p,iv) = rhs(m,p,iv) + mult * rhs(nc,i,iv)

                 mult = -mat(1,m,nc,r,iv) * fact
                 do q = nc + 1, nblk
                    mat(1,m,q,r,iv) = mat(1,m,q,r,iv) + mult * mat(3,nc,q,i,iv)
                 end do
                 do q = 1, nblk
                    mat(2,m,q,r,iv) = mat(2,m,q,r,iv) + mult * mat(4,nc,q,i,iv)
                    mat(3,m,q,r,iv) = mat(3,m,q,r,iv) + mult * mat(5,nc,q,i,iv)
                    per(1,m,q,r,iv) = per(1,m,q,r,iv) + mult * per(1,nc,q,i,iv)
                    per(2,m,q,r,iv) = per(2,m,q,r,iv) + mult * per(2,nc,q,i,iv)
                 end do
                 rhs(m,r,iv) = rhs(m,r,iv) + mult * rhs(nc,i,iv)

!.... the periodic stuff on the next-to-the-last row

                 mult = -per2(1,m,nc,iv) * fact
                 do q = nc + 1, nblk
                    per2(1,m,q,iv) = per2(1,m,q,iv) + mult * mat(3,nc,q,i,iv)
                 end do
                 do q = 1, nblk
                    per2(2,m,q,iv) = per2(2,m,q,iv) + mult * mat(4,nc,q,i,iv)
                    per2(3,m,q,iv) = per2(3,m,q,iv) + mult * mat(5,nc,q,i,iv)
                    mat(3,m,q,n-1,iv) = mat(3,m,q,n-1,iv) + mult * per(1,nc,q,i,iv)
                    mat(4,m,q,n-1,iv) = mat(4,m,q,n-1,iv) + mult * per(2,nc,q,i,iv)
                 end do
                 rhs(m,n-1,iv) = rhs(m,n-1,iv) + mult * rhs(nc,i,iv)

!.... the periodic stuff on the last row

                 mult = -per2(4,m,nc,iv) * fact
                 do q = nc + 1, nblk
                    per2(4,m,q,iv) = per2(4,m,q,iv) + mult * mat(3,nc,q,i,iv)
                 end do
                 do q = 1, nblk
                    per2(5,m,q,iv) = per2(5,m,q,iv) + mult * mat(4,nc,q,i,iv)
                    per2(6,m,q,iv) = per2(6,m,q,iv) + mult * mat(5,nc,q,i,iv)
                    mat(2,m,q,n,iv) = mat(2,m,q,n,iv) + mult * per(1,nc,q,i,iv)
                    mat(3,m,q,n,iv) = mat(3,m,q,n,iv) + mult * per(2,nc,q,i,iv)
                 end do
                 rhs(m,n,iv) = rhs(m,n,iv) + mult * rhs(nc,i,iv)

              end do            ! end of loop on m

           end do               ! end of loop on nc

           do q = 1, nblk
              do m = 1, nblk
                 per2(1,m,q,iv)  = per2(2,m,q,iv)
                 per2(2,m,q,iv)  = per2(3,m,q,iv)
                 per2(4,m,q,iv)  = per2(5,m,q,iv)
                 per2(5,m,q,iv)  = per2(6,m,q,iv)
              end do
           end do

        end do                  ! end of loop on i

!====================================================================================
        i = n - 5

!.... do the first four columns

        do nc = 1, nblk - 1

           do m = nc, nblk - 1
              l = m + 1
              mult = -mat(3,l,nc,i,iv) / mat(3,nc,nc,i,iv)
              do q = nc + 1, nblk
                 mat(3,l,q,i,iv) = mat(3,l,q,i,iv) + mult * mat(3,nc,q,i,iv)
              end do
              do q = 1, nblk
                 mat(4,l,q,i,iv) = mat(4,l,q,i,iv) + mult * mat(4,nc,q,i,iv)
                 mat(5,l,q,i,iv) = mat(5,l,q,i,iv) + mult * mat(5,nc,q,i,iv)
                 per(1,l,q,i,iv) = per(1,l,q,i,iv) + mult * per(1,nc,q,i,iv)
                 per(2,l,q,i,iv) = per(2,l,q,i,iv) + mult * per(2,nc,q,i,iv)
              end do
              rhs(l,i,iv) = rhs(l,i,iv) + mult * rhs(nc,i,iv)
           end do

        end do                  ! end of loop on nc

!.... for all columns

        nc = 1

        p = i + 1
        r = i + 2

        fact = one / mat(3,nc,nc,i,iv)
        do m = 1, nblk
           mult = -mat(2,m,nc,p,iv) * fact
           do q = nc + 1, nblk
              mat(2,m,q,p,iv) = mat(2,m,q,p,iv) + mult * mat(3,nc,q,i,iv)
           end do
           do q = 1, nblk
              mat(3,m,q,p,iv) = mat(3,m,q,p,iv) + mult * mat(4,nc,q,i,iv)
              mat(4,m,q,p,iv) = mat(4,m,q,p,iv) + mult * mat(5,nc,q,i,iv)
              per(1,m,q,p,iv) = per(1,m,q,p,iv) + mult * per(1,nc,q,i,iv)
              per(2,m,q,p,iv) = per(2,m,q,p,iv) + mult * per(2,nc,q,i,iv)
           end do
           rhs(m,p,iv) = rhs(m,p,iv) + mult * rhs(nc,i,iv)

           mult = -mat(1,m,nc,r,iv) * fact
           do q = nc + 1, nblk
              mat(1,m,q,r,iv) = mat(1,m,q,r,iv) + mult * mat(3,nc,q,i,iv)
           end do
           do q = 1, nblk
              mat(2,m,q,r,iv) = mat(2,m,q,r,iv) + mult * mat(4,nc,q,i,iv)
              mat(3,m,q,r,iv) = mat(3,m,q,r,iv) + mult * mat(5,nc,q,i,iv)
              mat(4,m,q,r,iv) = mat(4,m,q,r,iv) + mult * per(1,nc,q,i,iv)
              per(2,m,q,r,iv) = mult * per(2,nc,q,i,iv)
           end do
           rhs(m,r,iv) = rhs(m,r,iv) + mult * rhs(nc,i,iv)

!.... the periodic stuff on the next-to-the-last row

           mult = -per2(1,m,nc,iv) * fact
           do q = nc + 1, nblk
              per2(1,m,q,iv) = per2(1,m,q,iv) + mult * mat(3,nc,q,i,iv)
           end do
           do q = 1, nblk
              per2(2,m,q,iv) = per2(2,m,q,iv) + mult * mat(4,nc,q,i,iv)
              mat(1,m,q,n-1,iv) = mat(1,m,q,n-1,iv) + mult * mat(5,nc,q,i,iv)
              mat(3,m,q,n-1,iv) = mat(3,m,q,n-1,iv) + mult * per(1,nc,q,i,iv)
              mat(4,m,q,n-1,iv) = mat(4,m,q,n-1,iv) + mult * per(2,nc,q,i,iv)
           end do
           rhs(m,n-1,iv) = rhs(m,n-1,iv) + mult * rhs(nc,i,iv)

!.... the periodic stuff on the last row

           mult = -per2(4,m,nc,iv) * fact
           do q = nc + 1, nblk
              per2(4,m,q,iv) = per2(4,m,q,iv) + mult * mat(3,nc,q,i,iv)
           end do
           do q = 1, nblk
              per2(5,m,q,iv) = per2(5,m,q,iv) + mult * mat(4,nc,q,i,iv)
              per2(6,m,q,iv) = mult * mat(5,nc,q,i,iv)
              mat(2,m,q,n,iv) = mat(2,m,q,n,iv) + mult * per(1,nc,q,i,iv)
              mat(3,m,q,n,iv) = mat(3,m,q,n,iv) + mult * per(2,nc,q,i,iv)
           end do
           rhs(m,n,iv) = rhs(m,n,iv) + mult * rhs(nc,i,iv)

        end do                  ! end of loop on m

        do nc = 2, nblk

           p = i + 1
           r = i + 2

           fact = one / mat(3,nc,nc,i,iv)
           do m = 1, nblk
              mult = -mat(2,m,nc,p,iv) * fact
              do q = nc + 1, nblk
                 mat(2,m,q,p,iv) = mat(2,m,q,p,iv) + mult * mat(3,nc,q,i,iv)
              end do
              do q = 1, nblk
                 mat(3,m,q,p,iv) = mat(3,m,q,p,iv) + mult * mat(4,nc,q,i,iv)
                 mat(4,m,q,p,iv) = mat(4,m,q,p,iv) + mult * mat(5,nc,q,i,iv)
                 per(1,m,q,p,iv) = per(1,m,q,p,iv) + mult * per(1,nc,q,i,iv)
                 per(2,m,q,p,iv) = per(2,m,q,p,iv) + mult * per(2,nc,q,i,iv)
              end do
              rhs(m,p,iv) = rhs(m,p,iv) + mult * rhs(nc,i,iv)

              mult = -mat(1,m,nc,r,iv) * fact
              do q = nc + 1, nblk
                 mat(1,m,q,r,iv) = mat(1,m,q,r,iv) + mult * mat(3,nc,q,i,iv)
              end do
              do q = 1, nblk
                 mat(2,m,q,r,iv) = mat(2,m,q,r,iv) + mult * mat(4,nc,q,i,iv)
                 mat(3,m,q,r,iv) = mat(3,m,q,r,iv) + mult * mat(5,nc,q,i,iv)
                 mat(4,m,q,r,iv) = mat(4,m,q,r,iv) + mult * per(1,nc,q,i,iv)
                 per(2,m,q,r,iv) = per(2,m,q,r,iv) + mult * per(2,nc,q,i,iv)
              end do
              rhs(m,r,iv) = rhs(m,r,iv) + mult * rhs(nc,i,iv)

!.... the periodic stuff on the next-to-the-last row

              mult = -per2(1,m,nc,iv) * fact
              do q = nc + 1, nblk
                 per2(1,m,q,iv) = per2(1,m,q,iv) + mult * mat(3,nc,q,i,iv)
              end do
              do q = 1, nblk
                 per2(2,m,q,iv) = per2(2,m,q,iv) + mult * mat(4,nc,q,i,iv)
                 mat(1,m,q,n-1,iv) = mat(1,m,q,n-1,iv) + mult * mat(5,nc,q,i,iv)
                 mat(3,m,q,n-1,iv) = mat(3,m,q,n-1,iv) + mult * per(1,nc,q,i,iv)
                 mat(4,m,q,n-1,iv) = mat(4,m,q,n-1,iv) + mult * per(2,nc,q,i,iv)
              end do
              rhs(m,n-1,iv) = rhs(m,n-1,iv) + mult * rhs(nc,i,iv)

!.... the periodic stuff on the last row

              mult = -per2(4,m,nc,iv) * fact
              do q = nc + 1, nblk
                 per2(4,m,q,iv) = per2(4,m,q,iv) + mult * mat(3,nc,q,i,iv)
              end do
              do q = 1, nblk
                 per2(5,m,q,iv) = per2(5,m,q,iv) + mult * mat(4,nc,q,i,iv)
                 per2(6,m,q,iv) = per2(6,m,q,iv) + mult * mat(5,nc,q,i,iv)
                 mat(2,m,q,n,iv) = mat(2,m,q,n,iv) + mult * per(1,nc,q,i,iv)
                 mat(3,m,q,n,iv) = mat(3,m,q,n,iv) + mult * per(2,nc,q,i,iv)
              end do
              rhs(m,n,iv) = rhs(m,n,iv) + mult * rhs(nc,i,iv)

           end do               ! end of loop on m

        end do                  ! end of loop on nc

        do q = 1, nblk
           do m = 1, nblk
              per2(1,m,q,iv)  = per2(2,m,q,iv)
              per2(4,m,q,iv)  = per2(5,m,q,iv)
              per2(5,m,q,iv)  = per2(6,m,q,iv)
           end do
        end do

!====================================================================================
        i = n - 4

!.... do the first four columns

        do nc = 1, nblk - 1

           do m = nc, nblk - 1
              l = m + 1
              mult = -mat(3,l,nc,i,iv) / mat(3,nc,nc,i,iv)
              do q = nc + 1, nblk
                 mat(3,l,q,i,iv) = mat(3,l,q,i,iv) + mult * mat(3,nc,q,i,iv)
              end do
              do q = 1, nblk
                 mat(4,l,q,i,iv) = mat(4,l,q,i,iv) + mult * mat(4,nc,q,i,iv)
                 mat(5,l,q,i,iv) = mat(5,l,q,i,iv) + mult * mat(5,nc,q,i,iv)
                 per(1,l,q,i,iv) = per(1,l,q,i,iv) + mult * per(1,nc,q,i,iv)
                 per(2,l,q,i,iv) = per(2,l,q,i,iv) + mult * per(2,nc,q,i,iv)
              end do
              rhs(l,i,iv) = rhs(l,i,iv) + mult * rhs(nc,i,iv)
           end do

        end do                  ! end of loop on nc

!.... for all columns

        do nc = 1, nblk

           p = i + 1
           r = i + 2

           fact = one / mat(3,nc,nc,i,iv)
           do m = 1, nblk
              mult = -mat(2,m,nc,p,iv) * fact
              do q = nc + 1, nblk
                 mat(2,m,q,p,iv) = mat(2,m,q,p,iv) + mult * mat(3,nc,q,i,iv)
              end do
              do q = 1, nblk
                 mat(3,m,q,p,iv) = mat(3,m,q,p,iv) + mult * mat(4,nc,q,i,iv)
                 mat(4,m,q,p,iv) = mat(4,m,q,p,iv) + mult * mat(5,nc,q,i,iv)
                 mat(5,m,q,p,iv) = mat(5,m,q,p,iv) + mult * per(1,nc,q,i,iv)
                 per(2,m,q,p,iv) = per(2,m,q,p,iv) + mult * per(2,nc,q,i,iv)
              end do
              rhs(m,p,iv) = rhs(m,p,iv) + mult * rhs(nc,i,iv)

              mult = -mat(1,m,nc,r,iv) * fact
              do q = nc + 1, nblk
                 mat(1,m,q,r,iv) = mat(1,m,q,r,iv) + mult * mat(3,nc,q,i,iv)
              end do
              do q = 1, nblk
                 mat(2,m,q,r,iv) = mat(2,m,q,r,iv) + mult * mat(4,nc,q,i,iv)
                 mat(3,m,q,r,iv) = mat(3,m,q,r,iv) + mult * mat(5,nc,q,i,iv)
                 mat(4,m,q,r,iv) = mat(4,m,q,r,iv) + mult * per(1,nc,q,i,iv)
                 mat(5,m,q,r,iv) = mat(5,m,q,r,iv) + mult * per(2,nc,q,i,iv)
              end do
              rhs(m,r,iv) = rhs(m,r,iv) + mult * rhs(nc,i,iv)

!.... the periodic stuff on the next-to-the-last row

              mult = -per2(1,m,nc,iv) * fact
              do q = nc + 1, nblk
                 per2(1,m,q,iv) = per2(1,m,q,iv) + mult * mat(3,nc,q,i,iv)
              end do
              do q = 1, nblk
                 mat(1,m,q,n-1,iv) = mat(1,m,q,n-1,iv) + mult * mat(4,nc,q,i,iv)
                 mat(2,m,q,n-1,iv) = mat(2,m,q,n-1,iv) + mult * mat(5,nc,q,i,iv)
                 mat(3,m,q,n-1,iv) = mat(3,m,q,n-1,iv) + mult * per(1,nc,q,i,iv)
                 mat(4,m,q,n-1,iv) = mat(4,m,q,n-1,iv) + mult * per(2,nc,q,i,iv)
              end do
              rhs(m,n-1,iv) = rhs(m,n-1,iv) + mult * rhs(nc,i,iv)

!.... the periodic stuff on the last row

              mult = -per2(4,m,nc,iv) * fact
              do q = nc + 1, nblk
                 per2(4,m,q,iv) = per2(4,m,q,iv) + mult * mat(3,nc,q,i,iv)
              end do
              do q = 1, nblk
                 per2(5,m,q,iv) = per2(5,m,q,iv) + mult * mat(4,nc,q,i,iv)
                 mat(1,m,q,n,iv) = mat(1,m,q,n,iv) + mult * mat(5,nc,q,i,iv)
                 mat(2,m,q,n,iv) = mat(2,m,q,n,iv) + mult * per(1,nc,q,i,iv)
                 mat(3,m,q,n,iv) = mat(3,m,q,n,iv) + mult * per(2,nc,q,i,iv)
              end do
              rhs(m,n,iv) = rhs(m,n,iv) + mult * rhs(nc,i,iv)

           end do               ! end of loop on m

        end do                  ! end of loop on nc

        do q = 1, nblk
           do m = 1, nblk
              per2(4,m,q,iv)  = per2(5,m,q,iv)
           end do
        end do

!====================================================================================
        i = n - 3

!.... do the first four columns

        do nc = 1, nblk - 1

           do m = nc, nblk - 1
              l = m + 1
              mult = -mat(3,l,nc,i,iv) / mat(3,nc,nc,i,iv)
              do q = nc + 1, nblk
                 mat(3,l,q,i,iv) = mat(3,l,q,i,iv) + mult * mat(3,nc,q,i,iv)
              end do
              do q = 1, nblk
                 mat(4,l,q,i,iv) = mat(4,l,q,i,iv) + mult * mat(4,nc,q,i,iv)
                 mat(5,l,q,i,iv) = mat(5,l,q,i,iv) + mult * mat(5,nc,q,i,iv)
                 per(2,l,q,i,iv) = per(2,l,q,i,iv) + mult * per(2,nc,q,i,iv)
              end do
              rhs(l,i,iv) = rhs(l,i,iv) + mult * rhs(nc,i,iv)
           end do

        end do                  ! end of loop on nc

!.... for all columns

        do nc = 1, nblk

           p = i + 1
           r = i + 2

           fact = one / mat(3,nc,nc,i,iv)
           do m = 1, nblk
              mult = -mat(2,m,nc,p,iv) * fact
              do q = nc + 1, nblk
                 mat(2,m,q,p,iv) = mat(2,m,q,p,iv) + mult * mat(3,nc,q,i,iv)
              end do
              do q = 1, nblk
                 mat(3,m,q,p,iv) = mat(3,m,q,p,iv) + mult * mat(4,nc,q,i,iv)
                 mat(4,m,q,p,iv) = mat(4,m,q,p,iv) + mult * mat(5,nc,q,i,iv)
                 mat(5,m,q,p,iv) = mat(5,m,q,p,iv) + mult * per(2,nc,q,i,iv)
              end do
              rhs(m,p,iv) = rhs(m,p,iv) + mult * rhs(nc,i,iv)

              mult = -mat(1,m,nc,r,iv) * fact
              do q = nc + 1, nblk
                 mat(1,m,q,r,iv) = mat(1,m,q,r,iv) + mult * mat(3,nc,q,i,iv)
              end do
              do q = 1, nblk
                 mat(2,m,q,r,iv) = mat(2,m,q,r,iv) + mult * mat(4,nc,q,i,iv)
                 mat(3,m,q,r,iv) = mat(3,m,q,r,iv) + mult * mat(5,nc,q,i,iv)
                 mat(4,m,q,r,iv) = mat(4,m,q,r,iv) + mult * per(2,nc,q,i,iv)
              end do
              rhs(m,r,iv) = rhs(m,r,iv) + mult * rhs(nc,i,iv)

!.... the periodic stuff on the last row

              mult = -per2(4,m,nc,iv) * fact
              do q = nc + 1, nblk
                 per2(4,m,q,iv) = per2(4,m,q,iv) + mult * mat(3,nc,q,i,iv)
              end do
              do q = 1, nblk
                 mat(1,m,q,n,iv) = mat(1,m,q,n,iv) + mult * mat(4,nc,q,i,iv)
                 mat(2,m,q,n,iv) = mat(2,m,q,n,iv) + mult * mat(5,nc,q,i,iv)
                 mat(3,m,q,n,iv) = mat(3,m,q,n,iv) + mult * per(2,nc,q,i,iv)
              end do
              rhs(m,n,iv) = rhs(m,n,iv) + mult * rhs(nc,i,iv)

           end do               ! end of loop on m

        end do                  ! end of loop on nc

!====================================================================================
        i = n - 2

!.... do the first four columns

        do nc = 1, nblk - 1

           do m = nc, nblk - 1
              l = m + 1
              mult = -mat(3,l,nc,i,iv) / mat(3,nc,nc,i,iv)
              do q = nc + 1, nblk
                 mat(3,l,q,i,iv) = mat(3,l,q,i,iv) + mult * mat(3,nc,q,i,iv)
              end do
              do q = 1, nblk
                 mat(4,l,q,i,iv) = mat(4,l,q,i,iv) + mult * mat(4,nc,q,i,iv)
                 mat(5,l,q,i,iv) = mat(5,l,q,i,iv) + mult * mat(5,nc,q,i,iv)
              end do
              rhs(l,i,iv) = rhs(l,i,iv) + mult * rhs(nc,i,iv)
           end do

        end do                  ! end of loop on nc

!.... for all columns

        do nc = 1, nblk

           p = i + 1
           r = i + 2

           fact = one / mat(3,nc,nc,i,iv)
           do m = 1, nblk
              mult = -mat(2,m,nc,p,iv) * fact
              do q = nc + 1, nblk
                 mat(2,m,q,p,iv) = mat(2,m,q,p,iv) + mult * mat(3,nc,q,i,iv)
              end do
              do q = 1, nblk
                 mat(3,m,q,p,iv) = mat(3,m,q,p,iv) + mult * mat(4,nc,q,i,iv)
                 mat(4,m,q,p,iv) = mat(4,m,q,p,iv) + mult * mat(5,nc,q,i,iv)
              end do
              rhs(m,p,iv) = rhs(m,p,iv) + mult * rhs(nc,i,iv)

              mult = -mat(1,m,nc,r,iv) * fact
              do q = nc + 1, nblk
                 mat(1,m,q,r,iv) = mat(1,m,q,r,iv) + mult * mat(3,nc,q,i,iv)
              end do
              do q = 1, nblk
                 mat(2,m,q,r,iv) = mat(2,m,q,r,iv) + mult * mat(4,nc,q,i,iv)
                 mat(3,m,q,r,iv) = mat(3,m,q,r,iv) + mult * mat(5,nc,q,i,iv)
              end do
              rhs(m,r,iv) = rhs(m,r,iv) + mult * rhs(nc,i,iv)

           end do               ! end of loop on m

        end do                  ! end of loop on nc

!====================================================================================
        i = n - 1

!.... do the first four columns

        do nc = 1, nblk - 1

           do m = nc, nblk - 1
              l = m + 1
              mult = -mat(3,l,nc,i,iv) / mat(3,nc,nc,i,iv)
              do q = nc + 1, nblk
                 mat(3,l,q,i,iv) = mat(3,l,q,i,iv) + mult * mat(3,nc,q,i,iv)
              end do
              do q = 1, nblk
                 mat(4,l,q,i,iv) = mat(4,l,q,i,iv) + mult * mat(4,nc,q,i,iv)
              end do
              rhs(l,i,iv) = rhs(l,i,iv) + mult * rhs(nc,i,iv)
           end do

        end do                  ! end of loop on nc

!.... for all columns

        do nc = 1, nblk

           p = i + 1

           fact = one / mat(3,nc,nc,i,iv)

           do m = 1, nblk
              mult = -mat(2,m,nc,p,iv) * fact
              do q = nc + 1, nblk
                 mat(2,m,q,p,iv) = mat(2,m,q,p,iv) + mult * mat(3,nc,q,i,iv)
              end do
              do q = 1, nblk
                 mat(3,m,q,p,iv) = mat(3,m,q,p,iv) + mult * mat(4,nc,q,i,iv)
              end do
              rhs(m,p,iv) = rhs(m,p,iv) + mult * rhs(nc,i,iv)
           end do

        end do                  ! end of loop on nc

!.... do the last row

        i = n

        do nc = 1, nblk - 1

           do m = nc, nblk - 1
              l = m + 1
              mult = -mat(3,l,nc,i,iv) / mat(3,nc,nc,i,iv)
              do q = nc + 1, nblk
                 mat(3,l,q,i,iv) = mat(3,l,q,i,iv) + mult * mat(3,nc,q,i,iv)
              end do
              rhs(l,i,iv) = rhs(l,i,iv) + mult * rhs(nc,i,iv)
           end do

        end do                  ! end of loop on nc

!=============================================================================!
!                   B A C K W A R D   S U B S T I T U T I O N
!=============================================================================!

!.... do the last row first

        i = n

        do m = nblk, 1, -1
           do q = m+1, nblk
              rhs(m,i,iv) = rhs(m,i,iv) - rhs(q,i,iv) * mat(3,m,q,i,iv)
           end do
           rhs(m,i,iv) = rhs(m,i,iv) / mat(3,m,m,i,iv)
        end do

!.... do the next-to-the-last row

        i = n - 1
        p = i + 1

        do m = nblk, 1, -1
           do q = m+1, nblk
              rhs(m,i,iv) = rhs(m,i,iv) - rhs(q,i,iv) * mat(3,m,q,i,iv)
           end do
           do q = 1, nblk
              rhs(m,i,iv) = rhs(m,i,iv) - rhs(q,p,iv) * mat(4,m,q,i,iv)
           end do
           rhs(m,i,iv) = rhs(m,i,iv) / mat(3,m,m,i,iv)
        end do

        i = n - 2
        p = i + 1
        r = i + 2

        do m = nblk, 1, -1
           do q = m+1, nblk
              rhs(m,i,iv) = rhs(m,i,iv) - rhs(q,i,iv) * mat(3,m,q,i,iv)
           end do
           do q = 1, nblk
              rhs(m,i,iv) = rhs(m,i,iv) - rhs(q,p,iv) * mat(4,m,q,i,iv)
              rhs(m,i,iv) = rhs(m,i,iv) - rhs(q,r,iv) * mat(5,m,q,i,iv)
           end do
           rhs(m,i,iv) = rhs(m,i,iv) / mat(3,m,m,i,iv)
        end do

        i = n - 3
        p = i + 1
        r = i + 2

        do m = nblk, 1, -1
           do q = m+1, nblk
              rhs(m,i,iv) = rhs(m,i,iv) - rhs(q,i,iv) * mat(3,m,q,i,iv)
           end do
           do q = 1, nblk
              rhs(m,i,iv) = rhs(m,i,iv) - rhs(q,p,iv) * mat(4,m,q,i,iv)
              rhs(m,i,iv) = rhs(m,i,iv) - rhs(q,r,iv) * mat(5,m,q,i,iv)
              rhs(m,i,iv) = rhs(m,i,iv) - rhs(q,n,iv) * per(2,m,q,i,iv)
           end do
           rhs(m,i,iv) = rhs(m,i,iv) / mat(3,m,m,i,iv)
        end do

!.... now do the rest of the rows in reverse order

        do i = n - 4, 1, -1

           p = i + 1
           r = i + 2

           do m = nblk, 1, -1
              do q = m+1, nblk
                 rhs(m,i,iv) = rhs(m,i,iv) - rhs(q,i,iv) * mat(3,m,q,i,iv)
              end do
              do q = 1, nblk
                 rhs(m,i,iv) = rhs(m,i,iv) - rhs(q,p,iv) * mat(4,m,q,i,iv)
                 rhs(m,i,iv) = rhs(m,i,iv) - rhs(q,r,iv) * mat(5,m,q,i,iv)
                 rhs(m,i,iv) = rhs(m,i,iv) - rhs(q,n-1,iv) * per(1,m,q,i,iv)
                 rhs(m,i,iv) = rhs(m,i,iv) - rhs(q,n,iv) * per(2,m,q,i,iv)
              end do
              rhs(m,i,iv) = rhs(m,i,iv) / mat(3,m,m,i,iv)
           end do

        end do

!.... account for periodicity

        do q = 1, nblk
           rhs(q,np,iv) = rhs(q,1,iv)
        end do

        end do

        return
        end


*
*     ------------------------------------------------------------------
*              Z K
*     ------------------------------------------------------------------
*
*               k
*       Stores Z (i, j; r) in the array YK.
*
*
      SUBROUTINE ZK(I,J,K)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      PARAMETER(NOD=220)
      COMMON /PARAM/H,H1,H3,CH,EH,RHO,Z,TOL,NO,ND,NWF,MASS,NCFG,IB,IC,ID
     :   ,D0,D1,D2,D3,D4,D5,D6,D8,D10,D12,D16,D30,FINE,NSCF,NCLOSD,RMASS
      COMMON /RADIAL/R(NOD),RR(NOD),R2(NOD),YK(NOD),YR(NOD),X(NOD)
      POINTER(IQP,P(NOD,1)),(IQN,N(1)),(IQL,L(1)),(IQAZ,AZ(1)),
     :       (IQMAX,MAX(1))
      COMMON/NEL/IQP,IQN,IQL,IQAZ,IQMAX,IQ(7)
      DIMENSION F(NOD),G(NOD)
*
      DEN = L(I) + L(J) + 3+ K
      FACT = (D1/(L(I)+1) + D1/(L(J)+1))/(DEN + D1)
      A = EH**K
      A2 = A*A
      H90 = H/90.D0
      A3 = A2*A*H90
      AI = H90/A
      AN = 114.D0*A*H90
      A34 = 34.D0*H90
      DO 10 M = 1,NO
      F(M) = RR(M)*P(M,I)*P(M,J)
   10 CONTINUE
      YK(1) = F(1)*(D1 + Z*R(1)*FACT)/DEN
      YK(2) = F(2)*(D1 + Z*R(2)*FACT)/DEN
      YK(3) = F(3)*(D1 + Z*R(3)*FACT)/DEN
*      YK(3) = YK(1)*A2 + H3*(F3 + D4*A*F2 + A2*F1)
      DO 9 M = 5,NO
       G(M) = AN*F(M-2) + A34*(F(M-1)+A2*F(M-3))-F(M)*AI-F(M-4)*A3
    9 CONTINUE
      DO 8 M = 5,NO
        YK(M-1) = YK(M-3)*A2 + G(M)
    8 CONTINUE
      YK(NO) = A*YK(NO-1)
      IF (IABS(I-J)  +  IABS(K) .NE. 0) GO TO 2
*
*  *****  FOR Y0(I,I) SET THE LIMIT TO 1 AND REMOVE OSCILLATIONS
*  *****  INTRODUCED BY THE USE OF SIMPSON'S RULE
*
      M1 = (NO/2)*2 - 1
      M2 = M1 - 1
      C1 = D1 - YK(M1)
      C2 = D1 - YK(M2)
      DO 3 M = 1,NO,2
        YK(M) = YK(M) + C1
3     CONTINUE
      DO 4 M = 2,NO,2
        YK(M) = YK(M) + C2
4     CONTINUE
2     RETURN
      END