** Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions.
** See https://llvm.org/LICENSE.txt for license information.
** SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception

* Vectorizer 'induction variable retained' test

	program ka61
	common /matrix/ iord(4),irev(8)
	common /integ/ nx,ny,nz
	integer i, j
	integer result(12), expect(12)
	data expect /
     &		5,3,2,8,			! iord
     &		0,3,2,0,1,0,0,4 /		! irev
	nx = 2
	ny = 2
	nz = 2
	call combt()
	j = 1
	do i = 1,4
	    result(j) = iord(i)
	    j = j + 1
	enddo
	do i = 1,8
	    result(j) = irev(i)
	    j = j + 1
	enddo
	call check(result, expect, 12)
	end

	subroutine combt()
	implicit double precision(a-h,o-z)
	common /matrix/ iord(4),irev(8)
	common /integ/ nx,ny,nz
	icount = 0
        nxy=nx*ny
        mxyz=nx+ny+nz
	do i=4,mxyz,2
	    k1=max0(1,i-nx-ny)
	    k2=min0(i-2,nz)
	    do iinz=k1,k2
		inz=k2+k1-iinz
		j1=max0(1,i-nz-nx)
		j2=min0(i-inz-1,ny)
		do iiny=j1,j2
		    iny=j2+j1-iiny
		    inx=i-inz-iny
		    if(inx.le.nx) then
			icount=icount+1
			iord(icount)=nxy*(inz-1)+nx*(iny-1)+inx
			irev(iord(icount))=icount
		    endif
		enddo
	    enddo
	enddo
	end


!!# FUNCTION MODULE: <FUN_xyAVERAGEX>
MODULE FUN_xyAVERAGEX

!!## PURPOSE
!! Averages the function $X$ in 2D.

!!## METHOD

!!## AUTHORS
!! [waw] W. A. Wieselquist

!!## MODIFIED
!! 14 April 2007 [waw]

!!## DEFAULT IMPLICIT
IMPLICIT NONE

!!## PROCEDURE OVERLOADING
INTERFACE xyAVERAGEX_Ls
 MODULE PROCEDURE xyAVERAGEX_Ls_Rsp
 MODULE PROCEDURE xyAVERAGEX_Ls_Rdp
ENDINTERFACE

!!## PUBLIC ACCESS LIST
PUBLIC :: xyAVERAGEX_Ls
PUBLIC :: xyAVERAGEX_Ls_Rsp
PUBLIC :: xyAVERAGEX_Ls_Rdp

!!## CONTAINED PROCEDURES
CONTAINS

!!### FUNCTION <xyAVERAGEX_Ls_Rsp>
FUNCTION xyAVERAGEX_Ls_Rsp( Ls ) RESULT(AVERAGEX)
!!#### LOCAL MAPPINGS
USE PAR_Constants_Rsp                           !!((02-A-PAR_Constants_Rsp.f90))
USE KND_IntrinsicTypes,ONLY: KIND_R => KIND_Rsp !!((01-A-KND_IntrinsicTypes.f90))
INCLUDE "05-A-FUN_xyAVERAGEX_Ls.f90.hdr"
!!--begin--
INCLUDE "05-A-FUN_xyAVERAGEX_Ls.f90.bdy"
!!--end--
END FUNCTION

!!### FUNCTION <xyAVERAGEX_Ls_Rdp>
FUNCTION xyAVERAGEX_Ls_Rdp( Ls ) RESULT(AVERAGEX)
!!#### LOCAL MAPPINGS
USE PAR_Constants_Rdp                           !!((02-A-PAR_Constants_Rdp.f90))
USE KND_IntrinsicTypes,ONLY: KIND_R => KIND_Rdp !!((01-A-KND_IntrinsicTypes.f90))
INCLUDE "05-A-FUN_xyAVERAGEX_Ls.f90.hdr"
!!--begin--
INCLUDE "05-A-FUN_xyAVERAGEX_Ls.f90.bdy"
!!--end--
END FUNCTION

END MODULE


module init_phi_module

  use multifab_module
  use ml_layout_module
  use define_bc_module
  use ml_restrict_fill_module

  implicit none

  private

  public :: init_phi_on_level, init_phi

contains

  subroutine init_phi_on_level(phi,dx,prob_lo)

    type(multifab) , intent(inout) :: phi
    real(kind=dp_t), intent(in   ) :: dx
    real(kind=dp_t), intent(in   ) :: prob_lo(phi%dim)

    ! local
    integer i,ng,dm
    integer :: lo(phi%dim), hi(phi%dim)

    real(kind=dp_t), pointer :: dp(:,:,:,:)

    ng = phi%ng
    dm = phi%dim

    do i=1,nfabs(phi)
       dp => dataptr(phi,i)
       lo = lwb(get_box(phi,i))
       hi = upb(get_box(phi,i))
       select case(dm)
       case (2)
          call init_phi_2d(dp(:,:,1,1), ng, lo, hi, prob_lo, dx)
       case (3)
          call init_phi_3d(dp(:,:,:,1), ng, lo, hi, prob_lo, dx)
       end select
    end do

    call multifab_fill_boundary(phi)

  end subroutine init_phi_on_level

  subroutine init_phi(mla,phi,dx,prob_lo,the_bc_tower)

    type(ml_layout), intent(in   ) :: mla
    type(multifab) , intent(inout) :: phi(:)
    real(kind=dp_t), intent(in   ) :: dx(:)
    real(kind=dp_t), intent(in   ) :: prob_lo(mla%dim)
    type(bc_tower) , intent(in   ) :: the_bc_tower

    ! local variables
    integer :: lo(mla%dim), hi(mla%dim)
    integer :: nlevs, dm, ng, i, n

    real(kind=dp_t), pointer :: dp(:,:,:,:)

    ng = phi(1)%ng
    dm = mla%dim
    nlevs = mla%nlevel

    do n=1,nlevs

       do i=1,nfabs(phi(n))
          dp => dataptr(phi(n),i)
          lo = lwb(get_box(phi(n),i))
          hi = upb(get_box(phi(n),i))
          select case(dm)
          case (2)
             call init_phi_2d(dp(:,:,1,1), ng, lo, hi, prob_lo, dx(n))
          case (3)
             call init_phi_3d(dp(:,:,:,1), ng, lo, hi, prob_lo, dx(n))
          end select
       end do

    end do

    ! restrict the multi-level data, and
    ! fill all boundaries: same-level, coarse-fine, periodic, and domain boundaries
    call ml_restrict_and_fill(nlevs, phi, mla%mba%rr, the_bc_tower%bc_tower_array)

  end subroutine init_phi

  subroutine init_phi_2d(phi, ng, lo, hi, prob_lo, dx)

    integer          :: lo(2), hi(2), ng
    double precision :: phi(lo(1)-ng:,lo(2)-ng:)
    double precision :: prob_lo(2)
    double precision :: dx

    ! local varables
    integer          :: i,j
    double precision :: x,y,r1

    do j=lo(2),hi(2)
       y = prob_lo(2) + (dble(j)+0.5d0) * dx
       do i=lo(1),hi(1)
          x = prob_lo(1) + (dble(i)+0.5d0) * dx

          r1 = ((x-0.d0)**2 + (y-0.d0)**2) / 0.01d0

          phi(i,j) = 1.d0 + exp(-r1)

       end do
    end do

    end subroutine init_phi_2d

    subroutine init_phi_3d(phi, ng, lo, hi, prob_lo, dx)

    integer          :: lo(3), hi(3), ng
    double precision :: phi(lo(1)-ng:,lo(2)-ng:,lo(3)-ng:)
    double precision :: prob_lo(3)
    double precision :: dx

    ! local varables
    integer          :: i,j,k
    double precision :: x,y,z,r1

    !$omp parallel do private(i,j,k,x,y,z,r1)
    do k=lo(3),hi(3)
       z = prob_lo(3) + (dble(k)+0.5d0) * dx
       do j=lo(2),hi(2)
          y = prob_lo(2) + (dble(j)+0.5d0) * dx
          do i=lo(1),hi(1)
             x = prob_lo(1) + (dble(i)+0.5d0) * dx

             r1 = ((x-0.d0)**2 + (y-0.d0)**2 + (z-0.d0)**2) / 0.01d0

             phi(i,j,k) = 1.d0 + exp(-r1)

          end do
       end do
    end do
    !$omp end parallel do

  end subroutine init_phi_3d

end module init_phi_module


program range

implicit none

integer i, imax
parameter (imax = 3)

real a(0:imax), b(0:imax)

do i = 0, imax
   != stencil readOnce, backward(depth=1, dim=1, nonpointed) :: b
   a(i+1) = b(i)
end do

end program


submodule(euler_interface_m) euler_prob_0048_m
    implicit none

contains

    module character(len=20) function euler0048()
        write (euler0048, "(a20)") trim(ans())
    end function euler0048

    character(len=20) function ans()
        integer :: isum(10), i, iarr(10)

        isum = 0

        do i = 1, 1000
            call self_pow10(i, iarr)
            call add10(isum, iarr)
        end do

        write (ans, "(20(i1))") isum
    end function ans

    subroutine add10(a, b)
        integer, intent(inout) :: a(:)
        integer, intent(in) :: b(:)
        integer :: j

        a(:) = a(:) + b(:)

        do j = 10, 2, -1
            call carry_add(a(j - 1:j))
        end do

        a(1) = unit_digit(a(1))
    end subroutine add10

    subroutine self_pow10(n, iarr)
        integer, intent(in) :: n
        integer, intent(out) :: iarr(:)
        integer :: i, j

        iarr(:) = 0
        iarr(10) = n

        do i = 1, n - 1
            iarr(10) = iarr(10)*n

            do j = 10, 2, -1
                call carry_mul(iarr(j - 1:j), n)
            end do

            iarr(1) = unit_digit(iarr(1))
        end do
    end subroutine self_pow10

    subroutine carry_mul(a, m)
        integer, intent(inout) :: a(:) !a(2)
        integer, intent(in) :: m
        integer :: tmp

        tmp = a(2)
        a(2) = unit_digit(a(2))
        a(1) = a(1)*m + (tmp - a(2))/10
    end subroutine carry_mul

    subroutine carry_add(a)
        integer, intent(inout) :: a(:) !a(2)
        integer :: tmp

        tmp = a(2)
        a(2) = unit_digit(a(2))
        a(1) = a(1) + (tmp - a(2))/10
    end subroutine carry_add

end submodule euler_prob_0048_m


module rangen

character(len=32) :: ran_mode
double precision :: x1
double precision :: x2
double precision :: mean
double precision :: stdev
integer :: npts
character(len=512) :: seed_file

end module

!==================================================================================================!

program main

use io, only: stdout
use random, only: iseed, r8_uniform_01, r8_normal_ab

use rangen, only: ran_mode, &
                  x1, &
                  x2, &
                  mean, &
                  stdev, &
                  npts, &
                  seed_file

implicit none

! Local variables
integer :: i

call gcmdln()
if (ran_mode.eq.'') then
    call usage('rangen: no random number generator mode defined')
endif

