!=============================================================================!
        subroutine cpenta1p( nsys, np, nblk, mat, rhs, per, per2,
     &                       mult, fact, code )
!=============================================================================!
!
!  Solves a block pentadiagonal system of equations without pivoting.
!  Vectorized over the first 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
!    n          : number of rows in the systems
!    nblk       : dimension of the blocks in each row
!    code       : 0 = LU factorization only
!               : 1 = Forward and back solves given LU
!               : 2 = LU and solve
!
!  inout:
!    mat        : the block pentadiagonal matrix to be solved
!    rhs        : the right hand side
!=============================================================================!
        implicit none

        integer np, nblk, nsys, code
        complex mat(nsys,np,nblk,nblk,5), rhs(nsys,np,nblk)
        complex per(nsys,np,nblk,nblk,2), per2(nsys,np-2:np-1,nblk,nblk,np)
        complex mult(nsys), fact(nsys)

!.... useful constants

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

!.... local variables

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

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

        n = np - 1

!=============================================================================!
!                       L U   F A C T O R I Z A T I O N
!=============================================================================!
        if (code .eq. 0 .or. code .eq. 2) then

!       per  = zero
!       per2 = zero

        call rzero( nsys*np*nblk*nblk*2, per )
        call rzero( nsys*2*nblk*nblk*np, per2 )

!.... setup the periodic fillin vector

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

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

        do i = 1, n - 6

!.... do the first four columns

          do nc = 1, nblk - 1

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

          end do        ! end of loop on nc

!.... for all columns

          nc = 1

          p = i + 1
          r = i + 2

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

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

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

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

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

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

          end do        ! end of loop on m

          do nc = 2, nblk

            p = i + 1
            r = i + 2

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

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

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

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

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

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

            end do      ! end of loop on m

          end do        ! end of loop on nc

        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
              do iv = 1, nsys
                mult(iv) = -mat(iv,i,l,nc,3) / mat(iv,i,nc,nc,3)
                mat(iv,i,l,nc,3) = mult(iv)
              end do
              do q = nc + 1, nblk
                do iv = 1, nsys
                  mat(iv,i,l,q,3) = mat(iv,i,l,q,3) + mult(iv) * mat(iv,i,nc,q,3)
                end do
              end do
              do q = 1, nblk
                do iv = 1, nsys
                  mat(iv,i,l,q,4) = mat(iv,i,l,q,4) + mult(iv) * mat(iv,i,nc,q,4)
                  mat(iv,i,l,q,5) = mat(iv,i,l,q,5) + mult(iv) * mat(iv,i,nc,q,5)
                  per(iv,i,l,q,1) = per(iv,i,l,q,1) + mult(iv) * per(iv,i,nc,q,1)
                  per(iv,i,l,q,2) = per(iv,i,l,q,2) + mult(iv) * per(iv,i,nc,q,2)
                end do
              end do
            end do

          end do        ! end of loop on nc

!.... for all columns

          nc = 1

          p = i + 1
          r = i + 2

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

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

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

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

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

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

          end do        ! end of loop on m

          do nc = 2, nblk

            p = i + 1
            r = i + 2

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

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

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

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

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

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

            end do      ! end of loop on m

          end do        ! end of loop on nc

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

!.... do the first four columns

          do nc = 1, nblk - 1

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

          end do        ! end of loop on nc

!.... for all columns

          do nc = 1, nblk

            p = i + 1
            r = i + 2

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

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

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

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

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

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

            end do      ! end of loop on m

          end do        ! end of loop on nc

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

!.... do the first four columns

          do nc = 1, nblk - 1

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

          end do        ! end of loop on nc

!.... for all columns

          do nc = 1, nblk

            p = i + 1
            r = i + 2

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

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

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

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

            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
              do iv = 1, nsys
                mult(iv) = -mat(iv,i,l,nc,3) / mat(iv,i,nc,nc,3)
                mat(iv,i,l,nc,3) = mult(iv)
              end do
              do q = nc + 1, nblk
                do iv = 1, nsys
                  mat(iv,i,l,q,3) = mat(iv,i,l,q,3) + mult(iv) * mat(iv,i,nc,q,3)
                end do
              end do
              do q = 1, nblk
                do iv = 1, nsys
                  mat(iv,i,l,q,4) = mat(iv,i,l,q,4) + mult(iv) * mat(iv,i,nc,q,4)
                  mat(iv,i,l,q,5) = mat(iv,i,l,q,5) + mult(iv) * mat(iv,i,nc,q,5)
                end do
              end do
            end do

          end do        ! end of loop on nc

!.... for all columns

          do nc = 1, nblk

            p = i + 1
            r = i + 2

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

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

            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
              do iv = 1, nsys
                mult(iv) = -mat(iv,i,l,nc,3) / mat(iv,i,nc,nc,3)
                mat(iv,i,l,nc,3) = mult(iv)
              end do
              do q = nc + 1, nblk
                do iv = 1, nsys
                  mat(iv,i,l,q,3) = mat(iv,i,l,q,3) + mult(iv) * mat(iv,i,nc,q,3)
                end do
              end do
              do q = 1, nblk
                do iv = 1, nsys
                  mat(iv,i,l,q,4) = mat(iv,i,l,q,4) + mult(iv) * mat(iv,i,nc,q,4)
                end do
              end do
            end do

          end do        ! end of loop on nc

!.... for all columns

          do nc = 1, nblk

            p = i + 1

            do iv = 1, nsys
              fact(iv) = one / mat(iv,i,nc,nc,3)
            end do

            do m = 1, nblk
              do iv = 1, nsys
                mult(iv) = -mat(iv,p,m,nc,2) * fact(iv)
                mat(iv,p,m,nc,2) = mult(iv)
              end do
              do q = nc + 1, nblk
                do iv = 1, nsys
                  mat(iv,p,m,q,2) = mat(iv,p,m,q,2) + mult(iv) * mat(iv,i,nc,q,3)
                end do
              end do
              do q = 1, nblk
                do iv = 1, nsys
                  mat(iv,p,m,q,3) = mat(iv,p,m,q,3) + mult(iv) * mat(iv,i,nc,q,4)
                end do
              end do
            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
            do iv = 1, nsys
              mult(iv) = -mat(iv,i,l,nc,3) / mat(iv,i,nc,nc,3)
              mat(iv,i,l,nc,3) = mult(iv)
            end do
            do q = nc + 1, nblk
              do iv = 1, nsys
                mat(iv,i,l,q,3) = mat(iv,i,l,q,3) + mult(iv) * mat(iv,i,nc,q,3)
              end do
            end do
          end do

        end do  ! end of loop on nc

        end if
!=============================================================================!
!                     F O R W A R D   E L I M I N A T I O N
!=============================================================================!
        if (code.eq.1 .or. code.eq.2) then

        do i = 1, n - 6

!.... do the first four columns

          do nc = 1, nblk - 1

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

          end do        ! end of loop on nc

!.... for all columns

          nc = 1

          p = i + 1
          r = i + 2

          do m = 1, nblk
            do iv = 1, nsys
              mult(iv) = mat(iv,p,m,nc,2)
              rhs(iv,p,m) = rhs(iv,p,m) + mult(iv) * rhs(iv,i,nc)
            end do

            do iv = 1, nsys
              mult(iv) = mat(iv,r,m,nc,1)
              rhs(iv,r,m) = rhs(iv,r,m) + mult(iv) * rhs(iv,i,nc)
            end do

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

            do iv = 1, nsys
              mult(iv) = per2(iv,n-1,m,nc,i)
              rhs(iv,n-1,m) = rhs(iv,n-1,m) + mult(iv) * rhs(iv,i,nc)
            end do

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

            do iv = 1, nsys
              mult(iv) = per2(iv,n,m,nc,i)
              rhs(iv,n,m) = rhs(iv,n,m) + mult(iv) * rhs(iv,i,nc)
            end do

          end do        ! end of loop on m

          do nc = 2, nblk

            p = i + 1
            r = i + 2

            do m = 1, nblk
              do iv = 1, nsys
                mult(iv) = mat(iv,p,m,nc,2)
                rhs(iv,p,m) = rhs(iv,p,m) + mult(iv) * rhs(iv,i,nc)
              end do

              do iv = 1, nsys
                mult(iv) = mat(iv,r,m,nc,1)
                rhs(iv,r,m) = rhs(iv,r,m) + mult(iv) * rhs(iv,i,nc)
              end do

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

              do iv = 1, nsys
                mult(iv) = per2(iv,n-1,m,nc,i)
                rhs(iv,n-1,m) = rhs(iv,n-1,m) + mult(iv) * rhs(iv,i,nc)
              end do

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

              do iv = 1, nsys
                mult(iv) = per2(iv,n,m,nc,i)
                rhs(iv,n,m) = rhs(iv,n,m) + mult(iv) * rhs(iv,i,nc)
              end do

            end do      ! end of loop on m

          end do        ! end of loop on nc

        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
              do iv = 1, nsys
                mult(iv) = mat(iv,i,l,nc,3)
                rhs(iv,i,l) = rhs(iv,i,l) + mult(iv) * rhs(iv,i,nc)
              end do
            end do

          end do        ! end of loop on nc