do i = 1,npts
    if (ran_mode.eq.'uniform') then
        write(stdout,*) x1 + (x2-x1)*r8_uniform_01(iseed)
    elseif (ran_mode.eq.'normal') then
        write(stdout,*) r8_normal_ab(mean,stdev,iseed)
    else
        call usage('rangen: no generator mode named '//trim(ran_mode))
    endif
enddo

if (seed_file.ne.'') then
    open(unit=24,file=seed_file,status='unknown')
    write(24,*) iseed
    close(24)
endif

end

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

subroutine gcmdln()

use random, only: iseed, timeseed

use rangen, only: ran_mode, &
                  x1, &
                  x2, &
                  mean, &
                  stdev, &
                  npts, &
                  seed_file

implicit none

! Local variables
integer :: i, narg, ierr
character(len=512) :: tag

! Initialize control parameters
ierr = 0
ran_mode = ''
x1 = 0.0d0
x2 = 1.0d0
mean = 0.0d0
stdev = 1.0d0
npts = 100
seed_file = ''
iseed = timeseed()*100

! Number of arguments
narg = command_argument_count()
if (narg.eq.0) then
  call usage('')
endif

! Read arguments
i = 1
do while (i.le.narg)

    call get_command_argument(i,tag)

    if (trim(tag).eq.'-uniform') then
        ran_mode = 'uniform'
        i = i + 1
        call get_command_argument(i,tag)
        read(tag,*) x1
        i = i + 1
        call get_command_argument(i,tag)
        read(tag,*) x2

    elseif (trim(tag).eq.'-normal') then
        ran_mode = 'normal'
        i = i + 1
        call get_command_argument(i,tag)
        read(tag,*) mean
        i = i + 1
        call get_command_argument(i,tag)
        read(tag,*) stdev

    elseif (tag.eq.'-n'.or.tag.eq.'-npts') then
        i = i + 1
        call get_command_argument(i,tag)
        read(tag,*) npts

    elseif (trim(tag).eq.'-seed') then
        i = i + 1
        call get_command_argument(i,tag)
        read(tag,*) iseed
    elseif (trim(tag).eq.'-printseed') then
        i = i + 1
        call get_command_argument(i,seed_file,status=ierr)

    else
        call usage('rangen: no option '//trim(tag))
    endif

    if (ierr.ne.0) then
        call usage('rangen: error parsing command line arguments')
    endif

    i = i + 1

enddo

return
end subroutine

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

subroutine usage(str)

use io, only: stderr

implicit none

character(len=*) :: str

if (str.ne.'') then
    write(stderr,*) trim(str)
    write(stderr,*)
endif

write(stderr,*) 'Usage: rangen -uniform X1 X2 | -normal MEAN STD  [-n NPTS] [-seed SEED]'
write(stderr,*) '              [-printseed FILE]'
write(stderr,*)
write(stderr,*) '-uniform X1 X2        Uniform distribution between X1 and X2'
write(stderr,*) '-normal MEAN STD      Gaussian distribution centered on MEAN with std dev STD'
write(stderr,*) '-n NPTS               Number of points to generate (default: 100)'
write(stderr,*) '-seed SEED            Random number seed'
write(stderr,*) '-printseed FILE       Print output random number seed (to keep chain going)'
write(stderr,*)

call error_exit(1)
end subroutine


a = 1 ** 2
a = 1 ** (-2) ** 3
END PROGRAM


C=======================================================================

      SUBROUTINE SDIAG(N,A,D,X,E,IS)

C=======================================================================
C
c     N   order
C     A   matrix to be diagonalized
C     D   eigenvalues
C     X   eigenvectors
C     E   auxiliary field
C     IS = 1  eigenvalues are ordered and major component of X is positiv
C          0  eigenvalues are not ordered
C
C-----------------------------------------------------------------------
C     IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      DIMENSION A(N,N),X(N,N),E(N),D(N)
      DATA TOL,EPS/1.E-32,1.E-10/
      IF (N.EQ.1) THEN
        D(1)=A(1,1)
        X(1,1)=1.
        RETURN
      ENDIF
C
      DO 10 I=1,N
      DO 10 J=1,I
   10 X(I,J)=A(I,J)
C
CCC   HOUSEHOLDER-REDUKTION
      I=N
   15 IF (I-2) 200,20,20
   20 L=I-2
      F=X(I,I-1)
      G=F
      H=0
      IF (L) 31,31,32
   32 DO 30 K=1,L
   30 H=H+X(I,K)*X(I,K)
   31 S=H+F*F
      IF (S-TOL) 33,34,34
   33 H=0
      GOTO 100
   34 IF (H) 100,100,40
   40 L=L+1
      G= SQRT(S)
C      G=DSQRT(S)
      IF (F.GE.0.) G=-G
      H=S-F*G
      HI=1.D0/H
      X(I,I-1)=F-G
      F=0.
      IF (L) 51,51,52
   52 DO 50 J=1,L
      X(J,I)=X(I,J)*HI
      S=0.
      DO 55 K=1,J
   55 S=S+X(J,K)*X(I,K)
      J1=J+1
      IF (L-J1) 57,58,58
   58 DO 59 K=J1,L
   59 S=S+X(K,J)*X(I,K)
   57 E(J)=S*HI
   50 F=F+S*X(J,I)
   51 F=F*HI*.5D0
C
      IF (L) 100,100,62
   62 DO 60 J=1,L
      S=X(I,J)
      E(J)=E(J)-F*S
      P=E(J)
      DO 65 K=1,J
   65 X(J,K)=X(J,K)-S*E(K)-X(I,K)*P
   60 CONTINUE
  100 CONTINUE
      D(I)=H
      E(I-1)=G
      I=I-1
      GOTO 15
CCC   BEREITSTELLEN DER TRANSFORMATIONMATRIX
  200 D(1)=0.
      E(N)=0.
      B=0.
      F=0.
      DO 210 I=1,N
      L=I-1
      IF (D(I).EQ.0.) GOTO 221
      IF (L) 221,221,222
  222 DO 220 J=1,L
      S=0.
      DO 225 K=1,L
  225 S=S+X(I,K)*X(K,J)
      DO 226 K=1,L
  226 X(K,J)=X(K,J)-S*X(K,I)
  220 CONTINUE
  221 D(I)=X(I,I)
      X(I,I)=1
      IF (L) 210,210,232
  232 DO 230 J=1,L
      X(I,J)=0.
  230 X(J,I)=0.
  210 CONTINUE
CCC   DIAGONALISIEREN DER DREIECKSMATRIX
      DO 300 L=1,N
      H=EPS*( ABS(D(L))+ ABS(E(L)))
      IF (H.GT.B) B=H
CCC   TEST FUER SPLITTING
      DO 310 J=L,N
      IF ( ABS(E(J)).LE.B) GOTO 320
  310 CONTINUE
CCC   TEST FUER KONVERGENZ
  320 IF (J.EQ.L) GOTO 300
  340 P=(D(L+1)-D(L))/(2*E(L))
      R= DSQRT(P*P+1.D0)
      PR=P+R
      IF (P.LT.0.) PR=P-R
      H=D(L)-E(L)/PR
      DO 350 I=L,N
  350 D(I)=D(I)-H
      F=F+H
CCC   QR-TRANSFORMATION
      P=D(J)
      C=1.D0
      S=0.
      I=J
  360 I=I-1
      IF (I.LT.L) GOTO 362
      G=C*E(I)
      H=C*P
      IF ( ABS(P)- ABS(E(I))) 363,364,364
  364 C=E(I)/P
      R= DSQRT(C*C+1.D0)
      E(I+1)=S*P*R
      S=C/R
      C=1.D0/R
      GOTO 365
  363 C=P/E(I)
      R= DSQRT(C*C+1.D0)
      E(I+1)=S*E(I)*R
      S=1.D0/R
      C=C/R
  365 P=C*D(I)-S*G
      D(I+1)=H+S*(C*G+S*D(I))
      DO 368 K=1,N
      H=X(K,I+1)
      X(K,I+1)=X(K,I)*S+H*C
  368 X(K,I)=X(K,I)*C-H*S
      GOTO 360
  362 E(L)=S*P
      D(L)=C*P
      IF ( ABS(E(L)).GT.B) GOTO 340
CCC   KONVERGENZ
  300 D(L)=D(L)+F
C
      IF (IS.EQ.0) RETURN
CCC   ORDNEN DER EIGENWERTE
      DO 400 I=1,N
      K=I
      P=D(I)
      J1=I+1
      IF (J1-N) 401,401,400
  401 DO 410 J=J1,N
      IF (D(J).GE.P) GOTO 410
      K=J
      P=D(J)
  410 CONTINUE
  420 IF (K.EQ.I) GOTO 400
      D(K)=D(I)
      D(I)=P
      DO 425 J=1,N
      P=X(J,I)
      X(J,I)=X(J,K)
  425 X(J,K)=P
  400 CONTINUE
C
C     SIGNUM
      DO  71 K=1,N
      S=0.
      DO 72 I=1,N
      H= ABS(X(I,K))
      IF (H.GT.S) THEN
         S=H
         IM=I
      ENDIF
   72 CONTINUE
      IF (X(IM,K).LT.0.) THEN
         DO 73 I=1,N
   73    X(I,K)=-X(I,K)
      ENDIf
   71 CONTINUE
C
      WRITE(*,2000)
 2000 FORMAT(' *** END SDIAG ***')
      RETURN
C-END-SDIAG
      END


C    Copyright(C) 1999-2020 National Technology & Engineering Solutions
C    of Sandia, LLC (NTESS).  Under the terms of Contract DE-NA0003525 with
C    NTESS, the U.S. Government retains certain rights in this software.
C
C    See packages/seacas/LICENSE for details

      SUBROUTINE SQUASH (MXND, XN, YN, NUID, LXK, KXL, NXL, LXN, KKK,
     &   KKKOLD, NNN, NAVAIL, IAVAIL, ASMALL, DONE, NOROOM, ERR)
C***********************************************************************

C  SUBROUTINE SQUASH = TRIES TO SQUASH THE MOST SHARPELY RHOMBICAL
C                      ELEMENT IN THE MESH

C***********************************************************************

C  VARIABLES:
C     ASMALL  =  AN ANGLE CONSIDERED TO BE TOO SMALL (DEGREES)
C     DONE    =  .TRUE. IF A SQUASH WAS DONE

C***********************************************************************

      DIMENSION NODES(4), LINES(4), L1LIST(20)
      DIMENSION RHOM(6), KR(6)
      DIMENSION LXK(4, MXND), NXL(2, 3*MXND), KXL(2, 3*MXND)
      DIMENSION LXN(4, MXND), XN(MXND), YN(MXND), NUID(MXND)

      LOGICAL ERR, NOROOM, DONE, CCW

C  CHECK FOR IMPENDING OVERFLOW

      NOROOM = .FALSE.
      ERR = .FALSE.
      DONE = .FALSE.
      IF (NNN .GE. MXND - 1) THEN
         CALL MESSAGE('INSUFFICIENT STORAGE IN SQUASH')
         NOROOM = .TRUE.
         ERR = .TRUE.
         RETURN
      END IF

C  INITIALIZATION

      PI = ATAN2(0.0, -1.0)
      IF (ASMALL .GT. 80.0)ASMALL = 80.0
      ALOP = ASMALL*PI/180.
      DMAX = SIN(0.5*ALOP)/COS(0.5*ALOP)
      DMAX = DMAX**2

C  CLEAR RECORDS

      DO 100 I = 1, 6
         RHOM(I) = 10.0
         KR(I) = 0
  100 CONTINUE

C  ELEMENT LOOP

      DO 130 K = KKKOLD + 1, KKK
         IF (LXK(1, K) .GT. 0) THEN
            CCW = .FALSE.
            CALL GNXKA (MXND, XN, YN, K, NODES, AREA, LXK, NXL, CCW)
            N1 = NODES(1)
            N2 = NODES(2)
            N3 = NODES(3)
            N4 = NODES(4)
            DIAG1 = (XN(N3) - XN(N1))**2 + (YN(N3) - YN(N1))**2
            DIAG2 = (XN(N4) - XN(N2))**2 + (YN(N4) - YN(N2))**2
            IF (DIAG2 .NE. 0.0) THEN
               DRAT = DIAG1/DIAG2
               IF (DRAT .GT. 1.0) DRAT = 1.0/DRAT
            ELSE
               DRAT = 0.
            END IF

C  RECORD WORST FIVE

            IF (DRAT .LE. DMAX) THEN
               KR(6) = K
               RHOM(6) = DRAT
               DO 110 I = 1, 5
                  J = 7 - I
                  IF (RHOM(J) .GE. RHOM(J - 1)) GO TO 120
                  TEMP = RHOM(J - 1)
                  RHOM(J - 1) = RHOM(J)
                  RHOM(J) = TEMP
                  KTEMP = KR(J - 1)
                  KR(J - 1) = KR(J)
                  KR(J) = KTEMP
  110          CONTINUE
  120          CONTINUE
            END IF
         END IF
  130 CONTINUE

C  SQUASH WORST ELEMENT NOT VIOLATING THE BOUNDARY

      DO 140 IK = 1, 5
         K = KR(IK)
         IF (K .GT. 0) THEN
            CCW = .TRUE.
            CALL GNXKA (MXND, XN, YN, K, NODES, AREA, LXK, NXL, CCW)
            N1 = NODES(1)
            N2 = NODES(2)
            N3 = NODES(3)
            N4 = NODES(4)
            DIAG1 = (XN(N3) - XN(N1))**2 + (YN(N3) - YN(N1))**2
            DIAG2 = (XN(N4) - XN(N2))**2 + (YN(N4) - YN(N2))**2

C  ARRANGE NODES SO THE SHORT DIAGONAL IS FROM 1ST TO 3RD NODES
C  AND INSURE THAT THE NODE TO BE DELETED IS NOT A BOUNDARY NODE

            IF (DIAG1 .GT. DIAG2) CALL NXKORD (NODES, N2)
            N1 = NODES(1)
            N3 = NODES(3)
            IF (LXN(2, N1) .LE. 0) CALL NXKORD (NODES, N3)
            N1 = NODES(1)
            IF (LXN(2, N1) .GT. 0) GO TO 150
         END IF
  140 CONTINUE
      RETURN

C  PREPARE FOR THE SQUASH OF ELEMENT K

  150 CONTINUE
      DONE = .TRUE.
      N1 = NODES(1)
      N2 = NODES(2)
      N3 = NODES(3)
      N4 = NODES(4)

C  FIND THE LINES ASSOCIATED WITH THE ELEMENT TO BE DELETED

      DO 160 I = 1, 4
         J = I + 1
         IF (J .GE. 5) J = 1
         CALL FNDLNK (MXND, LXK, NXL, K, NODES(I), NODES(J), LINES(I),
     &      ERR)
         IF (ERR) RETURN
         IF (LINES(I) .EQ. 0) THEN
            ERR = .TRUE.
            RETURN
         END IF
  160 CONTINUE

C  FIND ELEMENTS ON OTHER SIDES OF THE LINES
C  K2 AND K3 ARE NEVER NEEDED

      L1 = LINES(1)
      L2 = LINES(2)
      L3 = LINES(3)
      L4 = LINES(4)
      K1 = KXL(1, L1) + KXL(2, L1) - K
      K4 = KXL(1, L4) + KXL(2, L4) - K

C  FIX LXK ARRAY
C  DISCARD L1 FOR L2 IN K1

      DO 170 I = 1, 4
         IF (LXK(I, K1) .EQ. L1) THEN
            LXK(I, K1) = L2
            GO TO 180
         END IF
  170 CONTINUE
      WRITE(*, 10000)K1, L1
      ERR = .TRUE.
      RETURN
  180 CONTINUE

C  DISCARD L4 FOR L3 IN K4

      DO 190 I = 1, 4
         IF (LXK(I, K4) .EQ. L4) THEN
            LXK(I, K4) = L3
            GO TO 200
         END IF
  190 CONTINUE
      WRITE(*, 10000)K1, L1
      ERR = .TRUE.
      RETURN
  200 CONTINUE

C  DELETE ELEMENT K

      DO 210 I = 1, 4
         LXK(I, K) = 0
  210 CONTINUE

C  FIX KXL ARRAY
C  DISCARD K FOR K1 WITH L2

      IF (KXL(1, L2) .EQ. K) THEN
         KXL(1, L2) = K1
      ELSE IF (KXL(2, L2) .EQ. K) THEN
         KXL(2, L2) = K1
      END IF

C  DISCARD K FOR K4 WITH L3

      IF (KXL(1, L3) .EQ. K) THEN
         KXL(1, L3) = K4
      ELSE IF (KXL(2, L3) .EQ. K) THEN
         KXL(2, L3) = K4
      END IF

C  DELETE L1 AND L4

      KXL(1, L1) = 0
      KXL(2, L1) = 0
      KXL(1, L4) = 0
      KXL(2, L4) = 0

C  FIX NXL ARRAY
C  DELETE L1 AND L4

      NXL(1, L1) = 0
      NXL(2, L1) = 0
      NXL(1, L4) = 0
      NXL(2, L4) = 0

C  RECONNECT ALL LINES CONNECTING TO NODE 1 TO NODE 3

      CALL GETLXN (MXND, LXN, N1, L1LIST, NL, ERR)
      IF (ERR) RETURN
      DO 220 I = 1, NL
         LL = L1LIST(I)
         IF (NXL(1, LL) .EQ. N1) THEN
            NXL(1, LL) = N3
         ELSE IF (NXL(2, LL) .EQ. N1) THEN
            NXL(2, LL) = N3
         END IF
  220 CONTINUE

C  FIX LXN ARRAY
C  UNHOOK L1 FROM N2 AND L4 FROM N4

      CALL DELLXN (MXND, LXN, NUID, NAVAIL, IAVAIL, N2, L1, NNN, ERR,
     &   NOROOM)
      IF (ERR) RETURN
      CALL DELLXN (MXND, LXN, NUID, NAVAIL, IAVAIL, N4, L4, NNN, ERR,
     &   NOROOM)
      IF (ERR) RETURN

C  ADD ALL LINES HOOKED TO N3 TO THE LIST OF LINES FOR N3

      DO 230 I = 1, NL
         LL = L1LIST(I)
         IF ((LL .NE. L1) .AND. (LL .NE. L4)) THEN
            CALL ADDLXN (MXND, LXN, NUID, NAVAIL, IAVAIL, N3, LL, NNN,
     &         ERR, NOROOM)
            IF (ERR) RETURN
         END IF
  230 CONTINUE

C  DELETE N1 (UNHOOK EVERYTHING FROM IT)

      DO 240 I = 1, 3
         LXN(I, N1) = 0
  240 CONTINUE
      LXN(4, N1) = IAVAIL
      IAVAIL = N1
      NAVAIL = NAVAIL + 1

C  FIX XN AND YN ARRAYS
C  DEFINE POSITION OF N3

      IF (LXN(2, N3) .GT. 0) THEN
         XN(N3) = 0.5*(XN(N1) + XN(N3))
         YN(N3) = 0.5*(YN(N1) + YN(N3))
      END IF
      NUID(N1) = 0
      RETURN

10000 FORMAT(' IN SQUASH,  ELEMENT', I5, ' DOES NOT CONTAIN LINE', I5)
      END


        subroutine respfn_gauss(lambda,reflambda,beta,nx,ny,obspix,x,y,T, &
	    nmod,pixel,fwhmobj,psf,ncp,refexists,refmodel,nref,rf)

! Calculate spatial response at wavelength lambda of a gaussian object of
! size 'fwhmobj' [pixels], temperature T [K], and unity central optical depth
! at reference wavelength, at (x,y) [arcsec] with respect to image center.
! Output units: Jy/pixel.

        implicit real (a-h,o-z)
        implicit integer (i-n)

        real,   intent(in),                           &
        &       dimension(ncp,ncp)      ::   psf         ! point spread func

        real,   intent(inout),                        &
        &       dimension(nref,nref)    ::   refmodel    ! reference model

        real,   intent(out),                          &
        &       dimension(nx,ny)        ::   rf          ! output image

        real,   allocatable             ::   tau(:,:), image(:,:)
        real,   allocatable             ::   kernel(:,:), refshift(:,:)
        real lambda
        integer xc,yc
        logical refexists

        allocate (image(nref,nref))
        image = 0.
        iref = nref/2 + 1
        fwhm = fwhmobj*pixel
        coef = -4.*log(2.)*(pixel/fwhm)**2

        if (.not.refexists) then
            allocate (tau(nref,nref))
            tau = 0.
            do j = 1,nref
            do i = 1,nref
                tau(i,j) = exp(coef*(float(i-iref)**2 + float(j-iref)**2))
            enddo
            enddo
            pfloor = 1.e-5*planckfn(5000./T,T)

            image = (tau*(reflambda/lambda)**beta * &
                    max(planckfn(lambda,T), pfloor))*pixel**2
            deallocate(tau)

! Convolve with PSF.
            allocate (kernel(ncp+1, ncp+1))
            icp = ncp/2 + 1
            kernel = 0.
            do j = 1,ncp
            do i = 1,ncp
                kernel(ncp-i+2, ncp-j+2) = psf(i,j)
            enddo
            enddo
            kernel = kernel/sum(kernel)
            refmodel = 0.

            do j = icp, nref-icp
            do i = icp, nref-icp
                csum = 0.
                do jj = 1,ncp+1
                do ii = 1,ncp+1
                    csum = csum + kernel(ii,jj)*image(i+ii-icp, j+jj-icp)
                enddo
                enddo
                refmodel(i,j) = csum
            enddo
            enddo
            deallocate(kernel)
            refexists = .true.
        endif

! Refmodel is an array nref by nref with centre pixel (iref,iref).
! We need to interpolate at intervals of obspix/pixel (= 1/mag) onto
! an array nx by ny which is centred on (iref,iref).

! Shift the array by xc,yc.
        allocate (refshift(nref,nref))
        xc = nint(x/pixel)
        yc = nint(y/pixel)
        ilo = max(xc+1, 1)
        jlo = max(yc+1, 1)
        ihi = min(xc+nref, nref)
        jhi = min(yc+nref, nref)
        do j = jlo,jhi
        do i = ilo,ihi
            refshift(i-xc, j-yc) = refmodel(i,j)
        enddo
        enddo

! Resample to Nyquist-sampled pixel size.
        rmag = pixel/obspix
        call resample(refshift,nref,nref,image,nref,nref,rmag)
        deallocate(refshift)
        image = image/rmag**2

        if (nref >= nx .and. nref >= ny) then
            rf = image(iref-nx/2:iref-nx/2+nx-1, iref-ny/2:iref-ny/2+ny-1)
        else
            rf = 0.
            ilo = max(2-iref+nx/2, 1)
            jlo = max(2-iref+ny/2, 1)
            ihi = min(nref-iref+nx/2+1, nref)
            do j = 1,nref
            do i = 1,nref
                rf(i,j) = image(iref-nx/2+i-1, iref-ny/2+j-1)
            enddo
            enddo
        endif

        deallocate(image)
        return

        end subroutine respfn_gauss


*DECK D9CHU
      DOUBLE PRECISION FUNCTION D9CHU (A, B, Z)
C***BEGIN PROLOGUE  D9CHU
C***SUBSIDIARY
C***PURPOSE  Evaluate for large Z  Z**A * U(A,B,Z) where U is the
C            logarithmic confluent hypergeometric function.
C***LIBRARY   SLATEC (FNLIB)
C***CATEGORY  C11
C***TYPE      DOUBLE PRECISION (R9CHU-S, D9CHU-D)
C***KEYWORDS  FNLIB, LOGARITHMIC CONFLUENT HYPERGEOMETRIC FUNCTION,
C             SPECIAL FUNCTIONS
C***AUTHOR  Fullerton, W., (LANL)
C***DESCRIPTION
C
C Evaluate for large Z  Z**A * U(A,B,Z)  where U is the logarithmic
C confluent hypergeometric function.  A rational approximation due to Y.
C L. Luke is used.  When U is not in the asymptotic region, i.e., when A
C or B is large compared with Z, considerable significance loss occurs.
C A warning is provided when the computed result is less than half
C precision.
C
C***REFERENCES  (NONE)
C***ROUTINES CALLED  D1MACH, XERMSG
C***REVISION HISTORY  (YYMMDD)
C   770801  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   890531  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900315  CALLs to XERROR changed to CALLs to XERMSG.  (THJ)
C   900720  Routine changed from user-callable to subsidiary.  (WRB)
C***END PROLOGUE  D9CHU
      DOUBLE PRECISION A, B, Z, AA(4), BB(4), AB, ANBN, BP, CT1, CT2,
     1  CT3, C2, D1Z, EPS, G1, G2, G3, SAB, SQEPS, X2I1,  D1MACH
      LOGICAL FIRST
      SAVE EPS, SQEPS, FIRST
      DATA FIRST /.TRUE./
C***FIRST EXECUTABLE STATEMENT  D9CHU
      IF (FIRST) THEN
         EPS = 4.0D0*D1MACH(4)
         SQEPS = SQRT(D1MACH(4))
      ENDIF
      FIRST = .FALSE.
C
      BP = 1.0D0 + A - B
      AB = A*BP
      CT2 = 2.0D0 * (Z - AB)
      SAB = A + BP
C
      BB(1) = 1.0D0
      AA(1) = 1.0D0
C
      CT3 = SAB + 1.0D0 + AB
      BB(2) = 1.0D0 + 2.0D0*Z/CT3
      AA(2) = 1.0D0 + CT2/CT3
C
      ANBN = CT3 + SAB + 3.0D0
      CT1 = 1.0D0 + 2.0D0*Z/ANBN
      BB(3) = 1.0D0 + 6.0D0*CT1*Z/CT3
      AA(3) = 1.0D0 + 6.0D0*AB/ANBN + 3.0D0*CT1*CT2/CT3
C
      DO 30 I=4,300
        X2I1 = 2*I - 3
        CT1 = X2I1/(X2I1-2.0D0)
        ANBN = ANBN + X2I1 + SAB
        CT2 = (X2I1 - 1.0D0)/ANBN
        C2 = X2I1*CT2 - 1.0D0
        D1Z = X2I1*2.0D0*Z/ANBN
C
        CT3 = SAB*CT2
        G1 = D1Z + CT1*(C2+CT3)
        G2 = D1Z - C2
        G3 = CT1*(1.0D0 - CT3 - 2.0D0*CT2)
C
        BB(4) = G1*BB(3) + G2*BB(2) + G3*BB(1)
        AA(4) = G1*AA(3) + G2*AA(2) + G3*AA(1)
        IF (ABS(AA(4)*BB(1)-AA(1)*BB(4)).LT.EPS*ABS(BB(4)*BB(1)))
     1    GO TO 40
C
C IF OVERFLOWS OR UNDERFLOWS PROVE TO BE A PROBLEM, THE STATEMENTS
C BELOW COULD BE ALTERED TO INCORPORATE A DYNAMICALLY ADJUSTED SCALE
C FACTOR.
C
        DO 20 J=1,3
          AA(J) = AA(J+1)
          BB(J) = BB(J+1)
 20     CONTINUE
 30   CONTINUE
      CALL XERMSG ('SLATEC', 'D9CHU', 'NO CONVERGENCE IN 300 TERMS', 2,
     +   2)
C
 40   D9CHU = AA(4)/BB(4)
C
      IF (D9CHU .LT. SQEPS .OR. D9CHU .GT. 1.0D0/SQEPS) CALL XERMSG
     +   ('SLATEC', 'D9CHU', 'ANSWER LT HALF PRECISION', 2, 1)
C
      RETURN
      END


submodule (real_transform_routines:multiple_real_backward) real_backward_2d

contains

    module subroutine rfft2b(ldim, l, m, r, wsave, lensav, work, lenwrk, ierror)
        !
        ! rfft2b: real backward fast fourier transform, 2d.
        !
        ! purpose:
        !
        !  computes the two-dimensional discrete fourier transform of the
        !  complex fourier coefficients a real periodic array.  this transform is
        !  known as the backward transform or fourier synthesis, transforming from
        !  spectral to physical space.  routine rfft2b is normalized: a call to
        !  rfft2b followed by a call to rfft2f (or vice-versa) reproduces the
        !  original array within roundoff error.
        !
        !  parameters:
        !
        !  integer ldim, the first dimension of the 2d real
        !  array r, which must be at least 2*(l/2+1).
        !
        !  integer l, the number of elements to be transformed
        !  in the first dimension of the two-dimensional real array r.  the value of
        !  l must be less than or equal to that of ldim.  the transform is most
        !  efficient when l is a product of small primes.
        !
        !  integer m, the number of elements to be transformed
        !  in the second dimension of the two-dimensional real array r.  the transform
        !  is most efficient when m is a product of small primes.
        !
        !  input/real r(ldim,m), the real array of two
        !  dimensions.  on input, r contains the l/2+1-by-m complex subarray of
        !  spectral coefficients, on output, the physical coefficients.
        !
        !  input, real (wp) wsave(lensav).  wsave's contents must be
        !  initialized with a call to rfft2i before the first call to routine rfft2f
        !  or rfft2b with lengths l and m.  wsave's contents may be re-used for
        !  subsequent calls to rfft2f and rfft2b with the same transform lengths
        !  l and m.
        !
        !  integer lensav, the number of elements in the wsave
        !  array.  lensav must be at least l + m + int(log(real(l)))
        !  + int(log(real(m))) + 8.
        !
        !  workspace, real (wp) work(lenwrk).  work provides workspace, and
        !  its contents need not be saved between calls to routines rfft2b and rfft2f.
        !
        !  integer  lenwrk, the number of elements in the work
        !  array.  lenwrk must be at least ldim*m.
        !
        !  integer ierror, the error_flag.
        !  0, successful exit;
        !  2, input parameter lensav not big enough;
        !  3, input parameter lenwrk not big enough;
        !  6, input parameter ldim < 2*(l/2+1);
        !  20, input error returned by lower level routine.
        !
        !--------------------------------------------------------------
        ! Dummy arguments
        !--------------------------------------------------------------
        integer (ip), intent (in)     :: ldim
        integer (ip), intent (in)     :: l
        integer (ip), intent (in)     :: m
        real (wp),    intent (in out) :: r(ldim,m)
        real (wp),    intent (in)     :: wsave(lensav)
        integer (ip), intent (in)     :: lensav
        real (wp),    intent (out)    :: work(lenwrk)
        integer (ip), intent (in)     :: lenwrk
        integer (ip), intent (out)    :: ierror
        !--------------------------------------------------------------
        ! Local variables
        !--------------------------------------------------------------
        integer (ip) :: local_error_flag
        integer (ip) :: ldh, ldw, ldx, lwsav
        integer (ip) :: mmsav, modl, modm, mwsav
        !--------------------------------------------------------------

        ! Initialize error flag
        ierror = 0

        !
        !==> verify lensav
        !
        lwsav = l+int(log(real(l, kind=wp))/log(TWO))+4
        mwsav = get_1d_saved_workspace_length(m)
        mmsav = m+int(log(real(m, kind=wp))/log(TWO))+4
        modl = mod(l,2)
        modm = mod(m,2)

        if (lensav < lwsav+mwsav+mmsav) then
            ierror = 2
            call fft_error_handler('rfft2f', 6)
            return
        end if
        !
        ! verify lenwrk
        !
        if (lenwrk < (l+1)*m) then
            ierror = 3
            call fft_error_handler('rfft2f', 8)
            return
        end if
        !
        ! verify ldim is as big as l
        !
        if (ldim < l) then
            ierror = 5
            call fft_error_handler('rfft2f', -6)
            return
        end if
        !
        !==> Transform second dimension of array
        !
        associate( mj => 2*((m+1)/2)-1 )

            r(1,2:mj) = TWO * r(1,2:mj)

        end associate

        r(1,3:m:2) = -r(1,3:m:2)

        call rfftmb(1,1,m,ldim,r,m*ldim, wsave(lwsav+mwsav+1),mmsav,work,lenwrk,local_error_flag)

        ldh = int((l+1)/2)

        if ( 1 < ldh ) then
            ldw = ldh+ldh
            !
            !  r and work are switched because the the first dimension
            !  of the input to complex cfftmf must be even.
            !
            call r2w(ldim,ldw,l,m,r,work)

            call cfftmb(ldh-1,1,m,ldh,work(2),ldh*m, &
                wsave(lwsav+1),mwsav,r,l*m, local_error_flag)

            if (local_error_flag/=0) then
                ierror = 20
                call fft_error_handler('rfft2b',-5)
                return
            end if

            call w2r(ldim,ldw,l,m,r,work)
        end if

        if (modl == 0) then

            associate( mj => 2*((m+1)/2)-1 )

                r(l,2:mj) = TWO * r(l,2:mj)

            end associate

            r(l,3:m:2) = -r(l,3:m:2)

            call rfftmb(1,1,m,ldim,r(l,1),m*ldim, &
                wsave(lwsav+mwsav+1),mmsav,work,lenwrk,local_error_flag)
        end if
        !
        !==> Transform first dimension of array
        !
        ldx = 2*int((l+1)/2)-1

        r(2:ldx,1:m) = TWO * r(2:ldx,1:m)
        r(3:ldx:2,1:m) = -r(3:ldx:2,1:m)

        associate( &
            arg_1 => m*ldim, &
            arg_2 => l+int(log(real(l, kind=wp) )/log(TWO))+4 &
            )

            call rfftmb(m,ldim,l,1,r,arg_1,wsave(1), arg_2,work,lenwrk,local_error_flag)

        end associate

        if (local_error_flag /= 0) then
            ierror = 20
            call fft_error_handler('rfft2f',-5)
        end if

    end subroutine rfft2b

end submodule real_backward_2d


!!!************************************************************
!!!*						                	                *
!!!*                     Thermal 1D      	         	    *
!!!*							        	                    *
!!!*                Author: Dr. Andrea Boghi  		        *
!!!*							        	                    *
!!!*								                            *
!!!************************************************************

Program main_theraml
    implicit none
    real*8,allocatable :: y(:),U(:),kt(:),eps(:)
    real*8,allocatable :: T(:),Th2(:),T0(:),Th20(:)
    real*8,allocatable :: nut(:),f2(:),dnutdy(:),dUdy(:)
    integer j,ny,iter,niter
    real*8  Re_tau,sigmaT,sigmaTh2,Ce1,Ce2,alphaT,alphaTh2
    real*8 resT,resTh2,dy,aT_w,aT_e,sT,aTh2_w,aTh2_e,sTh2, conv_fac
    logical flag

    open(1,file='imp_ther.dat')
    read(1,*) flag
    read(1,*) ny
    read(1,*) niter
    read(1,*) Re_tau
    read(1,*) alphaT
    read(1,*) alphaTh2
    close(1)

    print*, ' niter =', niter, ' ny =', ny
    print*, ' Re_tau =', Re_tau, ' flag =', flag

    allocate(y(1:ny),U(1:ny),kt(1:ny),eps(1:ny),nut(1:ny),dnutdy(1:ny),dUdy(1:ny),f2(1:ny))
    allocate(T(1:ny),Th2(1:ny),T0(1:ny),Th20(1:ny))

    open(1,file='point_ke.dat',form='unformatted')
    read(1) y(1:ny),U(1:ny),Kt(1:ny),eps(1:ny),nut(1:ny),f2(1:ny)
    close(1)

    open(14,file='momentum_test.csv',form='formatted')
    write(14,*) '"y","U","k","epsilon","nut"'
    do j=1,ny
       write(14,101) y(j),',',U(j),',',Kt(j),',',eps(j),',',nut(j)
    enddo
    close(14)

    goto 1001

    conv_fac = 1.d0
    open(11,file='residuals_thermal.csv')
    write(11,*) '"iter","resT","resTh2"'

    do iter=1,niter

        T0 = T
        Th20 = Th2

        call ddy(ny,nut,dnutdy,dy)
        call ddy(ny,U,dUdy,dy)
        T(1) = 0.d0
        Th2(1) = 0.d0
        do j =2,ny-1
            call T_coefficients(aT_w,aT_e,sT,nut(j),dnutdy(j),dy,Re_tau,sigmaT)
            T(j) =  sT + aT_e*T(j+1) + aT_w*T(j-1)
            call Th2_coefficients(aTh2_w,aTh2_e,sTh2,eps(j),nut(j),dnutdy(j),dUdy(j),dy,sigmaTh2)
            Th2(j) = sTh2 + aTh2_e*Th2(j+1) + aTh2_w*Th2(j-1)
        enddo
        call T_coefficients(aT_w,aT_e,sT,nut(ny),dnutdy(ny),dy,Re_tau,sigmaT)
        T(ny) =  sT + (aT_e + aT_w)*T(ny-1)
        call Th2_coefficients(aTh2_w,aTh2_e,sTh2,eps(ny),nut(ny),dnutdy(ny),dUdy(ny),dy,sigmaTh2)
        Th2(ny) = sTh2 + (aTh2_e + aTh2_w)*Th2(ny-1)

        call residuals(ny,T,T0,resT)
        call residuals(ny,Th2,Th20,resTh2)

        write(11,102) conv_fac*iter,',',resT,',',resTh2

        T = dabs(alphaT*T +(1.d0-alphaT)*T0)
        Th2 = dabs(alphaTh2*Th2 +(1.d0-alphaTh2)*Th20)
        print*, ' completed =', 100*real(iter)/real(niter), ' resT = ', resT, ' resTh2 = ', resTh2

    enddo
    close(11)

    open(1,file='point_thermal.dat',form='unformatted')
    write(1) y,T,Th2
    close(1)

    open(14,file='momentum_test.csv',form='formatted')
    write(14,*) '"y","U","k","epsilon","nut"'
    do j=1,ny
       write(14,101) y(j),',',U(j),',',Kt(j),',',eps(j),',',nut(j)
    enddo
    close(14)

    101 format(e18.10,A,e18.10,A,e18.10,A,e18.10,A,e18.10)

    102 format(e18.10,A,e18.10,A,e18.10)

    1001 continue

    end


      PROGRAM SPRING
        IMPLICIT REAL*8(A-H,O-Z)
        REAL*8 SK(16,16), SM(16,16), COORDS(2,16)
        INTEGER IRNODES_WO(6), IRNODES(10), IMNODES(10)
        REAL*8 EIGVALS(41*41,8)
        PARAMETER (PI = 3.141592653589793)

        OPEN(8,FILE ="spring.fre")

        IRNODES_WO(1) = 1; IRNODES_WO(4) = 10
        IRNODES_WO(2) = 2; IRNODES_WO(5) = 15
        IRNODES_WO(3) = 9; IRNODES_WO(6) = 16

        IRNODES(1) = 1; IRNODES(6) = 2
        IRNODES(2) = 2; IRNODES(7) = 15
        IRNODES(3) = 9; IRNODES(8) = 16
        IRNODES(4) = 10; IRNODES(9) = 1
        IRNODES(5) = 1; IRNODES(10) = 2

        IMNODES(1) = 7; IMNODES(6) = 6
        IMNODES(2) = 8; IMNODES(7) = 11
        IMNODES(3) = 13; IMNODES(8) = 12
        IMNODES(4) = 14; IMNODES(9) = 3
        IMNODES(5) = 5; IMNODES(10) = 4

        CALL MAT(16,SK,SM)

        COORDS(1,1) = -1.0; COORDS(2,1) = -1.0
        COORDS(1,2) = -1.0; COORDS(2,2) = -1.0
        COORDS(1,3) = 1.0; COORDS(2,3) = -1.0
        COORDS(1,4) = 1.0; COORDS(2,4) = -1.0
        COORDS(1,5) = 1.0; COORDS(2,5) = 1.0
        COORDS(1,6) = 1.0; COORDS(2,6) = 1.0
        COORDS(1,7) = -1.0; COORDS(2,7) = 1.0
        COORDS(1,8) = -1.0; COORDS(2,8) = 1.0
        COORDS(1,9) = 0.0; COORDS(2,9) = -1.0
        COORDS(1,10) = 0.0; COORDS(2,10) = -1.0
        COORDS(1,11) = 1.0; COORDS(2,11) = 0.0
        COORDS(1,12) = 1.0; COORDS(2,12) = 0.0
        COORDS(1,13) = 0.0; COORDS(2,13) = 1.0
        COORDS(1,14) = 0.0; COORDS(2,14) = 1.0
        COORDS(1,15) = -1.0; COORDS(2,15) = 0.0
        COORDS(1,16) = -1.0; COORDS(2,16) = 0.0

        NCOR = 16
        NDOF = 16
        NCOND = 10
        NCOND_WO = 6

        AKXMIN = -PI/2.0
        AKYMIN = -PI/2.0
        AKXMAX = PI/2.0
        AKYMAX = PI/2.0

        NEVALS = 6

        NKX = 41
        NKY = 41

        CALL BLOCH(NDOF,SK,SM,NCOR,COORDS,NCOND_WO,NCOND,
     1           IRNODES_WO,IMNODES,IRNODES,NEVALS,AKXMIN,
     2           AKYMIN,AKXMAX,AKYMAX,NKX,NKY,EIGVALS)

        DO I=1,NKX*NKY
            DO J=1,NEVALS+2
                WRITE(8,*) EIGVALS(I,J)
            END DO
        END DO

      END PROGRAM SPRING


      SUBROUTINE UNPK_MERCATOR(KFILDO,IPACK,ND5,IS3,NS3,
     1                         L3264B,LOCN,IPOS,BOUST,IER,*)
C
C        MARCH    2000   LAWRENCE  GSC/TDL    ORIGINAL CODING
C        JANUARY  2001   GLAHN     COMMENTS; ADDED * ARGUMENT
C                                  TO CALL TO UNEARTH; CHANGED
C                                  COMPUTATION OF NEGATIVE VALUE;
C                                  CHANGED TO STANDARD RETURN SEQUENCE
C        FEBRUARY 2001   GLAHN     CHECKED SIZE OF NS3; COMMENTS
C        NOVEMBER 2001   GLAHN     COMMENT ON IS3( ) SIZE
C
C        PURPOSE
C            UNPACKS TEMPLATE 3.10, A MERCATOR MAP PROJECTION FROM
C            IN SECTION 3 OF A GRIB2 MESSAGE.
C            DATA ARE PLACED INTO THE IS3( ) ARRAY.
C            IT IS THE RESPONSIBILITY OF THE CALLING ROUTINE
C            TO UNPACK THE FIRST 14 OCTETS IN SECTION 3.
C
C        DATA SET USE
C           KFILDO - UNIT NUMBER FOR OUTPUT (PRINT) FILE. (OUTPUT)
C
C        VARIABLES
C              KFILDO = UNIT NUMBER FOR OUTPUT (PRINT) FILE. (INPUT)
C            IPACK(J) = THE ARRAY THAT HOLDS THE ACTUAL PACKED MESSAGE
C                       (J=1,ND5). (INPUT/OUTPUT)
C                 ND5 = THE SIZE OF THE ARRAY IPACK( ). (INPUT)
C              IS3(J) = THE MERCATOR PROJECTION INFORMATION
C                       IS WRITTEN TO ELEMENTS 15 THROUGH 69
C                       AS IT IS UNPACKED FROM IPACK( ) (J=1,NS3).
C                       (INPUT/OUTPUT)
C                 NS3 = SIZE OF IS3( ). (INPUT)
C              L3264B = THE INTEGER WORD LENGTH IN BITS OF THE
C                       MACHINE BEING USED. VALUES OF 32 AND 64 ARE
C                       ACCOMMODATED. (INPUT)
C                LOCN = THE WORD POSITION FROM WHICH TO UNPACK THE
C                       NEXT VALUE. (INPUT/OUTPUT)
C                IPOS = THE BIT POSITION IN LOCN FROM WHICH TO START
C                       UNPACKING THE NEXT VALUE.  (INPUT/OUTPUT)
C               BOUST = .TRUE. IF THE DATA FIELD WAS SCANNED
C                       BOUSTROPHEDONICALLY. .FALSE. OTHERWISE.
C                       (LOGICAL) (OUTPUT)
C                 IER = RETURN STATUS CODE. (OUTPUT)
C                         0 = GOOD RETURN.
C                       6-8 = ERROR CODES GENERATED BY UNPKBG. SEE THE
C                             DOCUMENTATION IN THE UNPKBG ROUTINE.
C                       302 = IS3( ) NOT DIMENSIONED LARGE ENOUGH.
C                       303 = UNSUPPORTED GRID TEMPLATE INDICATED
C                             BY IS3(13).
C                       307 = UNRECOGNIZED OR UNSUPPORTED SHAPE OF
C                             EARTH CODE IN IS3(15) RETURNED FROM UNEARTH.
C                   * = ALTERNATE RETURN WHEN IER .NE. 0
C
C             LOCAL VARIABLES
C               ISIGN = A FLAG INDICATING WHETHER AN UNPACKED VALUE
C                       IS POSITIVE OR NEGATIVE.
C                   N = L3264B = THE INTEGER WORD LENGTH IN BITS OF
C                       THE MACHINE BEING USED. VALUES OF 32 AND
C                       64 ARE ACCOMMODATED.
C
C        NON SYSTEM SUBROUTINES CALLED
C           UNEARTH, UNPKBG
C
      LOGICAL BOUST
C
      DIMENSION IPACK(ND5),IS3(NS3)
C
      N=L3264B
      IER=0
C
C        CHECK TO MAKE SURE THAT A MERCATOR PROJECTION
C        IS PACKED IN THIS GRIB2 MESSAGE.
      IF (IS3(13).NE.10)THEN
D        WRITE(KFILDO,10)IS3(13)
D10      FORMAT(/' MAP PROJECTION CODE ',I4,' INDICATED BY IS3(13)'/
D    1           ' IS NOT MERCATOR. PLEASE REFER TO THE'/
D    2           ' GRIB2 DOCUMENTATION TO DETERMINE THE'/
D    3           ' CORRECT MAP PROJECTION PACKER TO CALL.'/)
         IER=303
         GO TO 900
      ENDIF
C
C        CHECK SIZE OF IS3( ).
C
      IF(NS3.LT.69)THEN
         IER=302
         GO TO 900
      ENDIF
C
C        UNPACK THE SHAPE OF THE EARTH.
      CALL UNEARTH(KFILDO,IPACK,ND5,IS3,NS3,N,LOCN,IPOS,IER,*900)
      IF(IER.NE.0)GO TO 900
C
C        UNPACK THE NUMBER POINTS ALONG A PARALLEL AND THE NUMBER
C        OF POINTS ALONG ALONG A MERIDIAN (Ni & Nj).
      CALL UNPKBG(KFILDO,IPACK,ND5,LOCN,IPOS,IS3(31),32,N,IER,*900)
      CALL UNPKBG(KFILDO,IPACK,ND5,LOCN,IPOS,IS3(35),32,N,IER,*900)
C
C        UNPACK THE LATITUDE & LONGITUDE OF THE FIRST GRID POINT
C        TAKING INTO CONSIDERATION THAT THE VALUE MAY BE
C        NEGATIVE.
      CALL UNPKBG(KFILDO,IPACK,ND5,LOCN,IPOS,ISIGN,1,N,IER,*900)
      CALL UNPKBG(KFILDO,IPACK,ND5,LOCN,IPOS,IS3(39),
     1          31,N,IER,*900)
      IF(ISIGN.EQ.1)IS3(39)=-IS3(39)
      CALL UNPKBG(KFILDO,IPACK,ND5,LOCN,IPOS,ISIGN,1,N,IER,*900)
      CALL UNPKBG(KFILDO,IPACK,ND5,LOCN,IPOS,IS3(43),
     1          31,N,IER,*900)
      IF(ISIGN.EQ.1)IS3(43)=-IS3(43)
C
C        UNPACK THE RESOLUTION AND COMPONENT FLAGS.
      CALL UNPKBG(KFILDO,IPACK,ND5,LOCN,IPOS,IS3(47),8,N,IER,*900)
C
C        UNPACK THE LATITUDE AT WHICH THE MERCATOR PROJECTION
C        INTERSECTS THE EARTH (THE LATITUDE WHERE THE LATITUDINAL
C        AND LONGITUDINAL GRID LENGTHS ARE SPECIFIED).
      CALL UNPKBG(KFILDO,IPACK,ND5,LOCN,IPOS,ISIGN,1,N,IER,*900)
      CALL UNPKBG(KFILDO,IPACK,ND5,LOCN,IPOS,IS3(48),
     1          31,N,IER,*900)
      IF(ISIGN.EQ.1)IS3(48)=-IS3(48)
C
C        UNPACK THE LATITUDE OF THE LAST GRID POINT.
      CALL UNPKBG(KFILDO,IPACK,ND5,LOCN,IPOS,ISIGN,1,N,IER,*900)
      CALL UNPKBG(KFILDO,IPACK,ND5,LOCN,IPOS,IS3(52),
     1          31,N,IER,*900)
      IF(ISIGN.EQ.1)IS3(52)=-IS3(52)
C
C        UNPACK THE LONGITUDE OF THE LAST GRID POINT.
      CALL UNPKBG(KFILDO,IPACK,ND5,LOCN,IPOS,ISIGN,1,N,IER,*900)
      CALL UNPKBG(KFILDO,IPACK,ND5,LOCN,IPOS,IS3(56),
     1          31,N,IER,*900)
      IF(ISIGN.EQ.1)IS3(56)=-IS3(56)
C
C        UNPACK THE SCANNING MODE.
      CALL UNPKBG(KFILDO,IPACK,ND5,LOCN,IPOS,IS3(60),8,N,IER,*900)
C
      IF(IAND(IS3(60),16).EQ.16)THEN
C           THE MASK GETS BIT 4 (FROM THE LEFT); WHEN IT IS 1,
C           BOUST IS TRUE.; OTHERWISE BOUST IS FALSE.
         BOUST=.TRUE.
         IS3(60)=IAND(IS3(60),239)
C           BIT 4 IS SET = 0, BECAUSE THE DATA ARE RETURNED
C           NON-BOUSTROPHEDONICALLY ORDERED EVEN THOUGH THEY WERE
C           PACKED THAT WAY.  239 DECIMAL = 357 OCTAL PRESERVES
C           ALL OTHER BITS IN THE OCTET.
      ELSE
         BOUST=.FALSE.
      ENDIF
C
C        UNPACK THE ORIENTATION ANGLE OF THE GRID (THE ANGLE
C        BETWEEN THE MAP'S I DIRECTION AND THE EARTH'S
C        EQUATOR).
      CALL UNPKBG(KFILDO,IPACK,ND5,LOCN,IPOS,IS3(61),32,N,IER,*900)
C
C        UNPACK THE LONGITUDINAL AND LATITUDINAL DIRECTION GRID LENGTHS
      CALL UNPKBG(KFILDO,IPACK,ND5,LOCN,IPOS,IS3(65),32,N,IER,*900)
      CALL UNPKBG(KFILDO,IPACK,ND5,LOCN,IPOS,IS3(69),32,N,IER,*900)
C
C       ERROR RETURN SECTION
C
 900  IF(IER.NE.0)RETURN 1
C
      RETURN
      END


*DECK SGEFA
      SUBROUTINE SGEFA (A, LDA, N, IPVT, INFO)
C***BEGIN PROLOGUE  SGEFA
C***PURPOSE  Factor a matrix using Gaussian elimination.
C***CATEGORY  D2A1
C***TYPE      SINGLE PRECISION (SGEFA-S, DGEFA-D, CGEFA-C)
C***KEYWORDS  GENERAL MATRIX, LINEAR ALGEBRA, LINPACK,
C             MATRIX FACTORIZATION
C***AUTHOR  Moler, C. B., (U. of New Mexico)
C***DESCRIPTION
C
C     SGEFA factors a real matrix by Gaussian elimination.
C
C     SGEFA is usually called by SGECO, but it can be called
C     directly with a saving in time if  RCOND  is not needed.
C     (Time for SGECO) = (1 + 9/N)*(Time for SGEFA) .
C
C     On Entry
C
C        A       REAL(LDA, N)
C                the matrix to be factored.
C
C        LDA     INTEGER
C                the leading dimension of the array  A .
C
C        N       INTEGER
C                the order of the matrix  A .
C
C     On Return
C
C        A       an upper triangular matrix and the multipliers
C                which were used to obtain it.
C                The factorization can be written  A = L*U , where
C                L  is a product of permutation and unit lower
C                triangular matrices and  U  is upper triangular.
C
C        IPVT    INTEGER(N)
C                an integer vector of pivot indices.
C
C        INFO    INTEGER
C                = 0  normal value.
C                = K  if  U(K,K) .EQ. 0.0 .  This is not an error
C                     condition for this subroutine, but it does
C                     indicate that SGESL or SGEDI will divide by zero
C                     if called.  Use  RCOND  in SGECO for a reliable
C                     indication of singularity.
C
C***REFERENCES  J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W.
C                 Stewart, LINPACK Users' Guide, SIAM, 1979.
C***ROUTINES CALLED  ISAMAX, SAXPY, SSCAL
C***REVISION HISTORY  (YYMMDD)
C   780814  DATE WRITTEN
C   890831  Modified array declarations.  (WRB)
C   890831  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900326  Removed duplicate information from DESCRIPTION section.
C           (WRB)
C   920501  Reformatted the REFERENCES section.  (WRB)
C***END PROLOGUE  SGEFA
      INTEGER LDA,N,IPVT(*),INFO
      REAL A(LDA,*)
C
      REAL T
      INTEGER ISAMAX,J,K,KP1,L,NM1
C
C     GAUSSIAN ELIMINATION WITH PARTIAL PIVOTING
C
C***FIRST EXECUTABLE STATEMENT  SGEFA
      INFO = 0
      NM1 = N - 1
      IF (NM1 .LT. 1) GO TO 70
      DO 60 K = 1, NM1
         KP1 = K + 1
C
C        FIND L = PIVOT INDEX
C
         L = ISAMAX(N-K+1,A(K,K),1) + K - 1
         IPVT(K) = L
C
C        ZERO PIVOT IMPLIES THIS COLUMN ALREADY TRIANGULARIZED
C
         IF (A(L,K) .EQ. 0.0E0) GO TO 40
C
C           INTERCHANGE IF NECESSARY
C
            IF (L .EQ. K) GO TO 10
               T = A(L,K)
               A(L,K) = A(K,K)
               A(K,K) = T
   10       CONTINUE
C
C           COMPUTE MULTIPLIERS
C
            T = -1.0E0/A(K,K)
            CALL SSCAL(N-K,T,A(K+1,K),1)
C
C           ROW ELIMINATION WITH COLUMN INDEXING
C
            DO 30 J = KP1, N
               T = A(L,J)
               IF (L .EQ. K) GO TO 20
                  A(L,J) = A(K,J)
                  A(K,J) = T
   20          CONTINUE
               CALL SAXPY(N-K,T,A(K+1,K),1,A(K+1,J),1)
   30       CONTINUE
         GO TO 50
   40    CONTINUE
            INFO = K
   50    CONTINUE
   60 CONTINUE
   70 CONTINUE
      IPVT(N) = N
      IF (A(N,N) .EQ. 0.0E0) INFO = N
      RETURN
      END
*DECK SGESL
      SUBROUTINE SGESL (A, LDA, N, IPVT, B, JOB)
C***BEGIN PROLOGUE  SGESL
C***PURPOSE  Solve the real system A*X=B or TRANS(A)*X=B using the
C            factors of SGECO or SGEFA.
C***CATEGORY  D2A1
C***TYPE      SINGLE PRECISION (SGESL-S, DGESL-D, CGESL-C)
C***KEYWORDS  LINEAR ALGEBRA, LINPACK, MATRIX, SOLVE
C***AUTHOR  Moler, C. B., (U. of New Mexico)
C***DESCRIPTION
C
C     SGESL solves the real system
C     A * X = B  or  TRANS(A) * X = B
C     using the factors computed by SGECO or SGEFA.
C
C     On Entry
C
C        A       REAL(LDA, N)
C                the output from SGECO or SGEFA.
C
C        LDA     INTEGER
C                the leading dimension of the array  A .
C
C        N       INTEGER
C                the order of the matrix  A .
C
C        IPVT    INTEGER(N)
C                the pivot vector from SGECO or SGEFA.
C
C        B       REAL(N)
C                the right hand side vector.
C
C        JOB     INTEGER
C                = 0         to solve  A*X = B ,
C                = nonzero   to solve  TRANS(A)*X = B  where
C                            TRANS(A)  is the transpose.
C
C     On Return
C
C        B       the solution vector  X .
C
C     Error Condition
C
C        A division by zero will occur if the input factor contains a
C        zero on the diagonal.  Technically, this indicates singularity,
C        but it is often caused by improper arguments or improper
C        setting of LDA .  It will not occur if the subroutines are
C        called correctly and if SGECO has set RCOND .GT. 0.0
C        or SGEFA has set INFO .EQ. 0 .
C
C     To compute  INVERSE(A) * C  where  C  is a matrix
C     with  P  columns
C           CALL SGECO(A,LDA,N,IPVT,RCOND,Z)
C           IF (RCOND is too small) GO TO ...
C           DO 10 J = 1, P
C              CALL SGESL(A,LDA,N,IPVT,C(1,J),0)
C        10 CONTINUE
C
C***REFERENCES  J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W.
C                 Stewart, LINPACK Users' Guide, SIAM, 1979.
C***ROUTINES CALLED  SAXPY, SDOT
C***REVISION HISTORY  (YYMMDD)
C   780814  DATE WRITTEN
C   890831  Modified array declarations.  (WRB)
C   890831  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900326  Removed duplicate information from DESCRIPTION section.
C           (WRB)
C   920501  Reformatted the REFERENCES section.  (WRB)
C***END PROLOGUE  SGESL
      INTEGER LDA,N,IPVT(*),JOB
      REAL A(LDA,*),B(*)
C
      REAL SDOT,T
      INTEGER K,KB,L,NM1
C***FIRST EXECUTABLE STATEMENT  SGESL
      NM1 = N - 1
      IF (JOB .NE. 0) GO TO 50
C
C        JOB = 0 , SOLVE  A * X = B
C        FIRST SOLVE  L*Y = B
C
         IF (NM1 .LT. 1) GO TO 30
         DO 20 K = 1, NM1
            L = IPVT(K)
            T = B(L)
            IF (L .EQ. K) GO TO 10
               B(L) = B(K)
               B(K) = T
   10       CONTINUE
            CALL SAXPY(N-K,T,A(K+1,K),1,B(K+1),1)
   20    CONTINUE
   30    CONTINUE
C
C        NOW SOLVE  U*X = Y
C
         DO 40 KB = 1, N
            K = N + 1 - KB
            B(K) = B(K)/A(K,K)
            T = -B(K)
            CALL SAXPY(K-1,T,A(1,K),1,B(1),1)
   40    CONTINUE
      GO TO 100
   50 CONTINUE
C
C        JOB = NONZERO, SOLVE  TRANS(A) * X = B
C        FIRST SOLVE  TRANS(U)*Y = B
C
         DO 60 K = 1, N
            T = SDOT(K-1,A(1,K),1,B(1),1)
            B(K) = (B(K) - T)/A(K,K)
   60    CONTINUE
C
C        NOW SOLVE TRANS(L)*X = Y
C
         IF (NM1 .LT. 1) GO TO 90
         DO 80 KB = 1, NM1
            K = N - KB
            B(K) = B(K) + SDOT(N-K,A(K+1,K),1,B(K+1),1)
            L = IPVT(K)
            IF (L .EQ. K) GO TO 70
               T = B(L)
               B(L) = B(K)
               B(K) = T
   70       CONTINUE
   80    CONTINUE
   90    CONTINUE
  100 CONTINUE
      RETURN
      END
*DECK SGBFA
      SUBROUTINE SGBFA (ABD, LDA, N, ML, MU, IPVT, INFO)
C***BEGIN PROLOGUE  SGBFA
C***PURPOSE  Factor a band matrix using Gaussian elimination.
C***CATEGORY  D2A2
C***TYPE      SINGLE PRECISION (SGBFA-S, DGBFA-D, CGBFA-C)
C***KEYWORDS  BANDED, LINEAR ALGEBRA, LINPACK, MATRIX FACTORIZATION
C***AUTHOR  Moler, C. B., (U. of New Mexico)
C***DESCRIPTION
C
C     SGBFA factors a real band matrix by elimination.
C
C     SGBFA is usually called by SBGCO, but it can be called
C     directly with a saving in time if  RCOND  is not needed.
C
C     On Entry
C
C        ABD     REAL(LDA, N)
C                contains the matrix in band storage.  The columns
C                of the matrix are stored in the columns of  ABD  and
C                the diagonals of the matrix are stored in rows
C                ML+1 through 2*ML+MU+1 of  ABD .
C                See the comments below for details.
C
C        LDA     INTEGER
C                the leading dimension of the array  ABD .
C                LDA must be .GE. 2*ML + MU + 1 .
C
C        N       INTEGER
C                the order of the original matrix.
C
C        ML      INTEGER
C                number of diagonals below the main diagonal.
C                0 .LE. ML .LT. N .
C
C        MU      INTEGER
C                number of diagonals above the main diagonal.
C                0 .LE. MU .LT. N .
C                More efficient if  ML .LE. MU .
C     On Return
C
C        ABD     an upper triangular matrix in band storage and
C                the multipliers which were used to obtain it.
C                The factorization can be written  A = L*U , where
C                L  is a product of permutation and unit lower
C                triangular matrices and  U  is upper triangular.
C
C        IPVT    INTEGER(N)
C                an integer vector of pivot indices.
C
C        INFO    INTEGER
C                = 0  normal value.
C                = K  if  U(K,K) .EQ. 0.0 .  This is not an error
C                     condition for this subroutine, but it does
C                     indicate that SGBSL will divide by zero if
C                     called.  Use  RCOND  in SBGCO for a reliable
C                     indication of singularity.
C
C     Band Storage
C
C           If  A  is a band matrix, the following program segment
C           will set up the input.
C
C                   ML = (band width below the diagonal)
C                   MU = (band width above the diagonal)
C                   M = ML + MU + 1
C                   DO 20 J = 1, N
C                      I1 = MAX(1, J-MU)
C                      I2 = MIN(N, J+ML)
C                      DO 10 I = I1, I2
C                         K = I - J + M
C                         ABD(K,J) = A(I,J)
C                10    CONTINUE
C                20 CONTINUE
C
C           This uses rows  ML+1  through  2*ML+MU+1  of  ABD .
C           In addition, the first  ML  rows in  ABD  are used for
C           elements generated during the triangularization.
C           The total number of rows needed in  ABD  is  2*ML+MU+1 .
C           The  ML+MU by ML+MU  upper left triangle and the
C           ML by ML  lower right triangle are not referenced.
C
C***REFERENCES  J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W.
C                 Stewart, LINPACK Users' Guide, SIAM, 1979.
C***ROUTINES CALLED  ISAMAX, SAXPY, SSCAL
C***REVISION HISTORY  (YYMMDD)
C   780814  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   890831  Modified array declarations.  (WRB)
C   890831  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900326  Removed duplicate information from DESCRIPTION section.
C           (WRB)
C   920501  Reformatted the REFERENCES section.  (WRB)
C***END PROLOGUE  SGBFA
      INTEGER LDA,N,ML,MU,IPVT(*),INFO
      REAL ABD(LDA,*)
C
      REAL T
      INTEGER I,ISAMAX,I0,J,JU,JZ,J0,J1,K,KP1,L,LM,M,MM,NM1
C
C***FIRST EXECUTABLE STATEMENT  SGBFA
      M = ML + MU + 1
      INFO = 0
C
C     ZERO INITIAL FILL-IN COLUMNS
C
      J0 = MU + 2
      J1 = MIN(N,M) - 1
      IF (J1 .LT. J0) GO TO 30
      DO 20 JZ = J0, J1
         I0 = M + 1 - JZ
         DO 10 I = I0, ML
            ABD(I,JZ) = 0.0E0
   10    CONTINUE
   20 CONTINUE
   30 CONTINUE
      JZ = J1
      JU = 0
C
C     GAUSSIAN ELIMINATION WITH PARTIAL PIVOTING
C
      NM1 = N - 1
      IF (NM1 .LT. 1) GO TO 130
      DO 120 K = 1, NM1
         KP1 = K + 1
C
C        ZERO NEXT FILL-IN COLUMN
C
         JZ = JZ + 1
         IF (JZ .GT. N) GO TO 50
         IF (ML .LT. 1) GO TO 50
            DO 40 I = 1, ML
               ABD(I,JZ) = 0.0E0
   40       CONTINUE
   50    CONTINUE
C
C        FIND L = PIVOT INDEX
C
         LM = MIN(ML,N-K)
         L = ISAMAX(LM+1,ABD(M,K),1) + M - 1
         IPVT(K) = L + K - M
C
C        ZERO PIVOT IMPLIES THIS COLUMN ALREADY TRIANGULARIZED
C
         IF (ABD(L,K) .EQ. 0.0E0) GO TO 100
C
C           INTERCHANGE IF NECESSARY
C
            IF (L .EQ. M) GO TO 60
               T = ABD(L,K)
               ABD(L,K) = ABD(M,K)
               ABD(M,K) = T
   60       CONTINUE
C
C           COMPUTE MULTIPLIERS
C
            T = -1.0E0/ABD(M,K)
            CALL SSCAL(LM,T,ABD(M+1,K),1)
C
C           ROW ELIMINATION WITH COLUMN INDEXING
C
            JU = MIN(MAX(JU,MU+IPVT(K)),N)
            MM = M
            IF (JU .LT. KP1) GO TO 90
            DO 80 J = KP1, JU
               L = L - 1
               MM = MM - 1
               T = ABD(L,J)
               IF (L .EQ. MM) GO TO 70
                  ABD(L,J) = ABD(MM,J)
                  ABD(MM,J) = T
   70          CONTINUE
               CALL SAXPY(LM,T,ABD(M+1,K),1,ABD(MM+1,J),1)
   80       CONTINUE
   90       CONTINUE
         GO TO 110
  100    CONTINUE
            INFO = K
  110    CONTINUE
  120 CONTINUE
  130 CONTINUE
      IPVT(N) = N
      IF (ABD(M,N) .EQ. 0.0E0) INFO = N
      RETURN
      END
*DECK SGBSL
      SUBROUTINE SGBSL (ABD, LDA, N, ML, MU, IPVT, B, JOB)
C***BEGIN PROLOGUE  SGBSL
C***PURPOSE  Solve the real band system A*X=B or TRANS(A)*X=B using
C            the factors computed by SGBCO or SGBFA.
C***CATEGORY  D2A2
C***TYPE      SINGLE PRECISION (SGBSL-S, DGBSL-D, CGBSL-C)
C***KEYWORDS  BANDED, LINEAR ALGEBRA, LINPACK, MATRIX, SOLVE
C***AUTHOR  Moler, C. B., (U. of New Mexico)
C***DESCRIPTION
C
C     SGBSL solves the real band system
C     A * X = B  or  TRANS(A) * X = B
C     using the factors computed by SBGCO or SGBFA.
C
C     On Entry
C
C        ABD     REAL(LDA, N)
C                the output from SBGCO or SGBFA.
C
C        LDA     INTEGER
C                the leading dimension of the array  ABD .
C
C        N       INTEGER
C                the order of the original matrix.
C
C        ML      INTEGER
C                number of diagonals below the main diagonal.
C
C        MU      INTEGER
C                number of diagonals above the main diagonal.
C
C        IPVT    INTEGER(N)
C                the pivot vector from SBGCO or SGBFA.
C
C        B       REAL(N)
C                the right hand side vector.
C
C        JOB     INTEGER
C                = 0         to solve  A*X = B ,
C                = nonzero   to solve  TRANS(A)*X = B , where
C                            TRANS(A)  is the transpose.
C
C     On Return
C
C        B       the solution vector  X .
C
C     Error Condition
C
C        A division by zero will occur if the input factor contains a
C        zero on the diagonal.  Technically, this indicates singularity,
C        but it is often caused by improper arguments or improper
C        setting of LDA .  It will not occur if the subroutines are
C        called correctly and if SBGCO has set RCOND .GT. 0.0
C        or SGBFA has set INFO .EQ. 0 .
C
C     To compute  INVERSE(A) * C  where  C  is a matrix
C     with  P  columns
C           CALL SBGCO(ABD,LDA,N,ML,MU,IPVT,RCOND,Z)
C           If (RCOND is too small) GO TO ...
C           DO 10 J = 1, P
C              CALL SGBSL(ABD,LDA,N,ML,MU,IPVT,C(1,J),0)
C        10 CONTINUE
C
C***REFERENCES  J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W.
C                 Stewart, LINPACK Users' Guide, SIAM, 1979.
C***ROUTINES CALLED  SAXPY, SDOT
C***REVISION HISTORY  (YYMMDD)
C   780814  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   890831  Modified array declarations.  (WRB)
C   890831  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900326  Removed duplicate information from DESCRIPTION section.
C           (WRB)
C   920501  Reformatted the REFERENCES section.  (WRB)
C***END PROLOGUE  SGBSL
      INTEGER LDA,N,ML,MU,IPVT(*),JOB
      REAL ABD(LDA,*),B(*)
C
      REAL SDOT,T
      INTEGER K,KB,L,LA,LB,LM,M,NM1
C***FIRST EXECUTABLE STATEMENT  SGBSL
      M = MU + ML + 1
      NM1 = N - 1
      IF (JOB .NE. 0) GO TO 50
C
C        JOB = 0 , SOLVE  A * X = B
C        FIRST SOLVE L*Y = B
C
         IF (ML .EQ. 0) GO TO 30
         IF (NM1 .LT. 1) GO TO 30
            DO 20 K = 1, NM1
               LM = MIN(ML,N-K)
               L = IPVT(K)
               T = B(L)
               IF (L .EQ. K) GO TO 10
                  B(L) = B(K)
                  B(K) = T
   10          CONTINUE
               CALL SAXPY(LM,T,ABD(M+1,K),1,B(K+1),1)
   20       CONTINUE
   30    CONTINUE
C
C        NOW SOLVE  U*X = Y
C
         DO 40 KB = 1, N
            K = N + 1 - KB
            B(K) = B(K)/ABD(M,K)
            LM = MIN(K,M) - 1
            LA = M - LM
            LB = K - LM
            T = -B(K)
            CALL SAXPY(LM,T,ABD(LA,K),1,B(LB),1)
   40    CONTINUE
      GO TO 100
   50 CONTINUE
C
C        JOB = NONZERO, SOLVE  TRANS(A) * X = B
C        FIRST SOLVE  TRANS(U)*Y = B
C
         DO 60 K = 1, N
            LM = MIN(K,M) - 1
            LA = M - LM
            LB = K - LM
            T = SDOT(LM,ABD(LA,K),1,B(LB),1)
            B(K) = (B(K) - T)/ABD(M,K)
   60    CONTINUE
C
C        NOW SOLVE TRANS(L)*X = Y
C
         IF (ML .EQ. 0) GO TO 90
         IF (NM1 .LT. 1) GO TO 90
            DO 80 KB = 1, NM1
               K = N - KB
               LM = MIN(ML,N-K)
               B(K) = B(K) + SDOT(LM,ABD(M+1,K),1,B(K+1),1)
               L = IPVT(K)
               IF (L .EQ. K) GO TO 70
                  T = B(L)
                  B(L) = B(K)
                  B(K) = T
   70          CONTINUE
   80       CONTINUE
   90    CONTINUE
  100 CONTINUE
      RETURN
      END
*DECK SAXPY
      SUBROUTINE SAXPY (N, SA, SX, INCX, SY, INCY)
C***BEGIN PROLOGUE  SAXPY
C***PURPOSE  Compute a constant times a vector plus a vector.
C***CATEGORY  D1A7
C***TYPE      SINGLE PRECISION (SAXPY-S, DAXPY-D, CAXPY-C)
C***KEYWORDS  BLAS, LINEAR ALGEBRA, TRIAD, VECTOR
C***AUTHOR  Lawson, C. L., (JPL)
C           Hanson, R. J., (SNLA)
C           Kincaid, D. R., (U. of Texas)
C           Krogh, F. T., (JPL)
C***DESCRIPTION
C
C                B L A S  Subprogram
C    Description of Parameters
C
C     --Input--
C        N  number of elements in input vector(s)
C       SA  single precision scalar multiplier
C       SX  single precision vector with N elements
C     INCX  storage spacing between elements of SX
C       SY  single precision vector with N elements
C     INCY  storage spacing between elements of SY
C
C     --Output--
C       SY  single precision result (unchanged if N .LE. 0)
C
C     Overwrite single precision SY with single precision SA*SX +SY.
C     For I = 0 to N-1, replace  SY(LY+I*INCY) with SA*SX(LX+I*INCX) +
C       SY(LY+I*INCY),
C     where LX = 1 if INCX .GE. 0, else LX = 1+(1-N)*INCX, and LY is
C     defined in a similar way using INCY.
C
C***REFERENCES  C. L. Lawson, R. J. Hanson, D. R. Kincaid and F. T.
C                 Krogh, Basic linear algebra subprograms for Fortran
C                 usage, Algorithm No. 539, Transactions on Mathematical
C                 Software 5, 3 (September 1979), pp. 308-323.
C***ROUTINES CALLED  (NONE)
C***REVISION HISTORY  (YYMMDD)
C   791001  DATE WRITTEN
C   890831  Modified array declarations.  (WRB)
C   890831  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   920310  Corrected definition of LX in DESCRIPTION.  (WRB)
C   920501  Reformatted the REFERENCES section.  (WRB)
C***END PROLOGUE  SAXPY
      REAL SX(*), SY(*), SA
C***FIRST EXECUTABLE STATEMENT  SAXPY
      IF (N.LE.0 .OR. SA.EQ.0.0E0) RETURN
      IF (INCX .EQ. INCY) IF (INCX-1) 5,20,60
C
C     Code for unequal or nonpositive increments.
C
    5 IX = 1
      IY = 1
      IF (INCX .LT. 0) IX = (-N+1)*INCX + 1
      IF (INCY .LT. 0) IY = (-N+1)*INCY + 1
      DO 10 I = 1,N
        SY(IY) = SY(IY) + SA*SX(IX)
        IX = IX + INCX
        IY = IY + INCY
   10 CONTINUE
      RETURN
C
C     Code for both increments equal to 1.
C
C     Clean-up loop so remaining vector length is a multiple of 4.
C
   20 M = MOD(N,4)
      IF (M .EQ. 0) GO TO 40
      DO 30 I = 1,M
        SY(I) = SY(I) + SA*SX(I)
   30 CONTINUE
      IF (N .LT. 4) RETURN
   40 MP1 = M + 1
      DO 50 I = MP1,N,4
        SY(I) = SY(I) + SA*SX(I)
        SY(I+1) = SY(I+1) + SA*SX(I+1)
        SY(I+2) = SY(I+2) + SA*SX(I+2)
        SY(I+3) = SY(I+3) + SA*SX(I+3)
   50 CONTINUE
      RETURN
C
C     Code for equal, positive, non-unit increments.
C
   60 NS = N*INCX
      DO 70 I = 1,NS,INCX
        SY(I) = SA*SX(I) + SY(I)
   70 CONTINUE
      RETURN
      END
*DECK SCOPY
      SUBROUTINE SCOPY (N, SX, INCX, SY, INCY)
C***BEGIN PROLOGUE  SCOPY
C***PURPOSE  Copy a vector.
C***CATEGORY  D1A5
C***TYPE      SINGLE PRECISION (SCOPY-S, DCOPY-D, CCOPY-C, ICOPY-I)
C***KEYWORDS  BLAS, COPY, LINEAR ALGEBRA, VECTOR
C***AUTHOR  Lawson, C. L., (JPL)
C           Hanson, R. J., (SNLA)
C           Kincaid, D. R., (U. of Texas)
C           Krogh, F. T., (JPL)
C***DESCRIPTION
C
C                B L A S  Subprogram
C    Description of Parameters
C
C     --Input--
C        N  number of elements in input vector(s)
C       SX  single precision vector with N elements
C     INCX  storage spacing between elements of SX
C       SY  single precision vector with N elements
C     INCY  storage spacing between elements of SY
C
C     --Output--
C       SY  copy of vector SX (unchanged if N .LE. 0)
C
C     Copy single precision SX to single precision SY.
C     For I = 0 to N-1, copy  SX(LX+I*INCX) to SY(LY+I*INCY),
C     where LX = 1 if INCX .GE. 0, else LX = 1+(1-N)*INCX, and LY is
C     defined in a similar way using INCY.
C
C***REFERENCES  C. L. Lawson, R. J. Hanson, D. R. Kincaid and F. T.
C                 Krogh, Basic linear algebra subprograms for Fortran
C                 usage, Algorithm No. 539, Transactions on Mathematical
C                 Software 5, 3 (September 1979), pp. 308-323.
C***ROUTINES CALLED  (NONE)
C***REVISION HISTORY  (YYMMDD)
C   791001  DATE WRITTEN
C   890831  Modified array declarations.  (WRB)
C   890831  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   920310  Corrected definition of LX in DESCRIPTION.  (WRB)
C   920501  Reformatted the REFERENCES section.  (WRB)
C***END PROLOGUE  SCOPY
      REAL SX(*), SY(*)
C***FIRST EXECUTABLE STATEMENT  SCOPY
      IF (N .LE. 0) RETURN
      IF (INCX .EQ. INCY) IF (INCX-1) 5,20,60
C
C     Code for unequal or nonpositive increments.
C
    5 IX = 1
      IY = 1
      IF (INCX .LT. 0) IX = (-N+1)*INCX + 1
      IF (INCY .LT. 0) IY = (-N+1)*INCY + 1
      DO 10 I = 1,N
        SY(IY) = SX(IX)
        IX = IX + INCX
        IY = IY + INCY
   10 CONTINUE
      RETURN
C
C     Code for both increments equal to 1.
C
C     Clean-up loop so remaining vector length is a multiple of 7.
C
   20 M = MOD(N,7)
      IF (M .EQ. 0) GO TO 40
      DO 30 I = 1,M
        SY(I) = SX(I)
   30 CONTINUE
      IF (N .LT. 7) RETURN
   40 MP1 = M + 1
      DO 50 I = MP1,N,7
        SY(I) = SX(I)
        SY(I+1) = SX(I+1)
        SY(I+2) = SX(I+2)
        SY(I+3) = SX(I+3)
        SY(I+4) = SX(I+4)
        SY(I+5) = SX(I+5)
        SY(I+6) = SX(I+6)
   50 CONTINUE
      RETURN
C
C     Code for equal, positive, non-unit increments.
C
   60 NS = N*INCX
      DO 70 I = 1,NS,INCX
        SY(I) = SX(I)
   70 CONTINUE
      RETURN
      END
*DECK SDOT
      REAL FUNCTION SDOT (N, SX, INCX, SY, INCY)
C***BEGIN PROLOGUE  SDOT
C***PURPOSE  Compute the inner product of two vectors.
C***CATEGORY  D1A4
C***TYPE      SINGLE PRECISION (SDOT-S, DDOT-D, CDOTU-C)
C***KEYWORDS  BLAS, INNER PRODUCT, LINEAR ALGEBRA, VECTOR
C***AUTHOR  Lawson, C. L., (JPL)
C           Hanson, R. J., (SNLA)
C           Kincaid, D. R., (U. of Texas)
C           Krogh, F. T., (JPL)
C***DESCRIPTION
C
C                B L A S  Subprogram
C    Description of Parameters
C
C     --Input--
C        N  number of elements in input vector(s)
C       SX  single precision vector with N elements
C     INCX  storage spacing between elements of SX
C       SY  single precision vector with N elements
C     INCY  storage spacing between elements of SY
C
C     --Output--
C     SDOT  single precision dot product (zero if N .LE. 0)
C
C     Returns the dot product of single precision SX and SY.
C     SDOT = sum for I = 0 to N-1 of  SX(LX+I*INCX) * SY(LY+I*INCY),
C     where LX = 1 if INCX .GE. 0, else LX = 1+(1-N)*INCX, and LY is
C     defined in a similar way using INCY.
C
C***REFERENCES  C. L. Lawson, R. J. Hanson, D. R. Kincaid and F. T.
C                 Krogh, Basic linear algebra subprograms for Fortran
C                 usage, Algorithm No. 539, Transactions on Mathematical
C                 Software 5, 3 (September 1979), pp. 308-323.
C***ROUTINES CALLED  (NONE)
C***REVISION HISTORY  (YYMMDD)
C   791001  DATE WRITTEN
C   890831  Modified array declarations.  (WRB)
C   890831  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   920310  Corrected definition of LX in DESCRIPTION.  (WRB)
C   920501  Reformatted the REFERENCES section.  (WRB)
C***END PROLOGUE  SDOT
      REAL SX(*), SY(*)
C***FIRST EXECUTABLE STATEMENT  SDOT
      SDOT = 0.0E0
      IF (N .LE. 0) RETURN
      IF (INCX .EQ. INCY) IF (INCX-1) 5,20,60
C
C     Code for unequal or nonpositive increments.
C
    5 IX = 1
      IY = 1
      IF (INCX .LT. 0) IX = (-N+1)*INCX + 1
      IF (INCY .LT. 0) IY = (-N+1)*INCY + 1
      DO 10 I = 1,N
        SDOT = SDOT + SX(IX)*SY(IY)
        IX = IX + INCX
        IY = IY + INCY
   10 CONTINUE
      RETURN
C
C     Code for both increments equal to 1.
C
C     Clean-up loop so remaining vector length is a multiple of 5.
C
   20 M = MOD(N,5)
      IF (M .EQ. 0) GO TO 40
      DO 30 I = 1,M
        SDOT = SDOT + SX(I)*SY(I)
   30 CONTINUE
      IF (N .LT. 5) RETURN
   40 MP1 = M + 1
      DO 50 I = MP1,N,5
      SDOT = SDOT + SX(I)*SY(I) + SX(I+1)*SY(I+1) + SX(I+2)*SY(I+2) +
     1              SX(I+3)*SY(I+3) + SX(I+4)*SY(I+4)
   50 CONTINUE
      RETURN
C
C     Code for equal, positive, non-unit increments.
C
   60 NS = N*INCX
      DO 70 I = 1,NS,INCX
        SDOT = SDOT + SX(I)*SY(I)
   70 CONTINUE
      RETURN
      END
*DECK SNRM2
      REAL FUNCTION SNRM2 (N, SX, INCX)
C***BEGIN PROLOGUE  SNRM2
C***PURPOSE  Compute the Euclidean length (L2 norm) of a vector.
C***CATEGORY  D1A3B
C***TYPE      SINGLE PRECISION (SNRM2-S, DNRM2-D, SCNRM2-C)
C***KEYWORDS  BLAS, EUCLIDEAN LENGTH, EUCLIDEAN NORM, L2,
C             LINEAR ALGEBRA, UNITARY, VECTOR
C***AUTHOR  Lawson, C. L., (JPL)
C           Hanson, R. J., (SNLA)
C           Kincaid, D. R., (U. of Texas)
C           Krogh, F. T., (JPL)
C***DESCRIPTION
C
C                B L A S  Subprogram
C    Description of Parameters
C
C     --Input--
C        N  number of elements in input vector(s)
C       SX  single precision vector with N elements
C     INCX  storage spacing between elements of SX
C
C     --Output--
C    SNRM2  single precision result (zero if N .LE. 0)
C
C     Euclidean norm of the N-vector stored in SX with storage
C     increment INCX .
C     If N .LE. 0, return with result = 0.
C     If N .GE. 1, then INCX must be .GE. 1
C
C     Four Phase Method using two built-in constants that are
C     hopefully applicable to all machines.
C         CUTLO = maximum of  SQRT(U/EPS)  over all known machines.
C         CUTHI = minimum of  SQRT(V)      over all known machines.
C     where
C         EPS = smallest no. such that EPS + 1. .GT. 1.
C         U   = smallest positive no.   (underflow limit)
C         V   = largest  no.            (overflow  limit)
C
C     Brief Outline of Algorithm.
C
C     Phase 1 scans zero components.
C     Move to phase 2 when a component is nonzero and .LE. CUTLO
C     Move to phase 3 when a component is .GT. CUTLO
C     Move to phase 4 when a component is .GE. CUTHI/M
C     where M = N for X() real and M = 2*N for complex.
C
C     Values for CUTLO and CUTHI.
C     From the environmental parameters listed in the IMSL converter
C     document the limiting values are as follows:
C     CUTLO, S.P.   U/EPS = 2**(-102) for  Honeywell.  Close seconds are
C                   Univac and DEC at 2**(-103)
C                   Thus CUTLO = 2**(-51) = 4.44089E-16
C     CUTHI, S.P.   V = 2**127 for Univac, Honeywell, and DEC.
C                   Thus CUTHI = 2**(63.5) = 1.30438E19
C     CUTLO, D.P.   U/EPS = 2**(-67) for Honeywell and DEC.
C                   Thus CUTLO = 2**(-33.5) = 8.23181D-11
C     CUTHI, D.P.   same as S.P.  CUTHI = 1.30438D19
C     DATA CUTLO, CUTHI /8.232D-11,  1.304D19/
C     DATA CUTLO, CUTHI /4.441E-16,  1.304E19/
C
C***REFERENCES  C. L. Lawson, R. J. Hanson, D. R. Kincaid and F. T.
C                 Krogh, Basic linear algebra subprograms for Fortran
C                 usage, Algorithm No. 539, Transactions on Mathematical
C                 Software 5, 3 (September 1979), pp. 308-323.
C***ROUTINES CALLED  (NONE)
C***REVISION HISTORY  (YYMMDD)
C   791001  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   890831  Modified array declarations.  (WRB)
C   890831  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   920501  Reformatted the REFERENCES section.  (WRB)
C***END PROLOGUE  SNRM2
      INTEGER NEXT
      REAL SX(*), CUTLO, CUTHI, HITEST, SUM, XMAX, ZERO, ONE
      SAVE CUTLO, CUTHI, ZERO, ONE
      DATA ZERO, ONE /0.0E0, 1.0E0/
C
      DATA CUTLO, CUTHI /4.441E-16,  1.304E19/
C***FIRST EXECUTABLE STATEMENT  SNRM2
      IF (N .GT. 0) GO TO 10
         SNRM2  = ZERO
         GO TO 300
C
   10 ASSIGN 30 TO NEXT
      SUM = ZERO
      NN = N * INCX
C
C                                                 BEGIN MAIN LOOP
C
      I = 1
   20    GO TO NEXT,(30, 50, 70, 110)
   30 IF (ABS(SX(I)) .GT. CUTLO) GO TO 85
      ASSIGN 50 TO NEXT
      XMAX = ZERO
C
C                        PHASE 1.  SUM IS ZERO
C
   50 IF (SX(I) .EQ. ZERO) GO TO 200
      IF (ABS(SX(I)) .GT. CUTLO) GO TO 85
C
C                                PREPARE FOR PHASE 2.
C
      ASSIGN 70 TO NEXT
      GO TO 105
C
C                                PREPARE FOR PHASE 4.
C
  100 I = J
      ASSIGN 110 TO NEXT
      SUM = (SUM / SX(I)) / SX(I)
  105 XMAX = ABS(SX(I))
      GO TO 115
C
C                   PHASE 2.  SUM IS SMALL.
C                             SCALE TO AVOID DESTRUCTIVE UNDERFLOW.
C
   70 IF (ABS(SX(I)) .GT. CUTLO) GO TO 75
C
C                     COMMON CODE FOR PHASES 2 AND 4.
C                     IN PHASE 4 SUM IS LARGE.  SCALE TO AVOID OVERFLOW.
C
  110 IF (ABS(SX(I)) .LE. XMAX) GO TO 115
         SUM = ONE + SUM * (XMAX / SX(I))**2
         XMAX = ABS(SX(I))
         GO TO 200
C
  115 SUM = SUM + (SX(I)/XMAX)**2
      GO TO 200
C
C                  PREPARE FOR PHASE 3.
C
   75 SUM = (SUM * XMAX) * XMAX
C
C     FOR REAL OR D.P. SET HITEST = CUTHI/N
C     FOR COMPLEX      SET HITEST = CUTHI/(2*N)
C
   85 HITEST = CUTHI / N
C
C                   PHASE 3.  SUM IS MID-RANGE.  NO SCALING.
C
      DO 95 J = I,NN,INCX
      IF (ABS(SX(J)) .GE. HITEST) GO TO 100
   95    SUM = SUM + SX(J)**2
      SNRM2 = SQRT( SUM )
      GO TO 300
C
  200 CONTINUE
      I = I + INCX
      IF (I .LE. NN) GO TO 20
C
C              END OF MAIN LOOP.
C
C              COMPUTE SQUARE ROOT AND ADJUST FOR SCALING.
C
      SNRM2 = XMAX * SQRT(SUM)
  300 CONTINUE
      RETURN
      END
*DECK SSCAL
      SUBROUTINE SSCAL (N, SA, SX, INCX)
C***BEGIN PROLOGUE  SSCAL
C***PURPOSE  Multiply a vector by a constant.
C***CATEGORY  D1A6
C***TYPE      SINGLE PRECISION (SSCAL-S, DSCAL-D, CSCAL-C)
C***KEYWORDS  BLAS, LINEAR ALGEBRA, SCALE, VECTOR
C***AUTHOR  Lawson, C. L., (JPL)
C           Hanson, R. J., (SNLA)
C           Kincaid, D. R., (U. of Texas)
C           Krogh, F. T., (JPL)
C***DESCRIPTION
C
C                B L A S  Subprogram
C    Description of Parameters
C
C     --Input--
C        N  number of elements in input vector(s)
C       SA  single precision scale factor
C       SX  single precision vector with N elements
C     INCX  storage spacing between elements of SX
C
C     --Output--
C       SX  single precision result (unchanged if N .LE. 0)
C
C     Replace single precision SX by single precision SA*SX.
C     For I = 0 to N-1, replace SX(IX+I*INCX) with  SA * SX(IX+I*INCX),
C     where IX = 1 if INCX .GE. 0, else IX = 1+(1-N)*INCX.
C
C***REFERENCES  C. L. Lawson, R. J. Hanson, D. R. Kincaid and F. T.
C                 Krogh, Basic linear algebra subprograms for Fortran
C                 usage, Algorithm No. 539, Transactions on Mathematical
C                 Software 5, 3 (September 1979), pp. 308-323.
C***ROUTINES CALLED  (NONE)
C***REVISION HISTORY  (YYMMDD)
C   791001  DATE WRITTEN
C   890831  Modified array declarations.  (WRB)
C   890831  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900821  Modified to correct problem with a negative increment.
C           (WRB)
C   920501  Reformatted the REFERENCES section.  (WRB)
C***END PROLOGUE  SSCAL
      REAL SA, SX(*)
      INTEGER I, INCX, IX, M, MP1, N
C***FIRST EXECUTABLE STATEMENT  SSCAL
      IF (N .LE. 0) RETURN
      IF (INCX .EQ. 1) GOTO 20
C
C     Code for increment not equal to 1.
C
      IX = 1
      IF (INCX .LT. 0) IX = (-N+1)*INCX + 1
      DO 10 I = 1,N
        SX(IX) = SA*SX(IX)
        IX = IX + INCX
   10 CONTINUE
      RETURN
C
C     Code for increment equal to 1.
C
C     Clean-up loop so remaining vector length is a multiple of 5.
C
   20 M = MOD(N,5)
      IF (M .EQ. 0) GOTO 40
      DO 30 I = 1,M
        SX(I) = SA*SX(I)
   30 CONTINUE
      IF (N .LT. 5) RETURN
   40 MP1 = M + 1
      DO 50 I = MP1,N,5
        SX(I) = SA*SX(I)
        SX(I+1) = SA*SX(I+1)
        SX(I+2) = SA*SX(I+2)
        SX(I+3) = SA*SX(I+3)
        SX(I+4) = SA*SX(I+4)
   50 CONTINUE
      RETURN
      END
*DECK ISAMAX
      INTEGER FUNCTION ISAMAX (N, SX, INCX)
C***BEGIN PROLOGUE  ISAMAX
C***PURPOSE  Find the smallest index of that component of a vector
C            having the maximum magnitude.
C***CATEGORY  D1A2
C***TYPE      SINGLE PRECISION (ISAMAX-S, IDAMAX-D, ICAMAX-C)
C***KEYWORDS  BLAS, LINEAR ALGEBRA, MAXIMUM COMPONENT, VECTOR
C***AUTHOR  Lawson, C. L., (JPL)
C           Hanson, R. J., (SNLA)
C           Kincaid, D. R., (U. of Texas)
C           Krogh, F. T., (JPL)
C***DESCRIPTION
C
C                B L A S  Subprogram
C    Description of Parameters
C
C     --Input--
C        N  number of elements in input vector(s)
C       SX  single precision vector with N elements
C     INCX  storage spacing between elements of SX
C
C     --Output--
C   ISAMAX  smallest index (zero if N .LE. 0)
C
C     Find smallest index of maximum magnitude of single precision SX.
C     ISAMAX = first I, I = 1 to N, to maximize  ABS(SX(IX+(I-1)*INCX)),
C     where IX = 1 if INCX .GE. 0, else IX = 1+(1-N)*INCX.
C
C***REFERENCES  C. L. Lawson, R. J. Hanson, D. R. Kincaid and F. T.
C                 Krogh, Basic linear algebra subprograms for Fortran
C                 usage, Algorithm No. 539, Transactions on Mathematical
C                 Software 5, 3 (September 1979), pp. 308-323.
C***ROUTINES CALLED  (NONE)
C***REVISION HISTORY  (YYMMDD)
C   791001  DATE WRITTEN
C   861211  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900821  Modified to correct problem with a negative increment.
C           (WRB)
C   920501  Reformatted the REFERENCES section.  (WRB)
C   920618  Slight restructuring of code.  (RWC, WRB)
C***END PROLOGUE  ISAMAX
      REAL SX(*), SMAX, XMAG
      INTEGER I, INCX, IX, N
C***FIRST EXECUTABLE STATEMENT  ISAMAX
      ISAMAX = 0
      IF (N .LE. 0) RETURN
      ISAMAX = 1
      IF (N .EQ. 1) RETURN
C
      IF (INCX .EQ. 1) GOTO 20
C
C     Code for increment not equal to 1.
C
      IX = 1
      IF (INCX .LT. 0) IX = (-N+1)*INCX + 1
      SMAX = ABS(SX(IX))
      IX = IX + INCX
      DO 10 I = 2,N
        XMAG = ABS(SX(IX))
        IF (XMAG .GT. SMAX) THEN
          ISAMAX = I
          SMAX = XMAG
        ENDIF
        IX = IX + INCX
   10 CONTINUE
      RETURN
C
C     Code for increments equal to 1.
C
   20 SMAX = ABS(SX(1))
      DO 30 I = 2,N
        XMAG = ABS(SX(I))
        IF (XMAG .GT. SMAX) THEN
          ISAMAX = I
          SMAX = XMAG
        ENDIF
   30 CONTINUE
      RETURN
      END
*DECK XERRWV
      SUBROUTINE XERRWV (MSG, NMES, NERR, LEVEL, NI, I1, I2, NR, R1, R2)
C***BEGIN PROLOGUE  XERRWV
C***SUBSIDIARY
C***PURPOSE  Write error message with values.
C***CATEGORY  R3C
C***TYPE      SINGLE PRECISION (XERRWV-S, XERRWD-D)
C***AUTHOR  Hindmarsh, Alan C., (LLNL)
C***DESCRIPTION
C
C  Subroutines XERRWV, XSETF, XSETUN, and the function routine IXSAV,
C  as given here, constitute a simplified version of the SLATEC error
C  handling package.
C
C  All arguments are input arguments.
C
C  MSG    = The message (character array).
C  NMES   = The length of MSG (number of characters).
C  NERR   = The error number (not used).
C  LEVEL  = The error level..
C           0 or 1 means recoverable (control returns to caller).
C           2 means fatal (run is aborted--see note below).
C  NI     = Number of integers (0, 1, or 2) to be printed with message.
C  I1,I2  = Integers to be printed, depending on NI.
C  NR     = Number of reals (0, 1, or 2) to be printed with message.
C  R1,R2  = Reals to be printed, depending on NR.
C
C  Note..  this routine is machine-dependent and specialized for use
C  in limited context, in the following ways..
C  1. The argument MSG is assumed to be of type CHARACTER, and
C     the message is printed with a format of (1X,A).
C  2. The message is assumed to take only one line.
C     Multi-line messages are generated by repeated calls.
C  3. If LEVEL = 2, control passes to the statement   STOP
C     to abort the run.  This statement may be machine-dependent.
C  4. R1 and R2 are assumed to be in single precision and are printed
C     in E21.13 format.
C
C***ROUTINES CALLED  IXSAV
C***REVISION HISTORY  (YYMMDD)
C   791129  DATE WRITTEN
C   890413  Heavily revised, with Common eliminated. (ACH, PNB)
C   921118  Replaced MFLGSV/LUNSAV by IXSAV. (ACH)
C   930329  Modified prologue to SLATEC format. (FNF)
C   930407  Changed MSG from CHARACTER*1 array to variable. (FNF)
C   930922  Minor cosmetic change. (FNF)
C***END PROLOGUE  XERRWV
C
C*Internal Notes:
C
C For a different default logical unit number, IXSAV (or a subsidiary
C routine that it calls) will need to be modified.
C For a different run-abort command, change the statement following
C statement 100 at the end.
C-----------------------------------------------------------------------
C Subroutines called by XERRWV.. None
C Function routine called by XERRWV.. IXSAV
C-----------------------------------------------------------------------
C**End
C
C  Declare arguments.
C
      REAL R1, R2
      INTEGER NMES, NERR, LEVEL, NI, I1, I2, NR
      CHARACTER*(*) MSG
C
C  Declare local variables.
C
      INTEGER LUNIT, IXSAV, MESFLG
C
C  Get logical unit number and message print flag.
C
C***FIRST EXECUTABLE STATEMENT  XERRWV
      LUNIT = IXSAV (1, 0, .FALSE.)
      MESFLG = IXSAV (2, 0, .FALSE.)
      IF (MESFLG .EQ. 0) GO TO 100
C
C  Write the message.
C
      WRITE (LUNIT,10)  MSG
 10   FORMAT(1X,A)
      IF (NI .EQ. 1) WRITE (LUNIT, 20) I1
 20   FORMAT(6X,'In above message,  I1 =',I10)
      IF (NI .EQ. 2) WRITE (LUNIT, 30) I1,I2
 30   FORMAT(6X,'In above message,  I1 =',I10,3X,'I2 =',I10)
      IF (NR .EQ. 1) WRITE (LUNIT, 40) R1
 40   FORMAT(6X,'In above message,  R1 =',E21.13)
      IF (NR .EQ. 2) WRITE (LUNIT, 50) R1,R2
 50   FORMAT(6X,'In above,  R1 =',E21.13,3X,'R2 =',E21.13)
C
C  Abort the run if LEVEL = 2.
C
 100  IF (LEVEL .NE. 2) RETURN
      STOP
C----------------------- End of Subroutine XERRWV ----------------------
      END
*DECK XSETF
      SUBROUTINE XSETF (MFLAG)
C***BEGIN PROLOGUE  XSETF
C***PURPOSE  Reset the error print control flag.
C***CATEGORY  R3A
C***TYPE      ALL (XSETF-A)
C***KEYWORDS  ERROR CONTROL
C***AUTHOR  Hindmarsh, Alan C., (LLNL)
C***DESCRIPTION
C
C   XSETF sets the error print control flag to MFLAG:
C      MFLAG=1 means print all messages (the default).
C      MFLAG=0 means no printing.
C
C***SEE ALSO  XERRWD, XERRWV
C***REFERENCES  (NONE)
C***ROUTINES CALLED  IXSAV
C***REVISION HISTORY  (YYMMDD)
C   921118  DATE WRITTEN
C   930329  Added SLATEC format prologue. (FNF)
C   930407  Corrected SEE ALSO section. (FNF)
C   930922  Made user-callable, and other cosmetic changes. (FNF)
C***END PROLOGUE  XSETF
C
C Subroutines called by XSETF.. None
C Function routine called by XSETF.. IXSAV
C-----------------------------------------------------------------------
C**End
      INTEGER MFLAG, JUNK, IXSAV
C
C***FIRST EXECUTABLE STATEMENT  XSETF
      IF (MFLAG .EQ. 0 .OR. MFLAG .EQ. 1) JUNK = IXSAV (2,MFLAG,.TRUE.)
      RETURN
C----------------------- End of Subroutine XSETF -----------------------
      END
*DECK XSETUN
      SUBROUTINE XSETUN (LUN)
C***BEGIN PROLOGUE  XSETUN
C***PURPOSE  Reset the logical unit number for error messages.
C***CATEGORY  R3B
C***TYPE      ALL (XSETUN-A)
C***KEYWORDS  ERROR CONTROL
C***DESCRIPTION
C
C   XSETUN sets the logical unit number for error messages to LUN.
C
C***AUTHOR  Hindmarsh, Alan C., (LLNL)
C***SEE ALSO  XERRWD, XERRWV
C***REFERENCES  (NONE)
C***ROUTINES CALLED  IXSAV
C***REVISION HISTORY  (YYMMDD)
C   921118  DATE WRITTEN
C   930329  Added SLATEC format prologue. (FNF)
C   930407  Corrected SEE ALSO section. (FNF)
C   930922  Made user-callable, and other cosmetic changes. (FNF)
C***END PROLOGUE  XSETUN
C
C Subroutines called by XSETUN.. None
C Function routine called by XSETUN.. IXSAV
C-----------------------------------------------------------------------
C**End
      INTEGER LUN, JUNK, IXSAV
C
C***FIRST EXECUTABLE STATEMENT  XSETUN
      IF (LUN .GT. 0) JUNK = IXSAV (1,LUN,.TRUE.)
      RETURN
C----------------------- End of Subroutine XSETUN ----------------------
      END
*DECK IXSAV
      INTEGER FUNCTION IXSAV (IPAR, IVALUE, ISET)
C***BEGIN PROLOGUE  IXSAV
C***SUBSIDIARY
C***PURPOSE  Save and recall error message control parameters.
C***CATEGORY  R3C
C***TYPE      ALL (IXSAV-A)
C***AUTHOR  Hindmarsh, Alan C., (LLNL)
C***DESCRIPTION
C
C  IXSAV saves and recalls one of two error message parameters:
C    LUNIT, the logical unit number to which messages are printed, and
C    MESFLG, the message print flag.
C  This is a modification of the SLATEC library routine J4SAVE.
C
C  Saved local variables..
C   LUNIT  = Logical unit number for messages.  The default is obtained
C            by a call to IUMACH (may be machine-dependent).
C   MESFLG = Print control flag..
C            1 means print all messages (the default).
C            0 means no printing.
C
C  On input..
C    IPAR   = Parameter indicator (1 for LUNIT, 2 for MESFLG).
C    IVALUE = The value to be set for the parameter, if ISET = .TRUE.
C    ISET   = Logical flag to indicate whether to read or write.
C             If ISET = .TRUE., the parameter will be given
C             the value IVALUE.  If ISET = .FALSE., the parameter
C             will be unchanged, and IVALUE is a dummy argument.
C
C  On return..
C    IXSAV = The (old) value of the parameter.
C
C***SEE ALSO  XERRWD, XERRWV
C***ROUTINES CALLED  IUMACH
C***REVISION HISTORY  (YYMMDD)
C   921118  DATE WRITTEN
C   930329  Modified prologue to SLATEC format. (FNF)
C   930915  Added IUMACH call to get default output unit.  (ACH)
C   930922  Minor cosmetic changes. (FNF)
C   010425  Type declaration for IUMACH added. (ACH)
C***END PROLOGUE  IXSAV
C
C Subroutines called by IXSAV.. None
C Function routine called by IXSAV.. IUMACH
C-----------------------------------------------------------------------
C**End
      LOGICAL ISET
      INTEGER IPAR, IVALUE
C-----------------------------------------------------------------------
      INTEGER IUMACH, LUNIT, MESFLG
C-----------------------------------------------------------------------
C The following Fortran-77 declaration is to cause the values of the
C listed (local) variables to be saved between calls to this routine.
C-----------------------------------------------------------------------
      SAVE LUNIT, MESFLG
      DATA LUNIT/-1/, MESFLG/1/
C
C***FIRST EXECUTABLE STATEMENT  IXSAV
      IF (IPAR .EQ. 1) THEN
        IF (LUNIT .EQ. -1) LUNIT = IUMACH()
        IXSAV = LUNIT
        IF (ISET) LUNIT = IVALUE
        ENDIF
C
      IF (IPAR .EQ. 2) THEN
        IXSAV = MESFLG
        IF (ISET) MESFLG = IVALUE
        ENDIF
C
      RETURN
C----------------------- End of Function IXSAV -------------------------
      END
*DECK IUMACH
      INTEGER FUNCTION IUMACH()
C***BEGIN PROLOGUE  IUMACH
C***PURPOSE  Provide standard output unit number.
C***CATEGORY  R1
C***TYPE      INTEGER (IUMACH-I)
C***KEYWORDS  MACHINE CONSTANTS
C***AUTHOR  Hindmarsh, Alan C., (LLNL)
C***DESCRIPTION
C *Usage:
C        INTEGER  LOUT, IUMACH
C        LOUT = IUMACH()
C
C *Function Return Values:
C     LOUT : the standard logical unit for Fortran output.
C
C***REFERENCES  (NONE)
C***ROUTINES CALLED  (NONE)
C***REVISION HISTORY  (YYMMDD)
C   930915  DATE WRITTEN
C   930922  Made user-callable, and other cosmetic changes. (FNF)
C***END PROLOGUE  IUMACH
C
C*Internal Notes:
C  The built-in value of 6 is standard on a wide range of Fortran
C  systems.  This may be machine-dependent.
C**End
C***FIRST EXECUTABLE STATEMENT  IUMACH
      IUMACH = 6
C
      RETURN
C----------------------- End of Function IUMACH ------------------------
      END