!.... for all columns

          nc = 1

          p = i + 1
          r = i + 2

          do m = 1, nblk
            do iv = 1, nsys
              mult(iv) = mat(iv,p,m,nc,2)
              rhs(iv,p,m) = rhs(iv,p,m) + mult(iv) * rhs(iv,i,nc)
            end do

            do iv = 1, nsys
              mult(iv) = mat(iv,r,m,nc,1)
              rhs(iv,r,m) = rhs(iv,r,m) + mult(iv) * rhs(iv,i,nc)
            end do

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

            do iv = 1, nsys
              mult(iv) = per2(iv,n-1,m,nc,i)
              rhs(iv,n-1,m) = rhs(iv,n-1,m) + mult(iv) * rhs(iv,i,nc)
            end do

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

            do iv = 1, nsys
              mult(iv) = per2(iv,n,m,nc,i)
              rhs(iv,n,m) = rhs(iv,n,m) + mult(iv) * rhs(iv,i,nc)
            end do

          end do        ! end of loop on m

          do nc = 2, nblk

            p = i + 1
            r = i + 2

            do m = 1, nblk
              do iv = 1, nsys
                mult(iv) = mat(iv,p,m,nc,2)
                rhs(iv,p,m) = rhs(iv,p,m) + mult(iv) * rhs(iv,i,nc)
              end do

              do iv = 1, nsys
                mult(iv) = mat(iv,r,m,nc,1)
                rhs(iv,r,m) = rhs(iv,r,m) + mult(iv) * rhs(iv,i,nc)
              end do

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

              do iv = 1, nsys
                mult(iv) = per2(iv,n-1,m,nc,i)
                rhs(iv,n-1,m) = rhs(iv,n-1,m) + mult(iv) * rhs(iv,i,nc)
              end do

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

              do iv = 1, nsys
                mult(iv) = per2(iv,n,m,nc,i)
                rhs(iv,n,m) = rhs(iv,n,m) + mult(iv) * rhs(iv,i,nc)
              end do

            end do      ! end of loop on m

          end do        ! end of loop on nc

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

!.... do the first four columns

          do nc = 1, nblk - 1

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

          end do        ! end of loop on nc

!.... for all columns

          do nc = 1, nblk

            p = i + 1
            r = i + 2

            do m = 1, nblk
              do iv = 1, nsys
                mult(iv) = mat(iv,p,m,nc,2)
                rhs(iv,p,m) = rhs(iv,p,m) + mult(iv) * rhs(iv,i,nc)
              end do

              do iv = 1, nsys
                mult(iv) = mat(iv,r,m,nc,1)
                rhs(iv,r,m) = rhs(iv,r,m) + mult(iv) * rhs(iv,i,nc)
              end do

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

              do iv = 1, nsys
                mult(iv) = per2(iv,n-1,m,nc,i)
                rhs(iv,n-1,m) = rhs(iv,n-1,m) + mult(iv) * rhs(iv,i,nc)
              end do

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

              do iv = 1, nsys
                mult(iv) = per2(iv,n,m,nc,i)
                rhs(iv,n,m) = rhs(iv,n,m) + mult(iv) * rhs(iv,i,nc)
              end do

            end do      ! end of loop on m

          end do        ! end of loop on nc

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

!.... do the first four columns

          do nc = 1, nblk - 1

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

          end do        ! end of loop on nc

!.... for all columns

          do nc = 1, nblk

            p = i + 1
            r = i + 2

            do m = 1, nblk
              do iv = 1, nsys
                mult(iv) = mat(iv,p,m,nc,2)
                rhs(iv,p,m) = rhs(iv,p,m) + mult(iv) * rhs(iv,i,nc)
              end do

              do iv = 1, nsys
                mult(iv) = mat(iv,r,m,nc,1)
                rhs(iv,r,m) = rhs(iv,r,m) + mult(iv) * rhs(iv,i,nc)
              end do

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

              do iv = 1, nsys
                mult(iv) = per2(iv,n,m,nc,i)
                rhs(iv,n,m) = rhs(iv,n,m) + mult(iv) * rhs(iv,i,nc)
              end do

            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
              do iv = 1, nsys
                mult(iv) = mat(iv,i,l,nc,3)
                rhs(iv,i,l) = rhs(iv,i,l) + mult(iv) * rhs(iv,i,nc)
              end do
            end do

          end do        ! end of loop on nc

!.... for all columns

          do nc = 1, nblk

            p = i + 1
            r = i + 2

            do m = 1, nblk
              do iv = 1, nsys
                mult(iv) = mat(iv,p,m,nc,2)
                rhs(iv,p,m) = rhs(iv,p,m) + mult(iv) * rhs(iv,i,nc)
              end do

              do iv = 1, nsys
                mult(iv) = mat(iv,r,m,nc,1)
                rhs(iv,r,m) = rhs(iv,r,m) + mult(iv) * rhs(iv,i,nc)
              end do

            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
              do iv = 1, nsys
                mult(iv) = mat(iv,i,l,nc,3)
                rhs(iv,i,l) = rhs(iv,i,l) + mult(iv) * rhs(iv,i,nc)
              end do
            end do

          end do        ! end of loop on nc

!.... for all columns

          do nc = 1, nblk

            p = i + 1

            do m = 1, nblk
              do iv = 1, nsys
                mult(iv) = mat(iv,p,m,nc,2)
                rhs(iv,p,m) = rhs(iv,p,m) + mult(iv) * rhs(iv,i,nc)
              end do
            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
            do iv = 1, nsys
              mult(iv) = mat(iv,i,l,nc,3)
              rhs(iv,i,l) = rhs(iv,i,l) + mult(iv) * rhs(iv,i,nc)
            end do
          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
            do iv = 1, nsys
              rhs(iv,i,m) = rhs(iv,i,m) - rhs(iv,i,q) * mat(iv,i,m,q,3)
            end do
          end do
          do iv = 1, nsys
            rhs(iv,i,m) = rhs(iv,i,m) / mat(iv,i,m,m,3)
          end do
        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
            do iv = 1, nsys
              rhs(iv,i,m) = rhs(iv,i,m) - rhs(iv,i,q) * mat(iv,i,m,q,3)
            end do
          end do
          do q = 1, nblk
            do iv = 1, nsys
              rhs(iv,i,m) = rhs(iv,i,m) - rhs(iv,p,q) * mat(iv,i,m,q,4)
            end do
          end do
          do iv = 1, nsys
            rhs(iv,i,m) = rhs(iv,i,m) / mat(iv,i,m,m,3)
          end do
        end do

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

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

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

        do m = nblk, 1, -1
          do q = m+1, nblk
            do iv = 1, nsys
              rhs(iv,i,m) = rhs(iv,i,m) - rhs(iv,i,q) * mat(iv,i,m,q,3)
            end do
          end do
          do q = 1, nblk
            do iv = 1, nsys
              rhs(iv,i,m) = rhs(iv,i,m) - rhs(iv,p,q) * mat(iv,i,m,q,4)
              rhs(iv,i,m) = rhs(iv,i,m) - rhs(iv,r,q) * mat(iv,i,m,q,5)
              rhs(iv,i,m) = rhs(iv,i,m) - rhs(iv,n,q) * per(iv,i,m,q,2)
            end do
          end do
          do iv = 1, nsys
            rhs(iv,i,m) = rhs(iv,i,m) / mat(iv,i,m,m,3)
          end do
        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
              do iv = 1, nsys
                rhs(iv,i,m) = rhs(iv,i,m) - rhs(iv,i,q) * mat(iv,i,m,q,3)
              end do
            end do
            do q = 1, nblk
              do iv = 1, nsys
                rhs(iv,i,m) = rhs(iv,i,m) - rhs(iv,p,q) * mat(iv,i,m,q,4)
                rhs(iv,i,m) = rhs(iv,i,m) - rhs(iv,r,q) * mat(iv,i,m,q,5)
                rhs(iv,i,m) = rhs(iv,i,m) - rhs(iv,n-1,q) * per(iv,i,m,q,1)
                rhs(iv,i,m) = rhs(iv,i,m) - rhs(iv,n  ,q) * per(iv,i,m,q,2)
              end do
            end do
            do iv = 1, nsys
              rhs(iv,i,m) = rhs(iv,i,m) / mat(iv,i,m,m,3)
            end do
          end do

        end do

!.... account for periodicity

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

        end if
!=============================================================================!
        return
        end

        subroutine rzero( n, x)

        integer n, i
        complex x(n)

        do i = 1, n
          x(i) = 0.0
        end do

        return
        end


program ahmk
  USE DMFT_IPT
  USE DMFT_TOOLS
  USE SCIFOR
  implicit none
  integer                :: i,ik,Lk,iloop,p,q,Lf,Lmts,L
  logical                :: converged
  complex(8)             :: zdet,zeta1,zeta2,x1,x2
  real(8)                :: delta,n,A,B,nf,nfL,nfR,ekin,dzeta1,dzeta2,D,dt,fmesh,tmax
  !
  complex(8),allocatable :: sigma(:,:),fg(:,:),wf0(:,:),calG(:,:),dummy(:,:)
  complex(8),allocatable :: zeta(:),fgm(:,:),sm(:,:),fg0m(:,:),cdet0(:),cdet(:)
  !
  real(8),allocatable    :: wt(:),epsik(:),wr(:),t(:),wrx(:),en(:),nk(:),ddet(:),ipoles(:),dos(:),dSigma(:)
  !
  type(keldysh_gf)       :: fg0k(2),sk(2),calG11,calG22,calF12,calF21
  !
  real(8)                :: vbias,wxmax,dos_max
  integer                :: dos_maxloc,sigma_pole
  logical                :: type,thermo,poles,octype,spole
  type(finter_type)      :: det_finter
  character(len=10)      :: vchar

  call parse_input_variable(Lk,'Lk','inputIPT.in',default=1000)
  call parse_input_variable(vbias,'VBIAS','inputIPT.in',default=0d0)
  call parse_input_variable(D,'wband','inputIPT.in',default=1d0)
  call parse_input_variable(L,"L",'inputIPT.in',default=10000)
  call parse_input_variable(Lf,"LF",'inputIPT.in',default=4096)
  call parse_input_variable(Lmts,"Lmts",'inputIPT.in',default=4096)
  call parse_input_variable(poles,"POLES",'inputIPT.in',default=.false.)
  call parse_input_variable(octype,"OCTYPE",'inputIPT.in',default=.false.)
  call parse_input_variable(thermo,"THERMO",'inputIPT.in',default=.false.)
  call parse_input_variable(spole,"SPOLE",'inputIPT.in',default=.false.)

  call read_input("inputIPT.in")

  allocate(fg(2,L))
  allocate(sigma(2,L))
  allocate(wf0(2,L))
  allocate(calG(2,L))
  allocate(zeta(L))

  call allocate_gf(fg0k(1),L);  call allocate_gf(fg0k(2),L)
  call allocate_gf(sk(1),L)  ;  call allocate_gf(sk(2),L)
  call allocate_gf(calG11,L)
  call allocate_gf(calG22,L)
  call allocate_gf(calF12,L)
  call allocate_gf(calF21,L)

  dt  = pi/wmax;print*,dt
  tmax= dt*L/2
  allocate(wr(L),t(0:L))
  wr =  linspace(-wmax,wmax,L,mesh=fmesh)
  t   = linspace(-tmax,tmax,L+1,mesh=dt)
  print*,"MESH="//txtfy(fmesh)

  call get_initial_sigma

  if(thermo)then
     call get_thermo()
     stop
  endif
  if(poles)then
     call get_poles()
     stop
  endif
  if(spole)then
     call get_spole()
     stop
  endif
  if(octype)then
     call get_octype()
     stop
  endif

  iloop=0    ; converged=.false.
  do while (.not.converged)
     iloop=iloop+1
     write(*,"(A,i5)",advance="no")"DMFT-loop",iloop

     !GETGLOC:
     fg=zero
     zeta(:) = cmplx(wr(:),eps,8) + xmu - sigma(1,:)
     do i=1,L
        zeta1 = zeta(i)
        zeta2 = conjg(zeta(L+1-i))
        x1 = 0.5d0*((zeta1+zeta2) + sqrt((zeta1-zeta2)**2 - 4.d0*conjg(sigma(2,L+1-i))*sigma(2,i) ))
        x2 = 0.5d0*((zeta1+zeta2) - sqrt((zeta1-zeta2)**2 - 4.d0*conjg(sigma(2,L+1-i))*sigma(2,i) ))
        fg(1,i) = zeta2/(x2-x1)*(gfbether(wr(i),x1,D)-gfbether(wr(i),x2,D))
        fg(2,i) =-conjg(sigma(2,L+1-i))/(x2-x1)*(gfbether(wr(i),x1,D)-gfbether(wr(i),x2,D))
     enddo
     delta=-uloc(1)*trapz(fmesh,dimag(fg(2,:))*istep(wr))/pi
     n=-trapz(fmesh,dimag(fg(1,:))*istep(wr))/pi

     !GET THE WEISS FIELD \calG0^-1(w)
     ! wf(1)=calG0^-1 = G*(-w)/(G(w)G*(-w) + F(w)F(-w)) + Sigma(w)
     ! wf(2)=calF0^-1 =-F(-w) /(G(w)G*(-w) + F(w)F(-w)) + S(w)
     do i=1,L
        zdet     = fg(1,i)*conjg(fg(1,L+1-i)) + conjg(fg(2,L+1-i))*fg(2,i)
        wf0(1,i)= conjg(fg(1,L+1-i))/zdet  + sigma(1,i)        !+  uloc(1)*(n-0.5d0)
        wf0(2,i)= fg(2,i)/zdet       + conjg(sigma(2,L+1-i))   + delta
     end do
     do i=1,L
        zdet      =  wf0(1,i)*conjg(wf0(1,L+1-i)) + conjg(wf0(2,L+1-i))*wf0(2,i)
        calG(1,i)=  conjg(wf0(1,L+1-i))/zdet
        calG(2,i)=  conjg(wf0(2,L+1-i))/zdet
     end do
     !
     fg0k(1)=zero ; fg0k(2)=zero
     do i=1,L
        A = -dimag(calG(1,i))/pi
        B = -dimag(calG(2,i))/pi
        nfL= istep(wr(i)-vbias/2.d0)!fermi(wr(i)-vbias/2.d0,beta)
        nfR= istep(wr(i)+vbias/2.d0)!fermi(wr(i)+vbias/2.d0,beta)
        nf= (nfL+nfR)/2.d0
        fg0k(1)%less%w(i) = pi2*xi*nf*A
        fg0k(1)%gtr%w(i)  = pi2*xi*(nf-1.d0)*A
        fg0k(2)%less%w(i) = pi2*xi*nf*B
        fg0k(2)%gtr%w(i)  = pi2*xi*(nf-1.d0)*B
     enddo
     !
     calG11%less%w = fg0k(1)%less%w
     calG11%gtr%w = fg0k(1)%gtr%w
     forall(i=1:L)calG22%less%w(i) = -(fg0k(1)%gtr%w(L+1-i))
     forall(i=1:L)calG22%gtr%w(i) = -(fg0k(1)%less%w(L+1-i))
     calF12%less%w   = -conjg(fg0k(2)%less%w)
     calF12%gtr%w   =  fg0k(2)%gtr%w
     calF21%less%w   = fg0k(2)%less%w
     calF21%gtr%w   = -conjg(fg0k(2)%gtr%w)
     !
     calG11%less%t = f_fft_rw2rt(calG11%less%w)*fmesh/pi2
     calG11%gtr%t  = f_fft_rw2rt(calG11%gtr%w)*fmesh/pi2
     calG22%less%t = f_fft_rw2rt(calG22%less%w)*fmesh/pi2
     calG22%gtr%t  = f_fft_rw2rt(calG22%gtr%w)*fmesh/pi2
     calF12%less%t = f_fft_rw2rt(calF12%less%w)*fmesh/pi2
     calF12%gtr%t  = f_fft_rw2rt(calF12%gtr%w)*fmesh/pi2
     calF21%less%t = f_fft_rw2rt(calF21%less%w)*fmesh/pi2
     calF21%gtr%t  = f_fft_rw2rt(calF21%gtr%w)*fmesh/pi2
     do i=0,L
        sk(1)%less%t(i) = Uloc(1)**2*(calG11%less%t(i)*calG22%less%t(i) - calF12%less%t(i)*calF21%less%t(i))*calG22%gtr%t(L-i)
        sk(1)%gtr%t(i) =  Uloc(1)**2*(calG11%gtr%t(i)*calG22%gtr%t(i) - calF12%gtr%t(i)*calF21%gtr%t(i))*calG22%less%t(L-i)
        sk(2)%less%t(i) = Uloc(1)**2*(calF12%less%t(i)*calF21%less%t(i) - calG11%less%t(i)*calG22%less%t(i))*calF12%gtr%t(L-i)
        sk(2)%gtr%t(i) =  Uloc(1)**2*(calF12%gtr%t(i)*calF21%gtr%t(i)  - calG11%gtr%t(i)*calG22%gtr%t(i))*calF12%less%t(L-i)
        sk(1)%ret%t(i) =heaviside(t(i))*(sk(1)%gtr%t(i)-sk(1)%less%t(i))
        sk(2)%ret%t(i) =heaviside(t(i))*(sk(2)%gtr%t(i)-sk(2)%less%t(i))
     enddo
     !
     if(heaviside(0.d0)==1.d0)sk(1)%ret%t(0)=sk(1)%ret%t(0)/2.d0
     if(heaviside(0.d0)==1.d0)sk(2)%ret%t(0)=sk(2)%ret%t(0)/2.d0
     !
     sk(1)%ret%w = f_fft_rt2rw(sk(1)%ret%t)*dt
     sk(2)%ret%w = f_fft_rt2rw(sk(2)%ret%t)*dt
     !
     sigma(1,:) = sk(1)%ret%w
     sigma(2,:) = -delta + sk(2)%ret%w
     ! sigma = ipt_solve_keldysh_sc(calG,delta,vbias)
     write(*,"(2f14.9)",advance="no")2.d0*n,delta
     converged = check_convergence(sigma(1,:)+sigma(2,:),eps=dmft_error,N1=Nsuccess,N2=Nloop)
     !if(printf)call splot("observables.ipt",vbias,delta,xmu,u,n,beta,dble(iloop),append=.true.)
  enddo

  call splot("observables.last",vbias,delta,xmu,uloc(1),n,beta,dble(iloop))
  call splot("Sigma_realw.restart",wr,sigma(1,:))
  call splot("Self_realw.restart",wr,sigma(2,:))

  !REDUCE size for printing.
  if(mod(Lf,2)/=0)Lf=Lf+1
  allocate(wrx(Lf),dummy(2,Lf))
  wrx = linspace(-wmax,wmax,Lf)

  call cubic_spline(wr(:),fg(1,:),wrx,dummy(1,:))
  call splot("DOS.last",wrx,-dimag(dummy(1,:))/pi)
  !
  call cubic_spline(wr,fg(1,:),wrx,dummy(1,:))
  call cubic_spline(wr,fg(2,:),wrx,dummy(2,:))
  call splot("G_realw.last",wrx,dummy(1,:))
  call splot("F_realw.last",wrx,dummy(2,:))
  !
  call cubic_spline(wr,calG(1,:),wrx,dummy(1,:))
  call cubic_spline(wr,calG(2,:),wrx,dummy(2,:))
  call splot("calG0_realw.last",wrx,dummy(1,:))
  call splot("calF0_realw.last",wrx,dummy(2,:))
  !
  call cubic_spline(wr,sigma(1,:),wrx,dummy(1,:))
  call cubic_spline(wr,sigma(2,:),wrx,dummy(2,:))
  call splot("Sigma_realw.last",wrx,dummy(1,:))
  call splot("Self_realw.last",wrx,dummy(2,:))
  !
  deallocate(wrx,dummy)

  !##################################################################
  !##################################################################
contains
  !##################################################################
  !##################################################################

  function det_poles(w) result(det_)
    real(8),intent(in) :: w
    real(8) :: det_
    det_ = finter(det_finter,w)
  end function det_poles

  elemental function istep(x) result(out)
    real(8),intent(in) :: x
    real(8)            :: out
    if(x < 0.d0) then
       out = 1.0d0
    elseif(x==0.d0)then
       out = 0.50d0
    else
       out = 0.0d0
    endif
  end function istep

  subroutine get_initial_sigma()
    logical                :: check1,check2,check
    inquire(file="Sigma_realw.restart",exist=check1)
    inquire(file="Self_realw.restart",exist=check2)
    check=check1.AND.check2
    if(check)then
       write(*,*)"Reading Sigma in input:"
       call sread("Sigma_realw.restart",wr,sigma(1,:))
       call sread("Self_realw.restart",wr,sigma(2,:))
    else
       print*,"Using Hartree-Fock self-energy"
       print*,"===================================="
       n=0.5d0 ;  delta=deltasc
       sigma(2,:)=-delta ; sigma(1,:)=zero
    endif
  end subroutine get_initial_sigma

  subroutine get_sc_optical_conductivity(L,wr,sigma)
    integer                :: L
    real(8)                :: wr(L),D,dw
    complex(8)             :: sigma(2,L)
    integer                :: i,ik,iv,iw,Nw
    real(8)                :: vel2,dos,Dfermi,A2,B2,ock
    complex(8)             :: zdet,zeta1,zeta2,fg(2)
    real(8),allocatable    :: oc(:), Ak(:,:,:),cDOS(:,:),ocw(:)
    complex(8),allocatable :: zeta(:)

    print*,"Get OC with:",L,"freq."
    Nw=L/2
    allocate(Ak(2,Lk,L),zeta(L))

    dw = abs(wr(2)-wr(1))
    allocate(cDOS(2,L))
    cDOS=0.d0
    zeta(:) = cmplx(wr(:),eps,8) + xmu - sigma(1,:)
    do i=1,L
       zeta1 = zeta(i)
       zeta2 = conjg(zeta(L+1-i))
       do ik=1,Lk
          zdet = (zeta1-epsik(ik))*(zeta2-epsik(ik)) + conjg(sigma(2,L+1-i))*sigma(2,i)
          fg(1)=(zeta2-epsik(ik))/zdet
          fg(2)=conjg(sigma(2,L+1-i))/zdet
          Ak(1,ik,i)=-dimag(fg(1))/pi
          Ak(2,ik,i)=-dimag(fg(2))/pi
          cDOS(1,i)=cDOS(1,i)+Ak(1,ik,i)*wt(ik)
          cDOS(2,i)=cDOS(2,i)+Ak(2,ik,i)*wt(ik)
       enddo
    enddo
    call splot("ocDOS.last",wr,cDOS(1,:),cDOS(2,:))
    deallocate(cDOS)
    ! do ik=1,Lk
    !    do i=1,L
    !       write(100,*)wr(i),Ak(1,ik,i)
    !       write(200,*)wr(i),Ak(2,ik,i)
    !    enddo
    !    write(100,*)""
    !    write(200,*)""
    ! enddo

    !Changing the loop order does not affect the calculation.
    allocate(oc(Nw),ocw(L))
    oc=0.d0
    call start_progress
    do iv=1,Nw
       ocw   = 0.d0
       do iw=1,L-iv
          Dfermi  = istep(wr(iw)) - istep(wr(iw+iv))
          ock=0.d0
          do ik=1,Lk
             A2 = Ak(1,ik,iw)*Ak(1,ik,iw+iv)
             B2 = Ak(2,ik,iw)*Ak(2,ik,iw+iv)
             vel2= (D**2-epsik(ik)**2)/3.d0
             ock = ock + vel2*(A2-B2)*wt(ik)
          enddo
          ocw(iw) = Dfermi*ock
       enddo
       oc(iv)=trapz(dw,ocw(:L-iv))/wr(Nw+iv)
       call progress(iv,Nw)
    enddo
    call stop_progress
    call splot("OC_realw.ipt",wr(Nw+1:L),oc(:))
    call splot("OC_integral.ipt",vbias,trapz(dw,oc))
  end subroutine get_sc_optical_conductivity

  subroutine get_thermo()
    !GET Matsubara functions (not working well: aka only at large enough temperature,
    !because of the finite broadening you can not resolve infinitely small energies/temp)
    converged=.true.
    beta=1000.d0
    fg=zero
    zeta(:) = cmplx(wr(:),eps,8) + xmu - sigma(1,:)
    do i=1,L
       zeta1 = zeta(i)
       zeta2 = conjg(zeta(L+1-i))
       x1 = 0.5d0*((zeta1+zeta2) + sqrt((zeta1-zeta2)**2 - 4.d0*conjg(sigma(2,L+1-i))*sigma(2,i) ))
       x2 = 0.5d0*((zeta1+zeta2) - sqrt((zeta1-zeta2)**2 - 4.d0*conjg(sigma(2,L+1-i))*sigma(2,i) ))
       fg(1,i) = zeta2/(x2-x1)*(gfbether(wr(i),x1,D)-gfbether(wr(i),x2,D))
       fg(2,i) =-conjg(sigma(2,L+1-i))/(x2-x1)*(gfbether(wr(i),x1,D)-gfbether(wr(i),x2,D))
    enddo
    delta=-uloc(1)*sum(dimag(fg(2,:))*fermi(wr,beta))*fmesh/pi
    n    =-sum(dimag(fg(1,:))*fermi(wr,beta))*fmesh/pi
    allocate(wrx(Lmts),fgm(2,Lmts),fg0m(2,Lmts),sm(2,Lmts))
    wrx = pi/beta*real(2*arange(1,Lmts)-1,8)
    allocate(wt(Lk),epsik(Lk),nk(Lk))
    call bethe_lattice(wt,epsik,Lk,1d0)
    write(*,*)"Get Matsubara GF:",Lmts
    print*,'G(iw)'
    call get_matsubara_gf_from_dos(wr,fg(1,:),fgm(1,:),beta)
    print*,'F(iw)'
    call get_matsubara_gf_from_dos(wr,fg(2,:),fgm(2,:),beta)
    print*,'Sigma(iw)'
    call get_matsubara_gf_from_dos(wr,sigma(1,:),sm(1,:),beta)
    print*,'S(iw)'
    call get_matsubara_gf_from_dos(wr,sigma(2,:),sm(2,:),beta)
    fgm(2,:)=dreal(fgm(2,:))
    sm(2,:)=dreal(sm(2,:))-delta
    call splot("G_iw.last",wrx,fgm(1,:))
    call splot("F_iw.last",wrx,fgm(2,:))
    call splot("G0_iw.last",wrx,fg0m(1,:))
    call splot("F0_iw.last",wrx,fg0m(2,:))
    call splot("Sigma_iw.last",wrx,sm(1,:))
    call splot("Self_iw.last",wrx,sm(2,:))
    call get_sc_internal_energy(Lmts,wrx,fgm,sm,L,wr,fg)
  end subroutine get_thermo

  subroutine get_poles()
    converged=.true.
    allocate(wt(Lk),epsik(Lk),nk(Lk),ddet(L),ipoles(Lk))
    call bethe_lattice(wt,epsik,Lk,D)
    zeta(:) = wr(:) + xmu - sigma(1,:)
    do ik=1,Lk
       do i=1,L
          dzeta1 = dreal(zeta(i))
          dzeta2 = dreal(zeta(L+1-i))
          ddet(i) = (dzeta1-epsik(ik))*(dzeta2-epsik(ik))+dreal(sigma(2,L+1-i))*dreal(Sigma(2,i))
       enddo
       call init_finter(det_finter,wr,ddet,5)
       ipoles(ik) = fzero_brentq(det_poles,0.d0,wr(L))
    enddo
    call splot("poles.last",epsik,ipoles)
  end subroutine get_poles

  subroutine get_spole()
    !EVALUATE THE SPECTRAL FUNCTION
    fg=zero
    allocate(dos(L))
    allocate(dSigma(L))
    zeta(:) = cmplx(wr(:),eps,8) + xmu - sigma(1,:)
    do i=1,L
       zeta1 = zeta(i)
       zeta2 = conjg(zeta(L+1-i))
       x1 = 0.5d0*((zeta1+zeta2) + sqrt((zeta1-zeta2)**2 - 4.d0*conjg(sigma(2,L+1-i))*sigma(2,i) ))
       x2 = 0.5d0*((zeta1+zeta2) - sqrt((zeta1-zeta2)**2 - 4.d0*conjg(sigma(2,L+1-i))*sigma(2,i) ))
       fg(1,i) = zeta2/(x2-x1)*(gfbether(wr(i),x1,D)-gfbether(wr(i),x2,D))
       fg(2,i) =-conjg(sigma(2,L+1-i))/(x2-x1)*(gfbether(wr(i),x1,D)-gfbether(wr(i),x2,D))
    enddo
    dos = -dimag(fg(1,:))/pi
    dos_max=maxval(dos)
    dos_maxloc=int(maxloc(dos,dim=1))
    open(100,file="qpDOSinfo.ipt")
    write(100,*)wr(dos_maxloc),-dimag(fg(1,dos_maxloc))/pi,dreal(fg(1,dos_maxloc))
    close(100)
    open(100,file="qpFinfo.ipt")
    write(100,*)wr(dos_maxloc),dimag(fg(2,dos_maxloc)),dreal(fg(2,dos_maxloc))
    close(100)
    open(100,file="qpzSigma.ipt")
    write(100,*)wr(dos_maxloc),dimag(sigma(1,dos_maxloc)),dreal(sigma(1,dos_maxloc))
    close(100)
    open(100,file="qpzSelf.ipt")
    write(100,*)wr(dos_maxloc),dimag(sigma(2,dos_maxloc)),dreal(sigma(2,dos_maxloc))
    close(100)
    open(100,file="Sigma_zero.ipt")
    write(100,*)0.5d0*(dimag(sigma(1,L/2))+dimag(sigma(1,L/2+1))),0.5d0*(dreal(sigma(1,L/2))+dreal(sigma(1,L/2+1)))
    close(100)
    dSigma = deriv(dreal(Sigma(1,:)),fmesh)
    open(100,file="ZdReSigma_realw.ipt")
    write(100,*)1.d0/(1.d0-dSigma(dos_maxloc)),dSigma(dos_maxloc)
    close(100)
    print*,dos_max,dos_maxloc,dimag(sigma(1,dos_maxloc))
    print*,1/(1-dSigma(dos_maxloc)),dSigma(dos_maxloc)
  end subroutine get_spole

  subroutine get_octype()
    converged=.true.
    if(mod(Lf,2)/=0)Lf=Lf+1
    allocate(wrx(Lf),dummy(2,Lf))
    wrx = linspace(-wxmax,wxmax,Lf)
    call cubic_spline(wr,sigma(1,:),wrx,dummy(1,:))
    call cubic_spline(wr,sigma(2,:),wrx,dummy(2,:))
    call splot("Sigma_realw_oc.last",wrx,dummy(1,:))
    call splot("Self_realw_oc.last",wrx,dummy(2,:))
    allocate(wt(Lk),epsik(Lk))
    call bethe_lattice(wt,epsik,Lk,D)
    call get_sc_optical_conductivity(Lf,wrx,dummy)
    deallocate(wt,epsik,wrx,dummy)
  end subroutine get_octype

  subroutine get_sc_internal_energy(L,wm,fg,sigma,Lr,wr,fgr)
    integer    :: L,Lr
    real(8)    :: wm(L),wr(Lr)
    complex(8) :: fg(2,L),sigma(2,L),fgr(2,Lr)
    integer    :: i,ik
    real(8)    :: matssum,fmatssum,checkP,checkdens,vertex,Dssum
    complex(8) :: iw,gkw,fkw,g0kw,f0kw
    real(8)    :: Epot,Etot,Eint,kin,kinsim,Ds,docc
    real(8)    :: Sigma_infty,S_infty,zdet,det_infty,csi,Ei,thermal_factor
    real(8)    :: free(Lk),Ffree(Lk),n_k(Lk)

    !Get asymptotic self-energies
    Sigma_infty =   dreal(sigma(1,L))
    S_infty     =   dreal(sigma(2,L))

    checkP=0.d0 ; checkdens=0.d0 ;          ! test variables

    call start_progress
    kin=0.d0                      ! kinetic energy (generic)
    Ds=0.d0                       ! superfluid stiffness (Bethe)
    do ik=1,Lk
       csi            = epsik(ik)-(xmu-Sigma_infty)
       Ei             = dsqrt(csi**2 + S_infty**2)
       thermal_factor = dtanh(0.5d0*beta*Ei)
       free(ik)        = 0.5d0*(1.d0 - csi/Ei)*thermal_factor
       Ffree(ik)       =-(0.5d0*S_infty)/Ei*thermal_factor

       fmatssum= 0.d0
       matssum = 0.d0
       Dssum   = 0.d0

       vertex=(D**2-epsik(ik)**2)/3.d0

       do i=1,L
          iw       = xi*wm(i)
          zdet      = abs(iw+xmu-epsik(ik)-sigma(1,i))**2 + real(sigma(2,i),8)**2
          det_infty= wm(i)**2 + (epsik(ik)-(xmu-Sigma_infty))**2 + S_infty**2

          gkw = (-iw+xmu - epsik(ik) - conjg(sigma(1,i)) )/zdet
          fkw = -sigma(2,i)/zdet

          g0kw= (-iw - (epsik(ik)-(xmu-Sigma_infty)))/det_infty
          f0kw=-S_infty/det_infty

          matssum =  matssum +  dreal(gkw)-dreal(g0kw)
          fmatssum= fmatssum +  dreal(fkw)-dreal(f0kw)
          Dssum   = Dssum    +  fkw*fkw
       enddo

       n_k(ik)   = 4.d0/beta*matssum + 2.d0*free(ik)
       checkP    = checkP    - wt(ik)*(2.d0/Beta*fmatssum+Ffree(ik))
       checkdens = checkdens + wt(ik)*n_k(ik)
       kin    = kin    + wt(ik)*n_k(ik)*epsik(ik)
       Ds=Ds + 8.d0/beta* wt(ik)*vertex*Dssum
       call progress(ik,Lk)
    enddo
    call stop_progress

    kinsim=0.d0
    do i=1,Lr
       kinsim = kinsim - &
            4.d0/pi*fermi(wr(i),beta)*dimag(fgr(1,i))*dreal(fgr(1,i)) + &
            4.d0/pi*fermi(wr(i),beta)*dimag(fgr(2,i))*dreal(fgr(2,i))
    enddo
    print*,kinsim*(wr(2)-wr(1))*D/4d0

    kinsim=0.d0
    kinsim = sum(fg(1,:)*fg(1,:)+conjg(fg(1,:))*conjg(fg(1,:))-2.d0*fg(2,:)*fg(2,:))*D**2/2d0/beta
    print*,kinsim

    Epot=zero
    Epot = sum(fg(1,:)*sigma(1,:) + fg(2,:)*sigma(2,:))/beta*2.d0

    docc = 0.5d0*n**2
    if(uloc(1) > 0.01d0)docc=-Epot/uloc(1) + n - 0.25d0

    Eint=kin+Epot

    Ds=zero
    Ds = sum(fg(2,:)*fg(2,:))/beta*2.d0

    write(*,*)"Asymptotic Self-Energies",Sigma_infty, S_infty
    write(*,*)"n,delta",n,delta
    write(*,*)"Dn% ,Ddelta%",(n-0.5d0*checkdens)/n,(delta + uloc(1)*checkP)/delta ! u is positive
    write(*,*)'========================================='
    write(*,*)"Kinetic energy",kin
    write(*,*)'========================================='
    write(*,*)"double occupancy   =",docc
    write(*,*)'========================================='
    write(*,*) 'Kinetic Energy TEST (simple formula)'
    write(*,*) '###ACTHUNG: FOR BETHE ONLY####',kinsim
    write(*,*) 'Dkin%',(kin-kinsim)/kin
    write(*,*)'========================================='
    write(*,*) 'Superfluid stiffness',Ds
    write(*,*) 'Potential Energy U(n_up-1/2)(n_do-1/2)',Epot
    write(*,*) 'Internal Energy',Eint
    write(*,*)'========================================='
    call splot("nk_distribution.ipt",epsik,n_k/2.d0,free)
    open(100,file="columns.ipt")
    write(100,"(11A21)")"1vbias","2u","3beta","4n","5kin","6docc","7Ds","8Epot","9Eint"
    close(100)
    open(200,file="thermodynamics.ipt")
    write(200,"(11F21.12)")vbias,uloc(1),beta,n,kinsim,docc,Ds,Epot,Eint
    close(200)
    return
  end subroutine get_sc_internal_energy

end program ahmk


SUBROUTINE h1f(xi,eta,phi,m,n,lambda,h0,an,am,pt,crea_par)

! Code converted using TO_F90 by Alan Miller
! Date: 2002-10-04  Time: 09:55:55

doubleprecision xi
doubleprecision eta
doubleprecision phi
doubleprecision m
doubleprecision n
doubleprecision lambda
doubleprecision h0
doubleprecision an
doubleprecision am
doubleprecision pt
doubleprecision crea_par(3)

doubleprecision h1(3)
doubleprecision t1
doubleprecision t10
doubleprecision t100
doubleprecision t103
doubleprecision t108
doubleprecision t11
doubleprecision t112
doubleprecision t12
doubleprecision t13
doubleprecision t15
doubleprecision t16
doubleprecision t166
doubleprecision t17
doubleprecision t2
doubleprecision t21
doubleprecision t22
doubleprecision t23
doubleprecision t25
doubleprecision t28
doubleprecision t3
doubleprecision t30
doubleprecision t32
doubleprecision t35
doubleprecision t39
doubleprecision t4
doubleprecision t44
doubleprecision t45
doubleprecision t46
doubleprecision t5
doubleprecision t52
doubleprecision t56
doubleprecision t57
doubleprecision t62
doubleprecision t68
doubleprecision t7
doubleprecision t71
doubleprecision t78
doubleprecision t79
doubleprecision t8
doubleprecision t83
doubleprecision t94
doubleprecision t95
doubleprecision t99

t1 = xi**2
t2 = eta**2
t3 = t1-t2
t4 = SQRT(t3)
t5 = 1/t4
t7 = s(eta)
t8 = r(xi)
t10 = am*t5*t7*t8
t11 = (-1)**pt
t12 = t11*m
t13 = t(phi)
t15 = -1+t1
t16 = SQRT(t15)
t17 = 1/t16
t21 = 1/c
t22 = t21*t16
t23 = 1-t2
t25 = 1/t3
t28 = c**2
t30 = t2**2
t32 = m**2
t35 = (eta-1)**2
t39 = (eta+1)**2
t44 = 1/t23
t45 = 1/t15
t46 = t44*t45
t52 = t23*t25
t56 = t3**2
t57 = 1/t56
t62 = diff(r(xi),xi)
t68 = eta*t25
t71 = -t23
t78 = diff(s(eta),eta)
t79 = t78*t8
t83 = 1/t4/t3
h1(1) = (-t10*t12*t13*eta*t17+((-t22*t5*(xi*t23*t25*(-lambda+lam  &
    bda*t2+t28*t2-t28*t30+t32)/t35/t39-t32*xi*t46)*t8+t22*t5*(t52  &
    -2*t2*t25+2*t2*t23*t57)*t62)*t7-t22*t5*xi*(-2*t68+2*t23*t57  &
    *eta-2*t52*eta/t71)*t79+t22*t83*eta*t23*t78*t62)*t13*an)*h0
t94 = SQRT(t23)
t95 = 1/t94
t99 = t21*t94
t100 = eta*t15
t103 = t1**2
t108 = (xi-1)**2
t112 = (xi+1)**2
h1(2) = (t10*t12*t13*xi*t95+((t99*t5*(-t100*t25*(lambda*t1-lambd  &
    a-t28*t103+t28*t1+t32)/t108/t112+t32*eta*t46)*t8+2*t99/t4/t56  &
    *t100*t62*xi)*t7+t99*t5*t78*(t15*t25+2*t1*t25-2*t1*t15*t57)  &
    *t8+t99*t83*t78*xi*t15*t62)*t13*an)*h0
t166 = t21*m
h1(3) = ((t71*t62*eta*t16*t25*t95*t7-t71*t78*t8*xi*t16*t25*t95)*  &
  &  t13*am+((t166*t94*t16*t25*(-t45-t44)*t11*t8-t166*t95*t16*t25  &
    *xi*t62*t11)*t7-t166*t94*t17*t68*t79*t11)*t13*an)*h0
crea_par(1) = h1(1)
crea_par(2) = h1(2)
crea_par(3) = h1(3)
RETURN
RETURN
END SUBROUTINE h1f


use RandomClass
use FEMDomainClass
implicit none

type(Random_) :: random
type(FEMDomain_) :: domain
integer(int32) :: i

domain%mesh%nodcoord =zeros(10,2)

! set nodes
domain%mesh%nodcoord(1,:) = [-1.0d0,-1.0d0]
domain%mesh%nodcoord(2,:) = [ 2.0d0,-1.0d0]
domain%mesh%nodcoord(3,:) = [ 2.0d0, 2.0d0]
domain%mesh%nodcoord(4,:) = [-1.0d0, 2.0d0]
do i=5,domain%nn()
    domain%mesh%nodcoord(i,1) = random%random()
    domain%mesh%nodcoord(i,2) = random%random()
enddo

! mesh Delaunay 2D
call domain%meshing()

! Triangle to Rectangle
call domain%mesh%convertTriangleToRectangular()

! Modify shape
call domain%mesh%Laplacian()

! 2D to 3D
call domain%mesh%convert2Dto3D()

call domain%vtk("test")

end


      subroutine fissla(ist,b,a,s)
!c     implicit double precision (a-h,o-z)                                    dp
!c
!c     a fast implicit solver for systems of linear equations
!c
!c     steven j. sackett
!c     lawrence livermore laboratory
!c     livermore, california 94550
!c
!c     robert l. taylor
!c     dept. of civil engineering
!c     university of california
!c     berkeley, california 94720
!c
!c     february 11, 1983
!c
!c-----argument usage----------------------------------------------------
      dimension b(1),a(1),s(1)
!c
!c     input arguments
!c           ist       stage flag
!c                         = 1    determine coefficient matrix profile
!c                                and block structure and set memory
!c                                pointers
!c                         = 2    assemble and factorize coefficient
!c                                matrix
!c                         = 3    solve equations using previously
!c                                factorized coefficient matrix
!c                         = 4    zero coefficient matrix and assemble
!c                                contributions from nel elements
!c                         = 5    assemble coefficient matrix contri-
!c                                butions from nel elements
!c                         = 6    factorize assembled coefficient matrix
!c            b        coefficient matrix column heights (excluding
!c                     diagonal), if ist = 1; the right hand side
!c                     (load vector), if ist = 3
!c            a        working space for blocked coefficient matrix
!c            s        array to hold a group of element records during
!c                     equation (coefficient matrix) assembly, if the
!c                     assembly is done by fissle, or containing
!c                     information for a user supplied version of
!c                     subroutine asblk, if assembly is done by the user
!c
!c     if ist = 1, b is assumed to be an integer array; if ist > 1, it is
!c     assumed to be real. if ist = 2, 4, or 5, however, and the equation
!c     assembly is done by fissle, b is not used. the last argument, s,
!c     is required only if ist = 2, 4, or 5. if equation assembly is done
!c     by fissle, this array must be dimensioned for at least ng*ls
!c     words, where ng is the number of elements per group and ls is the
!c     element record length (see common block /fissl1/).
!c
!c     output arguments
!c            b        coefficient matrix diagonal pointers, if ist = 1;
!c                     the right hand side (load vector), if ist = 2, 4,
!c                     or 5 and the user supplies a version of asblk
!c                     which includes assembly of the load vector;
!c                     the solution vector, if ist = 3
!c            a        inverse of d from u'du factorization of the
!c                     coefficient matrix, if ist = 2, 3, or 6
!c
!c     the first neq locations of the working space array, a, may be used
!c     as scratch space between calls to fissle. the remaining nwu-neq
!c     locations may be preserved or destroyed at the option of the user.
!c     if they are preserved, negative values of ist should be used to
!c     inform fissle of this fact and avoid unnecessary disk transfers.
!c     for problems that fit in one block, use of this option can
!c     significantly reduce solution cost.
!c
!c-----common blocks set by the user-------------------------------------
      common/bk12/ntlen
      common/fissn0/neq,mxw,no,n1,nfissl(3)
!c           neq       number of equations
!c           mxw       maximum dimension for the working space
!c           no        unit specifier for error messages
!c           n1        unit specifier for the coefficient matrix file
!c           nfissl(i) maximum number of warning messages to print
!c                     (default is nfissl(i)=20)
!c                       i = 1    zero pivot warnings
!c                       i = 2    equation sign change warnings
!c                       i = 3    loss of accuracy warnings
!c
!c     if mxw = 0, the working space array, a, is assumed to be located
!c     at the end of the users memory space. in this case fissle will
!c     expand memory to yield a working space size which will minimize
!c     the number of blocks required but not exceed the total memory
!c     available. if mxw < 0, fissle proceeds as if mxw = 0 except that
!c     abs(mxw) words of memory are assumed to be already assigned to a.
!c     in all cases the actual number of words of working space used is
!c     stored in the third word of common block /fissl2/.
!c
      common/fissn1/nel,ns,n2,ng,ls
!c           nel       number of elements
!c           ns        maximum number of degrees of freedom per element
!c           n2        unit specifier for file containing element records
!c           ng        number of elements per group (maximum=128)
!c           ls        element record length (minimum=ns+ns*(ns+1)/2)
!c
!c     the file assigned to unit n2 is assumed to contain nel records,
!c     one for each element. the first ns words of each record give
!c     the equation numbers for that element's degrees of freedom (if
!c     an element has less than ns degrees of freedom, zeroes must be
!c     used for the excess equation numbers). the next ns*(ns+1)/2
!c     words contain the upper triangle of the element coefficient
!c     (stiffness) matrix, stored columnwise. for vectorization these
!c     records are processed ng at a time. if ng > 0 they are assumed
!c     to be random-absolute, i.e. written with wrabsf calls. if ng < 0
!c     they are assumed to be sequential-binary, i.e. written with
!c     write(n2) calls (in this case a single call must, except for
!c     possibly a short last record, transmit a logical record
!c     containing ng element records). if ng is not specified by the
!c     user it is set to its maximum value, 128. if ls is not specified
!c     it is set to ns+ns*(ns+1)/2. if n2 = 0, the s array is assumed
!c     to already contain data for nel elements and an element file
!c     is not explicitly required.
!c
!c     this information is used by fissle to assemble the system
!c     coefficient matrix. if assembly is done with a user supplied
!c     version of subroutine asblk, /fissl1/ and the element file
!c     described above are not explicitly required.
!c
!c-----common blocks set by fissle---------------------------------------
      common/fissn2/nwb,nblk,nwu,meb,mxc,mpr,mch,ia1,ia2
!c           nwb       number of words per block
!c           nblk      number of blocks
!c           nwu       total working space used
!c           meb       maximum number of equations in any one block
!c           mxc       maximum column height
!c           mpr       matrix profile (sum of column heights)
!c           mch       mean (average) column height
!c           ia1       offsets to access data in the working space
!c           ia2
!c
      common/fissn3/ifissl,kfissl(3)
!c           ifissl    fissle fatal error flag
!c                         = 0    if there are no fatal errors
!c                         =-1    if a fatal error is detected
!c           kfissl(i) number of warning errors in last call to fissle
!c                       i = 1    zero pivot warnings
!c                       i = 2    equation sign change warnings
!c                       i = 3    loss of accuracy warnings
!c
      common/fissl4/je,jc
c           je        eqn. number of the first eqn. in the current
c                     block -1
c           jc        number of columns in the current equation block
c
      common/fissl5/dt(2)
!c           dt(1)     set negative if the sign of a diagonal term
!c                     changes during factorization
!c           dt(2)     set to zero if more than six significant digits
!c                     are lost in a diagonal term during factorization
!c-----------------------------------------------------------------------
!c
!c     note- this package contains coding for several different computer
!c     systems. statements flagged with "7600" in columns 74-77 apply
!c     to the cdc-7600 only. statements flagged with "cray" in columns
!c     74-77 apply to the cray-1 only. statements flagged with "ansi" in
!c     columns 74-77 are ansi standard fortran equivalents to vectorized
!c     cray coding.
!c
!c-----------------------------------------------------------------------
!!!      common/kkk/km,kkjj
!c
!c     parameter giving the minimum block size
!c     (this should be a multiple of the disk sector size)
      parameter (mbs0=64)
      parameter (mbs1=mbs0-1,mbs2=2*mbs0,mbs3=mbs2-1)
c
      data iai/0/
c
      if(abs(ist).gt.3) go to 201
      if(abs(ist)-2) 101,201,301
c
  101 continue
      nblk   = 1
      ifissl = 0

c.... compute coefficient matrix profile and set diagonal pointers
      mpr    = mapad(b,neq,mxc)
      mch    = mpr/neq

c.... estimate optimal block size
      nwp = mxw
      nwa = nwp
      if(nwp.gt.0) go to 115

      nwa = memav(0) - nwp
      nwp = -nwp
  115 nwu = mpr + neq + 3
      nwa = mbs2*(min(nwu+mbs3,nwa-neq)/mbs2)
      nwb = nwu

      if(nwb.le.nwa) go to 121
      nwb = nwa/2
      nwc = mch+1
      ncb = (nwb-3)/nwc
      mbs = max(ncb*nwc,mxc+1) + 3
      mbs = mbs0*((mbs+mbs1)/mbs0)
      nwb = min(nwb,mbs)
      nwu = 2*nwb

      if(nwb.eq.mbs) go to 121
      ifissl = -1
      go to 901

c.... set memory pointers and expand field length
  121 ia1 = neq
      nwu = nwu + neq
      ia2 = nwu - nwb
      nwr = nwu - nwp
      if(nwr.gt.0) call expndm((ntlen+nwu))

c.... set up block structure

      call mkblk(a(ia1+1),a(1),b(1),ist)
      if(ifissl.lt.0) go to 901
      return
c
  201 continue
      ifissl=0
c.... assemble equations (coefficient matrix) in blocks
      if(abs(ist).eq.6) go to 251
      call asblk(a(ia1+1),a(ia2+1),b(1),s(1),ist)
ck-------------------------------------------------
ck-------------------------------------------------
      ltta=(neq*(neq-1))/2+neq
ck      write(25,202)
  202 format(////5x,'Global stiffness matrix :'/)
      do 204 ii=1,ltta
c      write(*,203) ii,a(11+ii)
  203 format(5x,'K(',i3,') =',e14.6)
  204 continue
ck-------------------------------------------------
ck-------------------------------------------------
      if(abs(ist).ne.2) return
c.... factorize the coefficient matrix
  251 kfissl(1)=0
      kfissl(2)=0
      kfissl(3)=0
      call trifac(a(ia1+1),a(ia2+1),a(1),ist)
      return
c
  301 continue
ck---------------------------------------------------------
ck---------------------------------------------------------
!!!      if (km.eq.1) then
!!!ck      write(25,302)
!!!  302 format(//5x,'Load vector :'/)
!!!      do 307 i=1,neq
!!!c      write(*,304) i,b(i)
!!!  304 format(5x,'F(',i2,') = ',f10.4)
!!!  307 continue
!!!      endif
ck---------------------------------------------------------
ck---------------------------------------------------------
c.... reduce the load vector and backsubstitute
      call forred(a(ia1+1),a(ia2+1),a(1),b(1),ist)
c     if(and(nblk,1).ne.0) go to 311                                    cray1
      if(and(nblk,1).ne.0) go to 311                                    unix
c     if(iand(nblk,1).ne.0) go to 311                                   vms
      call bacsub(a(ia1+1),a(ia2+1),b(1))
      return
  311 call bacsub(a(ia2+1),a(ia1+1),b(1))
!!!!!ck----------------------------------------------
!!!!!ck----------------------------------------------
!!!!!      if (km.eq.1) then
!!!!!ck      write(25,332)
!!!!!  332 format(//5x,'Displacements :'/)
!!!!!      do 334 i=1,neq
!!!!!ck      write(25,333) i,b(i)
!!!!!  333 format(5x,'U(',i2,') = ',f10.4)
!!!!!  334 continue
!!!!!      endif
!!!!!ck----------------------------------------------
!!!!!ck----------------------------------------------
      return
c
c.... error in memory allocation
  901 mnw=2*max(nblk,mbs)+neq
      write(no,1001)neq,nblk,nwp,nwa,mnw
      return
 1001 format(5x,'**fatal error** insufficient memory to block equations'
     1/i15,' equations'/i15,' blocks'
     2/i15,' words of working space provided'
     3/i15,' words available'
     4/i15,' words required')
      end


C******************************************************************************
C
      PROGRAM EXAMPLE2
      IMPLICIT NONE
      REAL ::           AA(10),SPS,CPS,BB(3),PSI,CC(18)
      COMMON /GEOPACK1/ AA,SPS,CPS,BB,PSI,CC
C
c be sure to include an EXTERNAL statement with the names of (i) a magnetospheric
c external field model and (ii) Earth's internal field model.
c
      EXTERNAL DIP_08
      EXTERNAL TS04
C
C  X,Y,Z Locations
C
      REAL*8, DIMENSION(10) :: PARMOD

      INTEGER, PARAMETER :: ounit=20
      INTEGER, PARAMETER :: iunit=21
      INTEGER :: IOPT
      INTEGER :: i, k
      INTEGER, PARAMETER :: DIMX=600
      INTEGER, PARAMETER :: DIMZ=350

      REAL*8, DIMENSION(DIMX,DIMZ) :: XGSW
      REAL*8, DIMENSION(DIMX,DIMZ) :: ZGSW

      REAL*8 :: PS    = 0.D0
      REAL*8 :: BXGSW = 0.D0
      REAL*8 :: BYGSW = 0.D0
      REAL*8 :: BZGSW = 0.D0
      REAL   :: HXGSW = 0.D0
      REAL   :: HYGSW = 0.D0
      REAL   :: HZGSW = 0.D0

      REAL*8 :: Xbeg = -40.D0
      REAL*8 :: Zbeg = -35.D0
      REAL*8 :: dx = 0.1D0
      REAL*8 :: dz = 0.2D0

      REAL :: PDYN
      REAL :: B0y
      REAL :: B0z
      REAL :: XIND
      REAL :: VGSEX
      REAL :: VGSEY
      REAL :: VGSEZ

      INTEGER :: Status
      INTEGER :: ID
      CHARACTER(len=10) :: filename
C XIND: solar-wind-magnetosphere driving index,
C Typical values of XIND: between 0 (quiet) and 2 (strongly disturbed)
      DO k = 1, DIMZ
        DO i = 1, DIMX
          XGSW (i, k) = Xbeg + (i-1)*dx
          ZGSW (i, k) = Zbeg + (k-1)*dz
        ENDDO
      ENDDO
C
C   First, call RECALC_08, to define the main field coefficients and, hence, the magnetic
C      moment of the geodipole for IYEAR=1997 and IDAY=350.
C   The universal time and solar wind direction does not matter in this example,
C   because here we explicitly specify the tilt angle (hence, the orientation of
C   dipole in the GSW coordinates), so we arbitrarily set IHOUR=MIN=ISEC=0 and
C   VGSEX=-400.0, VGSEY=VGSEZ=0 (any other values would be equally OK):
C
      CALL RECALC_08 (1997,350,0,0,0,-400.0,0.0,0.0)
C
C  Specify the dipole tilt angle PS, its sine SPS and cosine CPS, entering
c    in the common block /GEOPACK1/:
C

      OPEN (UNIT=iunit,FILE="TA15_input",ACTION="read")

C Skip first line with column names
      read(iunit,*)

      DO
      read(iunit,*,IOSTAT=Status) ID,PDYN,B0y,B0z,XIND,VGSEX,VGSEY,VGSEZ

        write(*, *) 'generating file', ID

C       CALL RECALC_08 (1997,350,0,0,0,VGSEX,VGSEY,VGSEZ)

        PS    = 0.D0
        BXGSW = 0.D0
        BYGSW = 0.D0
        BZGSW = 0.D0

        IF (Status < 0) THEN
          ! In case end of file is reached
          EXIT
        END IF
C Specify name of output file
        IF (ID < 10) THEN
          write (filename, "(A3,I1,I1,A4)") "OUT",0,ID,".DAT"
        ELSE
          write (filename, "(A3,I2,A4)") "OUT",ID,".DAT"
        ENDIF

        PSI=0.
        SPS=SIN(PSI)
        CPS=COS(PSI)

        IOPT=0
C           (IN THIS EXAMPLE IOPT IS JUST A DUMMY PARAMETER,
C                 WHOSE VALUE DOES NOT MATTER)
        PARMOD(1) = PDYN
        PARMOD(2) = B0y
        PARMOD(3) = B0z
        PARMOD(4) = XIND
        PARMOD(5:10) = (/0.0, 0.0, 0.0, 0.0, 0.0, 0.0 /)
        PS = 0.D0

        IOPT=0
C           (IN THIS EXAMPLE IOPT IS JUST A DUMMY PARAMETER,
C                 WHOSE VALUE DOES NOT MATTER)
c

        OPEN (UNIT=ounit,FILE="output/"//filename,ACTION="write",
     *        STATUS="replace")

        DO k = 1, DIMZ
          DO i = 1, DIMX
            CALL T04_s (IOPT,PARMOD,PS,
     *                     XGSW(i,k),0.D0,ZGSW(i,k),
     *                     BXGSW,BYGSW,BZGSW)
C -- Routines to include internal B field:
C            CALL DIP_08 (REAL(XGSW(i,k)),0.0,REAL(ZGSW(i,k)),
C     *                   HXGSW,HYGSW,HZGSW)
            CALL IGRF_GSW_08 (REAL(XGSW(i,k)),0.0,REAL(ZGSW(i,k)),
     *                   HXGSW,HYGSW,HZGSW)
C --
          WRITE(ounit,*) XGSW(i,k),0.D0,ZGSW(i,k),
     *                   BXGSW+DBLE(HXGSW),BYGSW+DBLE(HYGSW),
     *                   BZGSW+DBLE(HZGSW)
        ENDDO
      ENDDO

      CLOSE(ounit)
      ENDDO
      END


!==========================================================================
elemental subroutine gsw_rho_first_derivatives_wrt_enthalpy (sa, ct, p, &
                                                             rho_sa, rho_h)
! =========================================================================
!
!  Calculates two first-order derivatives of specific volume (v).
!  Note that this function uses the using the computationally-efficient
!  expression for specific volume (Roquet et al., 2014).
!
!  SA  =  Absolute Salinity                                        [ g/kg ]
!  CT  =  Conservative Temperature (ITS-90)                       [ deg C ]
!  p   =  sea pressure                                             [ dbar ]
!         ( i.e. absolute pressure - 10.1325 dbar )
!
!  rho_SA =  The first derivative of rho with respect to
!              Absolute Salinity at constant CT & p.    [ J/(kg (g/kg)^2) ]
!  rho_h  =  The first derivative of rho with respect to
!              SA and CT at constant p.                  [ J/(kg K(g/kg)) ]
!--------------------------------------------------------------------------

use gsw_mod_toolbox, only : gsw_specvol
use gsw_mod_toolbox, only : gsw_specvol_first_derivatives_wrt_enthalpy

use gsw_mod_kinds

implicit none

real (r8), intent(in) :: sa, ct, p
real (r8), intent(out), optional :: rho_sa, rho_h

real (r8) :: rec_v2, v_h, v_sa

if (present(rho_sa) .and. present(rho_h)) then

    call gsw_specvol_first_derivatives_wrt_enthalpy(sa,ct,p,v_sa,v_h)

else if (present(rho_sa)) then

    call gsw_specvol_first_derivatives_wrt_enthalpy(sa,ct,p,v_sa=v_sa)

else if (present(rho_h)) then

    call gsw_specvol_first_derivatives_wrt_enthalpy(sa,ct,p,v_h=v_h)

end if

rec_v2 = (1.0_r8/gsw_specvol(sa,ct,p))**2

if (present(rho_sa)) rho_sa = -v_sa*rec_v2

if (present(rho_h)) rho_h = -v_h*rec_v2

return
end subroutine

!--------------------------------------------------------------------------


program mtx_loop_test

    !Undergraduate Student: Arturo Burgos
    !Professor: João Rodrigo Andrade
    !Federal University of Uberlândia - UFU, Fluid Mechanics Laboratory
    !MFLab, Block 5P, Uberlândia, MG, Brazil

    !This program will read the data in the txt file

    implicit none !To avoid variable definition problems, checking if they are correctly defined
    integer :: i, j
    real, DIMENSION(3,3,3) :: mtx
    DOUBLE PRECISION :: start, finish

    call random_number(mtx)

    print *, 'The random matrix is : '

    do i = 1,3
        do j = 1,3

            write(*,3) mtx(i,j,:)
            3 format(3f20.4)

        end do
        write (*,4) '---------- New Slice ----------'
        4 format(a52)
    end do

    write(*,'(A/)')
    print *,'the mtx(1,1,1) is: ', mtx(1,1,1)
    print *,'the mtx(1,1,2) is: ', mtx(1,1,2)
    write(*,'(//A/)')

    call cpu_time(start)

    mtx(:, :, 1) = mtx(:, :, 2)
    mtx(:, :, 3) = mtx(:, :, 1)

    call cpu_time(finish)

    print *, 'The new matrix is : '

    do i = 1,3
        do j = 1,3

            write(*,6) mtx(i,j,:)
            6 format(3f20.4)

        end do
        write (*,7) '---------- New Slice ----------'
        7 format(a52)
    end do

    write(*,'(A/)')
    print *,'the mtx(1,1,1) now is: ', mtx(1,1,1)
    print *,'the mtx(1,1,2) now is: ', mtx(1,1,2)
    write(*,'(A/)')
    print '("Time of operation is: ",f6.5," seconds")', finish - start

    open(5, file = 'mtx_loop_test.txt') !Print in file.txt
    write(5,*) mtx(:,:,:)

end program mtx_loop_test