SUBROUTINE BandWidth
   USE PrecTypes
   USE GlobalData
   IMPLICIT NONE
   ! -------------------------------------------------------------------------
   ! NAME:   BandWidth
   ! PARENT: Feritas
   ! STATUS: Current
   ! OWNER:  Toshiro Matsumoto
   ! TEXT:   Upper and lower band widths of the coefficient matrices of the
   !         system of algebraic equations obtained before applying the
   !         boundary conditions are calculated.
   ! REVISION DATE: 16-Jul-2009
   ! -------------------------------------------------------------------------

   INTEGER :: i, j, k, l, n
   INTEGER :: kmin, kmax
   INTEGER :: wmax, wmin, width

   wmax = 0

   DO i=1,node   ! Count the nodes
      kmin = dir * i
      kmax = 0
      DO j=1,ne   ! Count the element numbers

         ! Repeat for the number of nodes defining the element
         LOOP:DO k=1,etype(j)
            !  When the current node belongs to one of the nodes defining the current element
            IF(i==elm(j,k)) THEN
               DO l=1,etype(j)
                  n = elm(j,l)
                  IF(kmin > dir*(n-1)+1)  kmin = dir*(n-1) + 1
                  IF(kmax < dir*n)        kmax = dir*n
               END DO
               EXIT LOOP
            END IF
         END DO LOOP

      END DO

      width = kmax - kmin + 1

      IF(i==1) wmin = width
      IF(wmin < width) wmin = width
      IF(wmax > width) wmax = width

   END DO

   RETURN
   END SUBROUTINE BandWidth


! sample compile command to generate *.o object file:
!      gfortran -fopenmp -c Fig_10.1_parClaw.f90

program main
   use omp_lib

   interface
     !  initialization function
      subroutine initMats(N, A, T)
         integer :: N
         real, dimension(:,:), allocatable :: A, T
      end subroutine
     !  transform function
      subroutine transform(N, id, Nthrds, A, T)
         integer :: N, id, Nthrds
         real, dimension(:,:), allocatable :: A, T
      end subroutine
   end interface

   real :: trace = 0
   integer :: i, id, N, Nthrds
   real, dimension(:,:), allocatable :: A, T

   integer :: narg     ! number of Arg
   character(len=10) :: name ! Arg name

   narg = command_argument_count()
   if (narg == 1) then
      call get_command_argument(1,name)
      read(name,*) N
   else
       N = 10
   endif
   print *, "N=", N

   ! allocate space for three N x N matrices and initialize them
   allocate (T(N,N))
   allocate (A(N,N))
   call initMats(N, A, T)

   !$omp parallel if(N>100) num_threads(4) default(none) &
   !$omp&          shared(A,T,N) private (i,id,Nthrds) reduction(+:trace)
      id = omp_get_thread_num()
      Nthrds = omp_get_num_threads()
      call transform(N, id, Nthrds, T, A)

      ! compute trace of A matrix
      ! i.e., the sum of diagonal elements
      !$omp do
         do i = 1, N
            trace = trace + A(i,i)
         enddo
      !$omp end do
   !$omp end parallel
   print *, " transform complete with trace = ",trace
end program main


module MyUtility
! pack of utilities
! last modified : Feb 10, 2008
! Written by Yoki Okawa

integer, parameter :: db = selected_real_kind(p=13,r=200)

real(kind=db), parameter  :: two = 2.0_db
real(kind=db), parameter  :: one = 1.0_db
real(kind=db), parameter  :: p5  = 0.50_db
real(kind=db), parameter  :: zero = 0.0_db
real(kind=db), parameter  :: p1  = 0.10_db
real(kind=db), parameter  :: p01  = 0.01_db
real(kind=db), parameter  :: p0001 = 0.0001_db
real(kind=db), parameter  :: p00001 = 0.00001_db

contains
	subroutine MyError(str)
	! display error message and stop
	implicit none
	CHARACTER(LEN=*), INTENT(IN) :: str
	write(*,*) 'error ', str
	write(*,*) 'press any key to continue'
	read(*,*)

	return
	end subroutine MyError

	subroutine MatrixWrite(X,str)
	! write matrix as a matrix
	! Input:
	! X: input of matrix
	!
	! Optional Input:
	! str: (1f10.3) type string to specify the format of output.

	implicit none
	real(kind=db), intent(IN),dimension(:,:) :: X
	character(len=*), intent(IN), optional :: str
	integer :: i,j,n,m
	character(len=100) :: fmt

	! set default value of str
	if (.not. present(str)) then
		fmt  = '(1G12.6)'
	else
		fmt = str
	end if

	n = size(x,1)
	m = size(x,2)

	do i = 1, n
		do j = 1, m
			write(*,fmt,advance ='no') X(i,j)
		end do
		write(*,*) ' '
	end do

	return
	end subroutine MatrixWrite

	subroutine VectorWrite(vec,str)
	! write a vector as a horizontal vector
	! Input:
	! X: input of matrix
	!
	! Optional Input:
	! str: (1f10.3) type string to specify the format of output.

	implicit none
	real(kind=db), intent(IN),dimension(:) :: vec
	character(len=*), intent(IN), optional :: str
	integer :: i,j,n,m
	character(len=100) :: fmt

	! set default value of str
	if (.not. present(str)) then
		fmt  = "(' ' , 1F20.10)"
	else
		fmt = str
	end if

	n = size(vec)

	do i = 1, n
		write(*,fmt) vec(i)
	end do

	return
	end subroutine VectorWrite

	pure function outer(x,y)
	! caclulate the outer product
	! outer = x* y^t if x is column vector
	implicit none
	real(kind=db), intent(IN),dimension(:) :: x, y
	real(kind=db), dimension(size(x),size(y)) :: outer
	outer = spread(x,dim=2,ncopies=size(y)) * &
		spread(y,dim=1,ncopies=size(x))
	end function outer

	pure function norm(x)
	! calculate L^2 norm of X
	implicit none
	real(kind=db),intent(IN), dimension(:) :: x
	real(kind=db) ::  norm

	norm = ( dot_product(x,x) ) ** (0.50_db)
	end function norm

	pure function eye(M)
	! returns identity matrix of dimension M
	implicit none
	integer,intent(IN) :: m
	real(kind=db), dimension(M,M) ::  eye
	integer :: i, j

	forall (i=1:M, j =1:M)
		eye(i,j) = 0
	end forall

	forall (i = 1:M)
		eye(i,i) = 1
	end forall

	end function eye

	pure function diag(M)
	! returns a vector which contains diagonal element of M
	implicit none
	real(kind=db),intent(IN), dimension(:,:) :: M
	real(kind=db), dimension(min(size(M,1),size(M,2))) ::  diag
	integer :: n, i

	n= min(size(M,1),size(M,2))

	forall (i=1:n)
		diag(i) = M(i,i)
	end forall
	end function diag

end module MyUtility


      SUBROUTINE CALAVB (ISTL_)
C
C **  SUBROUTINE CALAV CALCULATES VERTICAL VISCOSITY AND DIFFUSIVITY
C **  USING GLAPERIN ET AL'S MODIFICATION OF THE MELLOR-YAMADA MODEL
C **  (NOTE AV, AB, AND AQ ARE ACTUALLY DIVIDED BY H)
C **  IF ISGA=1 VALUES ARE GEOMETRIC AVERAGES WITH THE PREVIOUS VALUES
C CHANGE RECORD
C  ADDED DRYCELL BYPASS AND CONSISTENT INITIALIZATION OF DRY VALUES
C
      USE GLOBAL
      USE OMP_LIB
	IMPLICIT NONE
      DOUBLE PRECISION LST,LEND,foo
	INTEGER::L,K,LS,ISTL_
	REAL::QQIMAX,RIQMIN,RIQMAX,RIQ,SFAV,SFAB,ABTMP,AVTMP
      REAL::BVF,SH2,SHEARVEL,SURFTAU,SURFVEL
!     New variable needed to find the the depth to the thermocline
      REAL::ZTHERM(LCM),ZMET(LCM),DENMAX(LCM)
      INTEGER::KZTHERM(LCM),KZMET(LCM)
      REAL::CP1,CP2,CP3,P2,alpha,Knot,Knottherm,Knotmet,BVFZ,KnotZ,Kv0
      REAL::RIQZtherm,RIQZmet,RIQZ,BVFZtherm,BVFZmet,KZTH,KZM

      REAL::RIQold,RIQprint

C
C   SHTOP    =      0.4939
C   SHBOT    =     34.6764
C   SMTOP1   =      0.3933
C   SMTOP2   =      7.8464
C   SMBOT1   =     34.6764
C   SMBOT2   =      6.1272
C   RLIMIT   =      0.0233
C   SHMIN    =      0.0934
C   SMMIN    =      0.1099
C   SHMAX    =      5.2073
C   SMMAX    =      4.9639
C
      QQIMAX=1./QQMIN
      AVMAX=AVO
      ABMAX=ABO
      AVMIN=10.
      ABMIN=10.
      IF(ISFAVB==3.OR.ISFAVB==4)THEN !Implement Lozovatsky Ri range
        RIQMIN=0.0 !was 0.25
        RIQMAX=2.0
      ELSE
        RIQMIN=-0.023
        RIQMAX=0.28
      ENDIF
      DO K=1,KC
        DO L=1,LC
          IF(IMASKDRY(L).EQ.1)THEN
            AV(L,K)=AVO*HPI(L)
            AB(L,K)=ABO*HPI(L)
          ENDIF
        ENDDO
      ENDDO
      IF(ISFAVB.EQ.0)THEN
!$OMP PARALLEL PRIVATE(RIQ,SFAV,SFAB,
!$OMP& AVMAX,ABMAX,AVMIN,ABMIN)
        DO K=1,KS
!$OMP DO SCHEDULE(STATIC,CHUNKSIZE)
          DO L=2,LA
            IF(LMASKDRY(L))THEN
              QQI(L)=1./QQ(L,K)
              QQI(L)=MIN(QQI(L),QQIMAX)

              RIQ=-GP*HP(L)*DML(L,K)*DML(L,K)*DZIG(K)
     &            *(B(L,K+1)-B(L,K))*QQI(L)
              RIQ=MAX(RIQ,RIQMIN)
              RIQ=MIN(RIQ,RIQMAX)
C
C      SFAV=0.4*(1.+8.*RIQ)/((1.+36.*RIQ)*(1.+6.*RIQ))
C      SFAB=0.5/(1.+36.*RIQ)
C      SFAV=0.3933*(1.+7.8464*RIQ)/((1.+34.6764*RIQ)*(1.+6.1272*RIQ))
C      SFAB=0.4939/(1.+34.6764*RIQ)
C SFAV AND SFAB ABOVE REPLACE BY KANATHA AND CLAYSON
C
              SFAV=0.3920*(1.+8.6736*RIQ)/((1.+30.192*RIQ)*(1.+
     &            6.1272*RIQ))
              SFAB=0.4939/(1.+30.192*RIQ)
             AB(L,K)=AVCON*SFAB*DML(L,K)*HP(L)*QQSQR(L,K)+ABO
             AV(L,K)=AVCON*SFAV*DML(L,K)*HP(L)*QQSQR(L,K)+AVO
              AVMAX=MAX(AVMAX,AV(L,K))
              ABMAX=MAX(ABMAX,AB(L,K))
              AVMIN=MIN(AVMIN,AV(L,K))
              ABMIN=MIN(ABMIN,AB(L,K))
              AV(L,K)=AV(L,K)*HPI(L)
              AB(L,K)=SCB(L)*AB(L,K)*HPI(L)
            ENDIF
          ENDDO
!$OMP END DO NOWAIT
        ENDDO
!$OMP END PARALLEL
      ELSEIF (ISFAVB.EQ.1)THEN
!$OMP PARALLEL PRIVATE(RIQ,SFAV,SFAB,
!$OMP& ABTMP,AVTMP,AVMAX,ABMAX,AVMIN,ABMIN)
        DO K=1,KS
!$OMP DO SCHEDULE(STATIC,CHUNKSIZE)
          DO L=2,LA
            IF(LMASKDRY(L))THEN
              QQI(L)=1./QQ(L,K)
              QQI(L)=MIN(QQI(L),QQIMAX)
              RIQ=-GP*HP(L)*DML(L,K)*DML(L,K)*DZIG(K)
     &            *(B(L,K+1)-B(L,K))*QQI(L)
              RIQ=MAX(RIQ,RIQMIN)
              RIQ=MIN(RIQ,RIQMAX)
C
C      SFAV=0.4*(1.+8.*RIQ)/((1.+36.*RIQ)*(1.+6.*RIQ))
C      SFAB=0.5/(1.+36.*RIQ)
C      SFAV=0.3933*(1.+7.8464*RIQ)/((1.+34.6764*RIQ)*(1.+6.1272*RIQ))
C      SFAB=0.4939/(1.+34.6764*RIQ)
C SFAV AND SFAB ABOVE REPLACE BY KANATHA AND CLAYSON
C
              SFAV=0.3920*(1.+8.6736*RIQ)/((1.+30.192*RIQ)*(1.+
     &            6.1272*RIQ))
              SFAB=0.4939/(1.+30.192*RIQ)
              ABTMP=AVCON*SFAB*DML(L,K)*HP(L)*QQSQR(L,K)+ABO
              AVTMP=AVCON*SFAV*DML(L,K)*HP(L)*QQSQR(L,K)+AVO
              AVMAX=MAX(AVMAX,AVTMP)
              ABMAX=MAX(ABMAX,ABTMP)
              AVMIN=MIN(AVMIN,AVTMP)
              ABMIN=MIN(ABMIN,ABTMP)
              AV(L,K)=0.5*(AV(L,K)+AVTMP*HPI(L))
              AB(L,K)=SCB(L)*0.5*(AB(L,K)+ABTMP*HPI(L))
            ENDIF
          ENDDO
!$OMP END DO NOWAIT
        ENDDO
!$OMP END PARALLEL

      ELSEIF(ISFAVB.EQ.2)THEN
!$OMP PARALLEL PRIVATE(RIQ,SFAV,SFAB,
!$OMP& ABTMP,AVTMP,AVMAX,ABMAX,AVMIN,ABMIN)
        DO K=1,KS
!$OMP DO SCHEDULE(STATIC,CHUNKSIZE)
          DO L=2,LA
            IF(LMASKDRY(L))THEN
              QQI(L)=1./QQ(L,K)
              QQI(L)=MIN(QQI(L),QQIMAX)
              RIQ=-GP*HP(L)*DML(L,K)*DML(L,K)*DZIG(K)
     &            *(B(L,K+1)-B(L,K))*QQI(L)
              RIQ=MAX(RIQ,RIQMIN)
              RIQ=MIN(RIQ,RIQMAX)
C
C SFAV AND SFAB ABOVE REPLACE BY KANATHA AND CLAYSON
C
              SFAV=0.3920*(1.+8.6736*RIQ)/((1.+30.192*RIQ)*(1.+
     &            6.1272*RIQ))
              SFAB=0.4939/(1.+30.192*RIQ)
              ABTMP=AVCON*SFAB*DML(L,K)*HP(L)*QQSQR(L,K)+ABO
              AVTMP=AVCON*SFAV*DML(L,K)*HP(L)*QQSQR(L,K)+AVO
              AVMAX=MAX(AVMAX,AVTMP)
              ABMAX=MAX(ABMAX,ABTMP)
              AVMIN=MIN(AVMIN,AVTMP)
              ABMIN=MIN(ABMIN,ABTMP)
              AV(L,K)=SQRT(AV(L,K)*AVTMP*HPI(L))
              AB(L,K)=SCB(L)*SQRT(AB(L,K)*ABTMP*HPI(L))
            ENDIF
          ENDDO
!$OMP END DO NOWAIT
        ENDDO
!$OMP END PARALLEL
      ELSEIF(ISFAVB.EQ.3)THEN  !R Arafin formulation 1
        DO K=1,KS  !KS=KC-1 second layer down
          DO L=2,LA
            IF(LMASKDRY(L))THEN
              QQI(L)=1./QQ(L,K)
              QQI(L)=MIN(QQI(L),QQIMAX)
            ENDIF
          ENDDO
          DO L=2,LA
            IF(LMASKDRY(L))THEN
!Brunt-Vaisala Frequency: N^2 =-g/rho0 * (del rho)/(del z)
!(del rho)/rho0 = B(L,K+1)-B(L,K)
!1/del z = HPI(L)*DZIG(K)
              BVF=-GP*(B(L,K+1)-B(L,K))*HPI(L)*DZIG(K)
!Vertical shear: [(del u)/(del z)]^2 + [(del v)/(del z)]^2
              SH2=((U(L,K+1)-U(L,K))*HPI(L)*DZIG(K))**2+
     &            ((V(L,K+1)-V(L,K))*HPI(L)*DZIG(K))**2
              RIQ=BVF/MIN(SH2+1.0E-6,RIQMAX) !Richardson number is Brunt-Vaisala frequency divided by vertical shear
              RIQ=MAX(RIQ,RIQMIN)  !Implement floor of Ri
              RIQ=MIN(RIQ,RIQMAX)  !Implement ceiling of Ri
!Shear velocity calculation: u*=sqrt(tau/rho)=sqrt(mu*sqrt(SH2)/rho)
!Water viscosity:            mu=1.003E-3 kg/m-s
!Water density:              rho=1000.0*(B(L,K)+1.0)
              SHEARVEL=
     &SQRT(1.003E-3*SQRT(SH2)/(1000.0*(B(L,K)+1.0)))
!Vertical diffusivity: von Karman constant is VKC
!                      Depth, z, is HP(L)*0.5*(Z(K+1)+Z(K))
!                      p is (2.0/3.0)
!                      Ricr is 0.1
!                      Ribeta is 0.05
!                      r is 1.0
              IF(HP(L)*(1.0-ZZ(K))<30.0)THEN !Lozovatsky formulation for depths less that 30 m
                SFAB=VKC*SHEARVEL*HP(L)*(1.0-ZZ(K))/
     &             (1.0+RIQ/0.1)**(2.0/3.0)/(1.0+RIQ/0.05)**1.0
                RIQ=-GP*HP(L)*DML(L,K)*DML(L,K)*DZIG(K)  !Old Mellor-Yamada formulation for SFAV
     &              *(B(L,K+1)-B(L,K))*QQI(L)
                RIQ=MAX(RIQ,RIQMIN)
                RIQ=MIN(RIQ,RIQMAX)
                SFAV=0.3920*(1.+8.6736*RIQ)/
     &               ((1.+30.192*RIQ)*(1.+6.1272*RIQ))
              ELSE !Mellor-Yamada formulation for depths greater than 30 m
                RIQ=-GP*HP(L)*DML(L,K)*DML(L,K)*DZIG(K)
     &            *(B(L,K+1)-B(L,K))*QQI(L)
                RIQ=MAX(RIQ,RIQMIN)
                RIQ=MIN(RIQ,RIQMAX)
                SFAV=0.3920*(1.+8.6736*RIQ)/((1.+30.192*RIQ)*(1.+
     &            6.1272*RIQ))
                SFAB=0.4939/(1.+30.192*RIQ)
              ENDIF

              IF(K==KS)THEN !Special logic for top model layer not otherwise calculated. In the Mellor-Yamada version, it is just ABO*HPI(L)
                  SURFTAU=SQRT(TSX(L)**2 + TSY(L)**2)           !RRA: TSX(L) and TSY(L) computed in CALTSXY
                  SURFVEL=SQRT(SURFTAU/(1000.0*(B(L,K+1)+1.0))) !RRA: SURFVEL is frictional velocity U* at surface
                  ABTMP=AVCON*VKC*SURFVEL*HP(L)*(1.0-ZZ(K+1))/
     &                  (1.0+RIQ/0.1)**(2.0/3.0)/(1.0+RIQ/0.05)**1.0+ABO
                  AB(L,K+1)=SCB(L)*0.5*(AB(L,K+1)+ABTMP*HPI(L))
              ENDIF
              ABTMP=AVCON*SFAB+ABO
              AVTMP=AVCON*SFAV*DML(L,K)*HP(L)*QQSQR(L,K)+AVO
              AVMAX=MAX(AVMAX,AVTMP)
              ABMAX=MAX(ABMAX,ABTMP)
              AVMIN=MIN(AVMIN,AVTMP)
              ABMIN=MIN(ABMIN,ABTMP)
              AV(L,K)=0.5*(AV(L,K)+AVTMP*HPI(L))  !Harmonic (time average) time smoothing
              AB(L,K)=SCB(L)*0.5*(AB(L,K)+ABTMP*HPI(L))  !Harmonic (time averge) time smoothing
!      IF(MOD(L,1000)==0)write(6,'(3(i5,1x),6(e9.2,1x))') !Debugging
!     &N,L,K,
!     &AB(L+1,K),AB(L,K),
!     &AB(L,K+1),RIQ
            ENDIF
          ENDDO
        ENDDO
      ELSEIF(ISFAVB.EQ.4)THEN
!Variation of density B(L,K+1)-B(L,K)
!Variation of vertical velocities U(L,K+1)-U(L,K) and V(L,K+1)-V(L,K)
!Change in sigma depth (normalized Z) is DZC(K)
!Change in  depth Z (dimensional) is HP(L)*DZC(K)
!RRA: Need to define depth, z correctly
!Ztherm is the depth of maximum gradient
!Zmeta is the boundary depth between metalimnion and hypolimnion at which the density gradient equals to threshold value 10-5 kg m-4
        IF (PARTID == MASTER_TASK) THEN
          OPEN(9876,FILE="ZTHERM.OUT",POSITION='APPEND')
          IF(MOD(N-1,86400)==0)THEN
            WRITE(9876,'("Time step: ",I8)')N
            WRITE(9876,
     &  '("  I   J Ktherm HP   Ztherm  Zmet Kmet  AVKT  ABKT ")')
          ENDIF
        END IF
        DENMAX(2:LA)=0.0 !initialize maximum density change to zero
        KZTHERM(2:LA)=KS !initialize the thermocline to start at layer KS (one below top layer)
        ZTHERM(2:LA)=HP(2:LA)*(1.0-ZZ(KS)) !initialize thermocline depth to the depth of layer KS
        KZMET(2:LA)=2 !initialize the metalimnion to begin at layer 2
        ZMET(2:LA)=HP(2:LA)*(1.0-ZZ(2)) !initialize the metalimnion depth to the depth of layer 2
        DO L=2,LA
          DO K=KS,2,-1
            IF(DENMAX(L)<B(L,K)-B(L,K+1))THEN !find the depth of the maximum density gradient (assumes stable stratification)
              DENMAX(L)=B(L,K)-B(L,K+1)
              ZTHERM(L)=HP(L)*(1.0-ZZ(K))
              KZTHERM(L)=K !Note this KZTHERM is the layer (K) containing the thermocline and not K(Ztherm), which is calculated below as KZTH
            ENDIF
          ENDDO
          IF(HP(L)>30.0)THEN !deep water
            IF(ZTHERM(L)<4.0)THEN !limit thermocline to deeper than 4 m
              ZTHERM(L)=4.0
              DO K=KC,1,-1
                IF(HP(L)*(1.0-ZZ(K))>4.0)THEN
                  KZTHERM(L)=MAX(K,2)
                  EXIT
                ENDIF
              ENDDO
            ELSEIF(ZTHERM(L)>30.0)THEN !limit thermocline to shallower than 30 m
              ZTHERM(L)=30.0
              DO K=1,KC
                IF(HP(L)*(1.0-ZZ(K))<30.0)THEN
                  KZTHERM(L)=MAX(K,2)
                  EXIT
                ENDIF
              ENDDO
            ENDIF
          ELSEIF(HP(L)>12.0)THEN !shallow water
            IF(ZTHERM(L)<4.0)THEN !limit thermocline to deeper than 4 m
              ZTHERM(L)=4.0
              DO K=KC,1,-1
                IF(HP(L)*(1.0-ZZ(K))>4.0)THEN
                  KZTHERM(L)=MAX(K,2)
                  EXIT
                ENDIF
              ENDDO
            ELSEIF(ZTHERM(L)>12.0)THEN !limit thermocline to shallower than 12 m
              ZTHERM(L)=12.0
              DO K=1,KC
                IF(HP(L)*(1.0-ZZ(K))<12.0)THEN
                  KZTHERM(L)=MAX(K,2)
                  EXIT
                ENDIF
              ENDDO
            ENDIF
          ELSE
            CONTINUE !Do not limit thermocline depths if the water depth is less than 12 m
          ENDIF
          DO K=KZTHERM(L)-1,2,-1 !calculate the metalimnion depth.
            IF(1000.0*(B(L,K)-B(L,K-1))/(DZC(K)*HP(L))<1.0E-5)THEN !Is the density gradient < 1E-5 kg/m^4
              ZMET(L)=HP(L)*(1.0-ZZ(K))
              KZMET(L)=K !Note this KZMET is the layer (K) containing the metalimnion and not K(Zmet), which is calculated below as KZM
             EXIT
            ENDIF
          ENDDO
          IF (PARTID == MASTER_TASK) THEN
            IF(MOD(N-1,86400)==0.AND.(L==1963.OR.L==130))THEN
              WRITE(9876,'(3(i3,1x),3(f6.2,1x),i2,2(1x,e8.3))')
     &IL(L),JL(L),KZTHERM(L),HP(L),ZTHERM(L),ZMET(L),KZMET(L),
     &AV(L,KZTHERM(L)),AB(L,KZTHERM(L))
            ENDIF
          END IF
        ENDDO
        IF(PARTID == MASTER_TASK .AND. MOD(N-1,86400)==0)THEN
          CLOSE(9876)
        ENDIF
        DO K=1,KS  !KS=KC-1 (second layer from the top)
          DO L=2,LA
            IF(LMASKDRY(L))THEN
              QQI(L)=1./QQ(L,K)
              QQI(L)=MIN(QQI(L),QQIMAX)
            ENDIF
          ENDDO
        ENDDO
        DO L=2,LA
          IF(LMASKDRY(L))THEN
!Surface frictional velocity computation: 2 approaches, either default from EFDC or from Vincon-Leite.
!Water viscosity:           mu      = 1.003E-3 kg/m-s
!Water density:             rho     = 1000.0*(B(L,K)+1.0)
!Air density: 			  rho_air = 1.29*(B(L,K)+1.0)
!Wind drag coefficient, CD: CD      = 1.8 E-3

!Surface frictional velocity computation as default in EFDC.
!              SURFTAU=SQRT(TSX(L)**2 + TSY(L)**2)           !RRA: TSX(L) and TSY(L) computed in CALTSXY
!              SURFVEL=SQRT(SURFTAU/(1000.0*(B(L,K+1)+1.0))) !RRA: SURFVEL is frictional velocity U* at surface
!Surface frictional velocity computation following Vincon-Leite.
            SURFVEL=
     &SQRT(1.8E-3*(1.29*(B(L,KS)+1.0))/(1000.0*(B(L,KC)+1.0)))*WINDST(L) !RRA: WINDST(L)is computed in CALTSXY This is calculated only at the surface layer
            IF (PARTID == MASTER_TASK) THEN
              IF(MOD(N-1,86400)==0.AND.(L==1963.OR.L==130))THEN
                  WRITE(753,'("Time step: ",I8)')N
                  WRITE(753,
     &'("  N   I   J   K Richardsn   BVF       DenGrad   Density Tempera
     &ture  SFAB    SFAV      BVFZtherm   BVFZmet    Knot   Knottherm Kn
     &otmet")')
              END IF
            ENDIF
            DO K=KS,1,-1
!Richardson number, RIQ computation as default in EFDC (Brunt-Vaisala frequency divided by vertical shear)
!Vertical shear: [(del u)/(del z)]^2 + [(del v)/(del z)]^2
!              SH2=((U(L,K+1)-U(L,K))*HPI(L)*DZIG(K))**2+
!     &            ((V(L,K+1)-V(L,K))*HPI(L)*DZIG(K))**2
!              RIQ=BVF/MIN(SH2+1.0E-6,RIQMAX) !Richardson number is Brunt-Vaisala frequency divided by vertical shear

!Vincon-Leite Richardson number, RIQ, is independent of shear velocity
! Calibration parameter CP1: gamma
              CP1 = 570.0 !seconds
! Calibration parameter CP2: delta
              CP2 = 0.015
! Calibration parameter CP3: sigma
              CP3 = 9.46
! Calibration parameter alpha:
              alpha = 0.173
! Calibration parameter P2:
              P2 = 0.605
!Brunt-Vaisala Frequency: N^2 =-g/rho0 * (del rho)/(del z)
!(del rho)/rho0 = B(L,K+1)-B(L,K)
!1/del z = HPI(L)*DZIG(K)
              BVF=GP/(1.0+B(L,K))*ABS(B(L,K+1)-B(L,K))*HPI(L)*DZIG(K) !Brunt-Vaisala frequency squared at depth Z (layer K): BVF(Z) = g/rho*|delta rho|/|delta z|

!RRA: Shear velocity (Internal) computation is redundant because Richardson number is independent of shear velocity according to Vincon-Leite.
!u*=sqrt(tau/rho)=sqrt(mu*sqrt(SH2)/rho)
!Water viscosity:            mu=1.003E-3 kg/m-s
!Water density:              rho=1000.0*(B(L,K)+1.0)
!SHEARVEL=SQRT(1.003E-3*SQRT(SH2)/(1000.0*(B(L,K)+1.0)))
!Eddy Diffusivity K0 in neutral condition
!RRA: Note RIQZ (Richardson number) at metalimnion and hypolimnion levels required in K(Ztherm) and K(Zmet) computations
!BVFZ (Brunt-Vaisala frequency) required at Ztherm and Zmet depths
             IF(HP(L)*(1.0-ZZ(K))<=ZTHERM(L))THEN !From Surface to Thermocline
               RIQ=
     &BVF*(CP1*CP2)**2*(EXP(2.*HP(L)*(1.0-ZZ(K))/CP1/SURFVEL)) !Ri(Z)
!RRA: Vincon-Leite didn't mention any upper or lower limit for Richardson number, so may be floor/ceiling of Ri not needed.
               RIQ=MAX(RIQ,RIQMIN)  !Implement floor to Ri
               RIQ=MIN(RIQ,RIQMAX)  !Implement ceiling to Ri

               RIQprint=RIQ !debug vertical profiles

               Knot =
     &CP1*CP2*SURFVEL**2*EXP(-HP(L)*(1.0-ZZ(K))/CP1/SURFVEL) !K0(Z) = gamma*delta*omega^2*exp(-Z/gamma/omega)
               SFAB=Knot/(1.0+CP3*RIQ) !K(Z) = K0(Z)/[1+sigma*Ri(Z)]
             ELSEIF(HP(L)*(1.0-ZZ(K))<=ZMET(L))THEN !From Thermocline to Metalimnion: Vertical Eddy Diffusivity Computation  (Ztherm > Z >= Zmet)
!Calculation of K(Ztherm): KZTH
               Knottherm=
     &CP1*CP2*SURFVEL**2*EXP(-ZTHERM(L)/CP1/SURFVEL) !K0(Ztherm)
               BVFZtherm=
     &MAX(
     &GP/(1.0+B(L,KZTHERM(L)))*
     &ABS((B(L,KZTHERM(L)+1)-B(L,KZTHERM(L))))*HPI(L)*DZIG(KZTHERM(L)),
     &1.0E-18) !Brunt Vaisala frequency at Ztherm: BVF(Ztherm)
               RIQZtherm=
     &BVFZtherm*(CP1*CP2)**2*
     &EXP(2.*ZTHERM(L)/CP1/SURFVEL) !Ri(Ztherm)
               RIQZtherm=MAX(RIQZtherm,RIQMIN)  !Implement floor of Ri
               RIQZtherm=MIN(RIQZtherm,RIQMAX)  !Implement ceiling of Ri

               RIQprint=RIQZtherm !debug vertical profiles

               KZTH=Knottherm/(1.0+CP3*RIQZtherm) !K(Ztherm)
               IF(BVF>0.0)THEN
                 SFAB=alpha*KZTH*(BVFZtherm/BVF)**P2 !K(z) for Ztherm > Z >= Zmet
               ELSE
                 SFAB=0.0 !Avoid divide by zero errors
               ENDIF
             ELSE !In hypolimnion Zmet > Z > Zmax (or HP(L)
!Calculation of K(Zmet): KZM
               Knotmet=
     &CP1*CP2*SURFVEL**2*EXP(-ZMET(L)/CP1/SURFVEL)
!               BVFZmet=
!     &MAX(
!     &GP/(1.0+B(L,KZMET(L)))*
!     &ABS((B(L,KZMET(L)+1)-B(L,KZMET(L))))*HPI(L)*DZIG(KZMET(L)),
!     &    1.0E-6) !Brunt Vaisala frequency at Zmet: BFV(Zmet)
               BVFZmet=
     &MAX(-GP/(1.0E3*(1.0+B(L,KZMET(L))))*1E-5,
     &    1.0E-18) !Brunt Vaisala frequency at Zmet: BFV(Zmet) Using density gradient threshold 1E-5
               RIQZmet=
     &BVFZmet*(CP1*CP2)**2*EXP(2.*ZMET(L)/CP1/SURFVEL) !Ri(Zmet)
               RIQZmet=MAX(RIQZmet,RIQMIN)  !Implement floor of Ri
               RIQZmet=MIN(RIQZmet,RIQMAX)  !Implement ceiling of Ri

               RIQprint=RIQZmet !debug vertical profiles

               KZM=Knotmet/(1.0+CP3*RIQZmet) !K(Zmet)
               IF(BVF>0.0)THEN
                 SFAB=
     &(HP(L)-HP(L)*(1.0-ZZ(K)))/(HP(L)-ZMET(L))*
     &KZM*(BVFZmet/BVF)**P2 !K(z) for Zmet > Z >= Zmax (or HP(L))
               ELSE
                 SFAB=0.0
               ENDIF
             ENDIF
!Following Pacanowski and Philander (1981), used by Rao et al. (2004).
!Need Richardson number, RIQ. Use the default calculation from EFDC (Brunt-Vaisala frequency divided by vertical shear).
!Vertical shear: [(del u)/(del z)]^2 + [(del v)/(del z)]^2
              SH2=((U(L,K+1)-U(L,K))*HPI(L)*DZIG(K))**2+
     &            ((V(L,K+1)-V(L,K))*HPI(L)*DZIG(K))**2
              RIQ=BVF/MIN(SH2+1.0E-6,RIQMAX)
!Richardson number is Brunt-Vaisala frequency divided by vertical shear
!Previously calculated SFAV in EFDC following Mellor-Yamada (1982).
!SFAV=0.3920*(1.+8.6736*RIQ)/((1.+30.192*RIQ)*(1.+6.1272*RIQ))
!AVTMP=AVCON*SFAV*DML(L,K)*HP(L)*QQSQR(L,K)+AVO

!New formulation by Pacanowski and Philander (1981)
!Kv0 is an adjustable parameter:  Kv0 =1.0 E-2 m2/s
!AVO is background eddy diffusivity value (user input)
              SFAV = 0.01*(1.0+5.0*RIQ)**(-2)
!Include on/off switch (AVCON), add backgrounds, apply limits, and then harmonically smooth
              ABTMP=AVCON*SFAB+ABO
              AVTMP=AVCON*SFAV+AVO
              AVMAX=MAX(AVMAX,AVTMP)
              ABMAX=MAX(ABMAX,ABTMP)
              AVMIN=MIN(AVMIN,AVTMP)
              ABMIN=MIN(ABMIN,ABTMP)
              AV(L,K)=       SQRT(AV(L,K)*AVTMP*HPI(L)) !Harmonic (time average) time smoothing
              AB(L,K)=SCB(L)*SQRT(AB(L,K)*ABTMP*HPI(L)) !Harmonic (time average) time smoothing

            ENDDO
          ENDIF
        ENDDO
      ENDIF
      ! *** NOW APPLY MAXIMUM, IF REQURIED
      IF(ISAVBMX.GE.1)THEN
!$OMP PARALLEL PRIVATE(AVTMP,ABTMP)
        DO K=1,KS
!$OMP DO SCHEDULE(STATIC,CHUNKSIZE)
          DO L=2,LA
            AVTMP=AVMX*HPI(L)
            ABTMP=ABMX*HPI(L)
            AV(L,K)=MIN(AV(L,K),AVTMP)
            AB(L,K)=MIN(AB(L,K),ABTMP)
          ENDDO
!$OMP END DO NOWAIT
        ENDDO
!$OMP END PARALLEL
      ENDIF
!$OMP PARALLEL PRIVATE(LS)
      DO K=1,KS
!$OMP DO SCHEDULE(STATIC,CHUNKSIZE)
        DO L=2,LA
          LS=LSC(L)
c pmc          AVUI(L,K)=2./(AV(L,K)+AV(L-1,K))
c pmc          AVVI(L,K)=2./(AV(L,K)+AV(LS,K))
cferg          AVUI(L,K)=(1.+SUB(L))/(AV(L,K)+SUB(L)*AV(L-1,K))
cferg          AVVI(L,K)=(1.+SVB(L))/(AV(L,K)+SVB(L)*AV(LS,K))
               AVUI(L,K) = 1./AV(L,K)
               AVVI(L,K) = 1./AV(L,K)
        ENDDO
!$OMP END DO NOWAIT
      ENDDO
      DO K=2,KS
!$OMP DO SCHEDULE(STATIC,CHUNKSIZE)
        DO L=2,LA
          AQ(L,K)=0.205*(AV(L,K-1)+AV(L,K))
        ENDDO
!$OMP END DO NOWAIT
      ENDDO
!$OMP DO SCHEDULE(STATIC,CHUNKSIZE)
      DO L=2,LA
        AQ(L,1)=0.205*AV(L,1)
        AQ(L,KC)=0.205*AV(L,KS)
      ENDDO
!$OMP END DO NOWAIT
!$OMP END PARALLEL

      RETURN
      END


      SUBROUTINE SPLIT(TT,FR)
C
C+++++++++++++++++++++++++
C
C     THIS SUBROUTINE BREAKS A D.P. NUMBER INTO A D.P. INTEGER
C     AND A D.P. FRACTIONAL PART.
C
C     CALLING SEQUENCE PARAMETERS:
C
C       TT = D.P. INPUT NUMBER
C
C       FR = D.P. 2-WORD OUTPUT ARRAY.
C            FR(1) CONTAINS INTEGER PART
C            FR(2) CONTAINS FRACTIONAL PART
C
C            FOR NEGATIVE INPUT NUMBERS, FR(1) CONTAINS THE NEXT
C            MORE NEGATIVE INTEGER; FR(2) CONTAINS A POSITIVE FRACTION.
C
C       CALLING SEQUENCE DECLARATIONS
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)

      DIMENSION FR(2)

C       MAIN ENTRY -- GET INTEGER AND FRACTIONAL PARTS

      FR(1)=DINT(TT)
      FR(2)=TT-FR(1)

      IF(TT.GE.0.D0 .OR. FR(2).EQ.0.D0) RETURN

C       MAKE ADJUSTMENTS FOR NEGATIVE INPUT NUMBER

      FR(1)=FR(1)-1.D0
      FR(2)=FR(2)+1.D0

      RETURN

      END

C++++++++++++++++++++++++++++++++
C


! { dg-do run }
! { dg-skip-if "" { *-*-* } { "-O0" } { "" } }
! { dg-additional-options "-ffrontend-optimize -floop-nest-optimize" }
! PR 56872 - wrong front-end optimization with a single constructor.
! Original bug report by Rich Townsend.
  integer :: k
  real :: s
  integer :: m
  s = 2.0
  m = 4
  res = SUM([(s**(REAL(k-1)/REAL(m-1)),k=1,m)])
  if (abs(res - 5.84732246) > 1e-6) STOP 1
  end


SUBROUTINE weitc(ord,x,y,sig,mu,eta)

!-------------------------------------------------------------
!
!  Computes the spatial weights for AHOT-C
!  Adapted from code AHOT.1, by YYAzmy on 03/05/2010
!
!  Input:
!
!  ** ord    - equal to lambda
!  ** x,y    - delta_x and delta_y
!  ** sig    - total cross section in cell
!  ** mu,eta - angle cosines, standard notation
!
!  Variables
!
!  ** In most cases totally analogous to azmy 92
!-------------------------------------------------------------

USE solvar
IMPLICIT NONE
!
! Input Variables
!
INTEGER ,INTENT(in) :: ord
REAL*8  ,INTENT(in) :: x,y
REAL*8  ,INTENT(in) :: sig,mu,eta
!
! Local Variables
!
REAL*8 :: xi
REAL*8 :: eex,eey
REAL*8 :: summe
REAL*8 :: z1,e1,z2,e2,xz,fai,faj,fan,fam
REAL*8 :: sm1,legp1,legp2
INTEGER :: i,j,k,l,m,n
INTEGER :: kmin,kmax
   !
   ! Initialize
   !
   scra = 0.0
   scrt = 0.0
   scrm = 0.0
   scrn = 0.0
   !
   ! Set the optical thicknesses ex and ey
   ! and the aspect ratio
   !
   ex  = 0.5*sig*x/mu
   ey  = 0.5*sig*y/eta
   xi  = ex / ey
   eex = exp(-2.0*ex)
   eey = exp(-2.0*ey)
   !
   ! Calculate scra weights
   !
   DO i = 0, ord
      DO j = 0, ord
         scra(i,j,0,0) = 1.0
      END DO
   END DO
   !
   IF (ord > 0) THEN
      DO i = 0, ord
         DO j = 0, ord
            DO m = i-1,0,-1
               kmax = i-1
               kmin = m+1-mod(i+m,2)
               summe = 0.0
               DO k = kmin, kmax, 2
                  summe = summe + REAL(2*k+1,8)*scra(k,j,k-m,0)
               END DO
               scra(i,j,i-m,0) = -summe / ex
            END DO
         END DO
      END DO
      !
      DO i = 0, ord
         DO j = 0, ord
            DO n = j-1,0,-1
               kmax = j-1
               kmin = n+1-mod(j+n,2)
               summe = 0.0
               DO k = kmin, kmax, 2
                  summe = summe + REAL(2*k+1,8)*scra(i,k,0,k-n)
               END DO
               scra(i,j,0,j-n) = -summe / ey
            END DO
         END DO
      END DO
      !
      DO i = 0, ord
         DO j = 0, ord
            DO m = i-1,0,-1
               DO n = j-1,0,-1
                  summe = 0.0
                  kmin = m+1-mod(i+m,2)
                  kmax = i-1
                  DO k = kmin,kmax,2
                     summe = summe + REAL(2*k+1,8)*scra(k,j,k-m,j-n)
                  END DO
                  scra(i,j,i-m,j-n) = -summe / ex
                  !
                  summe = 0.0
                  kmin = n+1-mod(j+n,2)
                  kmax = j-1
                  DO k = kmin,kmax,2
                     summe = summe + REAL(2*k+1,8)*scra(i,k,i-m,k-n)
                  END DO
                  scra(i,j,i-m,j-n) = scra(i,j,i-m,j-n) - summe / ey
                  !
               END DO
            END DO
         END DO
      END DO
      !
   END IF
   !
   ! End Calculation scra weights
   !
   !
   ! Start Calculating scrt and scrm weights
   !
   ! Set auxiliary variables like azmy depending on xi
   !
   IF(xi > 1.0) THEN
      z1 = ey
      e1 = eey
      z2 = ex
      e2 = eex
      xz = xi
   ELSE
      z2 = ey
      e2 = eey
      z1 = ex
      e1 = eex
      xz = 1.0/xi
   END IF
   !
   fai = -1.0
   !
   DO i = 0, ord
      fai = -fai
      faj = -1.0
      DO j = 0, ord
         faj = -faj
         CALL p(i,1.0-2.0/xz,legp1)
         sm1 = 0.5*(faj-e1*legp1)
         !
         IF (i > 0) THEN
            kmin = 1-mod(i,2)
            kmax = i-1
            DO k=kmin,kmax,2
               sm1 = sm1 - REAL(2*k+1,8)*scrt(k,j)/xz
            END DO
         END IF
         !
         IF (j > 0) THEN
            kmin = 1-mod(j,2)
            kmax = j-1
            DO k=kmin,kmax,2
               sm1 = sm1 + REAL(2*k+1,8)*scrt(i,k)
            END DO
         END IF
         !
         scrt(i,j) = sm1/z1
         scrm(j,i) = fai*faj*scrt(i,j)/xz
      END DO
   END DO
   !
   ! Finished Calculating scrt and scrm weights
   !
   !
   ! Start Calculating scrn weights
   !
   fai = -1.0
   DO i = 0, ord
      fai = -fai
      DO j = 0, ord
         CALL p(i,1.0-2.0/xz,legp1)
         CALL p(j,2.0/xz-1.0,legp2)
         summe = 0.5*e1*(legp1-fai*(2.0/xz-1.0)*legp2)
         !
         IF(i > 0) THEN
            kmin=1-mod(i,2)
            kmax=i-1
            DO k = kmin,kmax,2
               summe = summe - 2.0*REAL(2*k+1,8)*scrn(k,j)/xz
            END DO
         END IF
         !
         IF(i > 1) THEN
            kmin = 1-mod(i-1,2)
            kmax = i-2
            DO k=kmin,kmax,2
               summe = summe - REAL(2*k+1,8)*scrn(k,j)
            END DO
         END IF
         !
         IF(j > 1) THEN
            kmin =1-mod(j-1,2)
            kmax =j-2
            DO k=kmin,kmax,2
               summe = summe - REAL(2*k+1,8)*scrn(i,k)
            END DO
         END IF
         !
         scrn(i,j) = summe/REAL(1+i+j,8)
         !
      END DO
   END DO
   !
   ! Finished Calculating scrn - finished calculating weights
   !
   !
   ! Start Calculating Source Multipliers
   !
   DO i = 0, ord
      DO j = 0, ord
         flml(i+1,j+1,1) = REAL(2*i+1,8)*scrt(i,j)
         flml(i+1,j+1,2) = REAL(2*i+1,8)*scrn(i,j)
         flml(i+1,j+1,3) = REAL(2*i+1,8)*scrm(i,j)
      END DO
   END DO
   !
   IF (xi > 1.0) THEN
      !
      DO i = 0, ord
         DO j = 0, ord
            DO l = 0, ord
               summe = 0.0
               !
               DO m = 0, i
                  IF (j.le.l) summe = summe + scra(i,l,i-m,l-j) / REAL(2*j+1,8)
                  fan = -1.0
                  DO n = 0, l
                     fan = -fan
                     summe = summe-fan*scra(i,l,i-m,l-n)*scrt(m,j)
                  END DO
               END DO
               !
               srml(i+1,l+1,j+1,1) = REAL(2*i+1,8)*REAL(2*l+1)*summe
               !
               summe = 0.0
               fan = -1.0
               DO n = 0, l
                  fan = -fan
                  IF(j.le.i) summe = summe + scra(i,l,i-j,l-n) / REAL(2*j+1,8)
                  fam = -1.0
                  DO m = 0, i
                     fam = -fam
                     summe = summe - scra(i,l,i-m,l-n)*(fan*scrn(m,j)+fam*scrm(n,j))
                  END DO
               END DO
               !
               srml(i+1,l+1,j+1,2) = REAL(2*i+1,8)*REAL(2*l+1,8)*summe
               !
            END DO
         END DO
      END DO
      !
   ELSE
      !
      DO i = 0, ord
         DO j = 0, ord
            DO l = 0, ord
               !
               summe = 0.0
               DO n = 0, l
                  IF(j .le. i) summe = summe + scra(i,l,i-j,l-n) / REAL(2*j+1,8)
                  fam = -1.0
                  DO m = 0, i
                     fam = -fam
                     summe = summe - fam*scra(i,l,i-m,l-n)*scrt(n,j)
                  END DO
               END DO
               !
               srml(i+1,l+1,j+1,1) = REAL(2*i+1,8)*REAL(2*l+1,8)*summe
               !
               summe = 0.0
               fam = -1.0
               DO m = 0, i
                  fam = -fam
                  IF(j .le. l) summe = summe + scra(i,l,i-m,l-j) / REAL(2*j+1,8)
                  fan = -1.0
                  DO n = 0, l
                     fan = -fan
                     summe = summe - scra(i,l,i-m,l-n)*(fam*scrn(n,j)+fan*scrm(m,j))
                  END DO
               END DO
               !
               srml(i+1,l+1,j+1,2) = REAL(2*i+1,8)*REAL(2*l+1,8)*summe
               !
            END DO
         END DO
      END DO
      !
   END IF
   !
   RETURN
   !
END SUBROUTINE weitc


c=======================================================================
c
c     subroutine NPREG
c
c     Regression Estimation by Non Parametric Kernel method
c
c     THE RAW DATA SHOULD BE GIVEN BY THE POINTS
c     (T(1),X(1)),...,(T(N),X(N))
c
c     THE RESULTING ESTIMATOR OF THE NUE-TH DERIVATIVE OF THE
c     REGRESSION CURVE IS GIVEN THROUGH THE POINTS
c     (TT(1),Y(1)),...,(TT(M),Y(M))
c
c-----------------------------------------------------------------------
      SUBROUTINE npreg ( N, M, NUE, T, X, TT, dwork, Y, info )
c-----------------------------------------------------------------------
c
c     INPUT
c       N     : number of points (N > 1)                         integer
c       M     : number of (output) gird points (M > 0)           integer
c       NUE   : derivative order of the estimated regression,    integer
c               only NUE=0,1 or 2 are possible.
c       T(N)  : input gird (N)                                    double
c       X(N)  : data (N)                                          double
c       TT(M) : output gird (M)                                   double
c
c     WORKSPACE
c       dwork : 6*(N + 201)                                       double
c
c     OUTPUT
c       Y(M)  : estimates (M)                                     double
c       info  : diagnostic argument                              integer
c
c-----------------------------------------------------------------------
c
      IMPLICIT NONE
c
c     i/o arguments
      INTEGER NUE, N, M, info
      DOUBLE PRECISION T(*), X(*), TT(*), Y(*)
c
c     workspaces
      DOUBLE PRECISION dwork(*)
c
c     local variables
      INTEGER pds, pdwn, pdw1
      INTEGER IHOM, IRND, ISMO, M1, KORD
      PARAMETER(IHOM = 0, IRND = 1, ISMO = 0, M1 = 400)
c
c     IHOM, SIG: These variables indicate which variance estimator should be used for IRND=0
c           or ISMO=0 (default values). They are not used at all for both IRND<>0 and ISMO<>0.
c           For IHOM=0 (default) homoscedastic variance is assumed, i.e. that the variance of
c           the error variables equals a constant and thus does not depend on the location or
c           on the regression function. For IHOM=0 and SIG<=0 (both default values),
c           the variance is estimated nonparametrically and can be found as output of SIG
c           as long as IRND=0 or ISMO=0 (default values). For IHOM=0 and SIG>0 the algorithm
c           uses the input value of SIG as variance estimator for IRND=0 or ISMO=0 (default values).
c           For IHOM<>0 a smooth variance function is assumed and estimated by the algorithm
c           for IRND=0 or ISMO=0 (default values). The variable SIG is not used than.
c     IRND: This variable will specify the weights of the convolution kernel estimator
c           and the calculation of the S-array. The classical Gasser-Müller form of the weights
c           is used for IRND<>0. This will be useful for equidistant and nearly equidistant
c           design points T(1),...,T(N). If the distances T(I)-T(I-1) are very variable,
c           e.g. if T(1),...,T(N) are ordered variables from a random sample, such a convolution
c           kernel estimator is inefficient. Than it is useful to perform an easy modification
c           which is done for IRND=0 (default). For large sample size N this modification can
c           also handle multiple design points automatically.
c     ISMO  This variable simply indicates if previously specified local or global
c           bandwidths should be used. Than put ISMO<>0 and specify a global bandwidth
c           by the variable B in glkern.f and a local bandwidth array BAN of length M in lokern.f.
c           Data-adaptive plugin bandwidths are calculated for ISMO=0 (default).
c     M1    >=10, length of W1, large value will increase the accuracy of the integral
c           approximation (default M1=400).
c     KORD  This variable specifies the kernel order which is used by the kernel regression
c           estimator. KORD-NUE has to be an even number, KORD=NUE+2 will be the default choice.
c           Only NUE+2<=KORD<=4 is allowed for automatic bandwidth choice (ISMO=0, default) and
c           NUE+2<=KORD<=6 is allowed for smoothing with specified bandwidths (ISMO<>0).
c
      DOUBLE PRECISION TL, TU, SIG, B
      PARAMETER (TL = 1.0, TU = 0.0, SIG = -1.0)
c
c     TL, TU These variables specify lower and upper bounds of the region for the global bandwidth
c            estimation step (even in lokern.f). If TL>=TU (default) they are set automatically
c            and exclude a small part of the boundary region.
c     S(0:N) This array is of methodological interest mainly. It specifies the weights of the
c            convolution kernel estimator. For S(N)>=S(0) (default) this array is computed
c            automatically according to the IRND-variable. For IRND=0 (default) the computation
c            of this array does not depend on the bandwidths, the same array may be used if the
c            subroutines are called for different bandwidths (ISMO<>0). It is very important to
c            perform a new initialization for different design points and useful to do so for
c            different NUE, KORD and variance too.
c            For IRND<>0 the S-array does only depend on T(1),...,T(N).
c     SIG    Residual variance, estimated for SIG=0 or IHOM<>0, else given by input
c            (default SIG = -1.0).
c     B      Global plug-in bandwith (B can be undefined if ISMO=0).
c
c--------------------------------------------------------------------
c
c     initialization
      info  = 0
c
c     pointers for double precision work space  : dwork
c     -------------------------------------------------
      pds = 1
c     pds  : pointer for S array, so ( N + 1 )
      pdwn = pds + ( N + 1 )
c     pdwn : pointer for WN array, so ( 5*(N + 1) )
      pdw1 = pdwn + ( 5*(N + 1) )
c     pdw1 : pointer for W1 array, so (3*M1)
c
c     Total size of dwork array = N + 1
c                               + 5*(N + 1)
c                               + 3*400
c                               = 6*(N + 201)
c
c--------------------------------------------------------------------
c
c     kernel order
      KORD = NUE + 2
c
c      DOUBLE PRECISION S(0:N), WN(0:N,5),W1(M1,3)
c
c     S(0)=1.0, S(N)=0.0
      dwork(pds) = 1.0
      dwork(pds + N + 1) = 0.0
c
c     call non parametric regression estimation
      CALL GLKERN(T, X, N, TT, M, IHOM, NUE, KORD, IRND, ISMO, M1, TL,
     &            TU, dwork(pds), SIG, dwork(pdwn), dwork(pdw1), B, Y)
c
      RETURN
      END


      SUBROUTINE PCHEZ(N, X, F, D, SPLINE, WK, LWK, IERR)
      USE stel_kinds
      IMPLICIT NONE
!-----------------------------------------------
!   D u m m y   A r g u m e n t s
!-----------------------------------------------
      INTEGER :: N, LWK, IERR
      LOGICAL SPLINE
      REAL(rprec), DIMENSION(N) :: X, F, D
      REAL(rprec), DIMENSION(LWK) :: WK
!-----------------------------------------------
!   L o c a l   V a r i a b l e s
!-----------------------------------------------
      INTEGER, DIMENSION(2) :: IC
      INTEGER :: INCFD
      REAL(rprec), DIMENSION(2) :: VC
!-----------------------------------------------
!***BEGIN PROLOGUE  PCHEZ
!***DATE WRITTEN   870821   (YYMMDD)
!***REVISION DATE  870908   (YYMMDD)
!***CATEGORY NO.  E1B
!***KEYWORDS  CUBIC HERMITE MONOTONE INTERPOLATION, SPLINE
!             INTERPOLATION, EASY TO USE PIECEWISE CUBIC INTERPOLATION
!***AUTHOR  KAHANER, D.K., (NBS)
!             SCIENTIFIC COMPUTING DIVISION
!             NATIONAL BUREAU OF STANDARDS
!             GAITHERSBURG, MARYLAND 20899
!             (301) 975-3808
!***PURPOSE  Easy to USE spline or cubic Hermite interpolation.
!***DESCRIPTION
!
!          PCHEZ:  Piecewise Cubic Interpolation, Easy to Use.
!
!     From the book "Numerical Methods and Software"
!          by  D. Kahaner, C. Moler, S. Nash
!               Prentice HALL 1988
!
!     Sets derivatives for spline (two continuous derivatives) or
!     Hermite cubic (one continuous derivative) interpolation.
!     Spline interpolation is smoother, but may not "look" right IF the
!     data CONTAINS both "steep" and "flat" sections.  Hermite cubics
!     can produce a "visually pleasing" and monotone interpolant to
!     monotone data. This is an easy to USE driver for the routines
!     by F. N. Fritsch in reference (4) below. Various boundary
!     conditions are set to DEFAULT values by PCHEZ. MANY other choices
!     are available in the SUBROUTINEs PCHIC, PCHIM and PCHSP.
!
!     Use PCHEV to evaluate the resulting function and its derivative.
!
! ----------------------------------------------------------------------
!
!  Calling sequence:   CALL  PCHEZ (N, X, F, D, SPLINE, WK, LWK, IERR)
!
!     INTEGER  N, IERR,  LWK
!     REAL  X(N), F(N), D(N), WK(*)
!     LOGICAL SPLINE
!
!   Parameters:
!
!     N -- (input) number of data points.  (Error RETURN IF N.LT.2 .)
!           If N=2, simply does linear interpolation.
!
!     X -- (input) REAL array of independent variable values.  The
!           elements of X must be strictly increasing:
!                X(I-1) .LT. X(I),  I = 2(1)N.
!           (Error RETURN IF not.)
!
!     F -- (input) REAL array of dependent variable values to be inter-
!           polated.  F(I) is value corresponding to X(I).
!
!     D -- (output) REAL array of derivative values at the data points.
!
!     SPLINE -- (input) LOGICAL variable to specify IF the interpolant
!           is to be a spline with two continuous derivaties
!           (set SPLINE=.TRUE.) or a Hermite cubic interpolant with one
!           continuous derivative (set SPLINE=.FALSE.).
!        Note: If SPLINE=.TRUE. the interpolating spline satisfies the
!           DEFAULT "not-a-knot" boundary condition, with a continuous
!           third derivative at X(2) and X(N-1). See reference (3).
!              If SPLINE=.FALSE. the interpolating Hermite cubic will be
!           monotone IF the input data is monotone. Boundary conditions
!           computed from the derivative of a local quadratic unless this
!           alters monotonicity.
!
!     WK -- (scratch) REAL work array, which must be declared by the calling
!           program to be at least 2*N IF SPLINE is .TRUE. and not used
!           otherwise.
!
!     LWK -- (input) length of work array WK. (Error RETURN IF
!           LWK.LT.2*N and SPLINE is .TRUE., not checked otherwise.)
!
!     IERR -- (output) error flag.
!           Normal RETURN:
!              IERR = 0  (no errors).
!           Warning error:
!              IERR.GT.0  (can ONLY occur when SPLINE=.FALSE.) means that
!                 IERR switches in the direction of monotonicity were detected.
!                 When SPLINE=.FALSE.,  PCHEZ guarantees that IF the input
!                 data is monotone, the interpolant will be too. This warning
!                 is to alert you to the fact that the input data was not
!                 monotone.
!           "Recoverable" errors:
!              IERR = -1  IF N.LT.2 .
!              IERR = -3  IF the X-array is not strictly increasing.
!              IERR = -7  IF LWK is less than 2*N and SPLINE is .TRUE.
!             (The D-array has not been changed in any of these cases.)
!               NOTE:  The above errors are checked in the order listed,
!                   and following arguments have **NOT** been validated.
!
!----------------------------------------------------------------------
!***REFERENCES  1. F.N.FRITSCH AND R.E.CARLSON, 'MONOTONE PIECEWISE CUBIC INTERPOLATION,'
!                  SIAM J.NUMER.ANAL. 17, 2 (APRIL 1980), 238-246.
!               2. F.N.FRITSCH AND J.BUTLAND, 'A METHOD FOR CONSTRUCTING LOCAL MONOTONE PIECEWISE CUBIC INTERPOLANTS,'
!                  LLNL PREPRINT UCRL-87559 (APRIL 1982).
!               3. CARL DE BOOR, A PRACTICAL GUIDE TO SPLINES, SPRINGER-
!                 VERLAG (NEW YORK, 1978).  (ESP. CHAPTER IV, PP.49-62.)
!               4. F.N.FRITSCH, 'PIECEWISE CUBIC HERMITE INTERPOLATION PACKAGE, FINAL SPECIFICATIONS',
!                  LAWRENCE LIVERMORE NATIONAL LABORATORY, COMPUTER DOCUMENTATION UCID-30194, AUGUST 1982.
!***ROUTINES CALLED  PCHIM,PCHSP
!***END PROLOGUE  PCHEZ
!
!  DECLARE LOCAL VARIABLES.
!
      ic = 0;  incfd = 1
!
!***FIRST EXECUTABLE STATEMENT  PCHEZ
!
      IF (SPLINE) THEN
         CALL PCHSP (IC, VC, N, X, F, D, INCFD, WK, LWK, IERR)
      ELSE
         CALL PCHIM (N, X, F, D, INCFD, IERR)
      ENDIF
!
!  ERROR CONDITIONS ALREADY CHECKED IN PCHSP OR PCHIM

      RETURN
!------------- LAST LINE OF PCHEZ FOLLOWS ------------------------------
      END SUBROUTINE PCHEZ


************************************************************************
        SUBROUTINE DSSBMV(A,INDROW,INDCOL,IUPPER,NZER,TEMPB,TEMPC,
     :			  N,M,B,C)
************************************************************************
*
*	Computes the product of matrix A with a block of vectors B(N,M)
*			        C=A B
*	where A(NxN) is a Symmetric Sparse matrix. Only the nonzero
*	parts of the matrix are kept and this is managed by Indices
*
*	Subroutines called:
*	dgathr,dscatr,ddot,daxpy,dini
************************************************************************
*
	IMPLICIT DOUBLE PRECISION(A-H,O-Z)
	LOGICAL IUPPER
	DIMENSION A(NZER),INDCOL(N),INDROW(NZER)
	DIMENSION TEMPB(N),TEMPC(N)
	DIMENSION B(N*M),C(N*M)

************************************************************************
*
*   on entry
*   --------
*   N		the dimension (rank) of the matrix A
*   B	    	the matrix (block of vectors) to multiply A with
*   A		Linear array keeping the the nonzero elements of
*		the matrix A. It stores columns one after the other
*		starting from the first. It is either the upper
*		triangular part or the lower part depending on logical
*		iupper. (max elements that may contain= n^2/(2*nodes))
*   INDCOL	It is the index showing for each column where that
*		column ends in array A.
*   INDROW	It is the index showing for each element of A to its
*		row number in the square matrix
*   iupper	logical. If .true. the upper part of A is used.
*   TEMPB,TEMPC Linear scratch arrays (dim=N)
*
*   on exit
*   -------
*
*   C 		the result of the multiplication (dim=NxM)
*
************************************************************************
	IOFFS=1
	IF (IUPPER) IOFFS=0

	ISTART=1
	CALL DINIT(N*M,0.D0,C,1)

      	DO 20 ICOL=1,N
	   NUMELEM = INDCOL(ICOL)-ISTART+1
    	   ICUR=1

    	   DO 10 IV=1,M
	      CALL DGATHR(NUMELEM,B(ICUR),1,INDROW(ISTART),1,TEMPB,1)
	      CALL DGATHR(NUMELEM,C(ICUR),1,INDROW(ISTART),1,TEMPC,1)

              DIAG=C(ICUR-1+ICOL)+DDOT(NUMELEM,A(ISTART),1,TEMPB,1)
              CALL DAXPY(NUMELEM-1,B(ICUR-1+ICOL),
     :	                  A(ISTART+IOFFS),1,
     :	   		  TEMPC(IOFFS+1),1)

    	      CALL DSCATR(NUMELEM,TEMPC,1,INDROW(ISTART),1,C(ICUR),1)
	      C(ICUR-1+ICOL)=DIAG
    	      ICUR=ICUR+N
   10      CONTINUE

    	    ISTART=INDCOL(ICOL)+1
   20   CONTINUE

	RETURN
	END


      subroutine DSVA(A,MDA,M,N,MDATA,B,SING,KPVEC,NAMES,ISCALE,D,WORK)
c Copyright (c) 1996 California Institute of Technology, Pasadena, CA.
c ALL RIGHTS RESERVED.
c Based on Government Sponsored Research NAS7-03001.
c>> 1996-05-10 DSVA Krogh  Only "*" output on C version.
c>> 1995-11-15 DSVA Krogh  Moved formats up for C conversion.
C>> 1994-10-20 DSVA Krogh  Changes to use M77CON
C>> 1992-04-23 DSVA CLL Replaced Hollerith with '...' in a FORMAT.
C>> 1992-03-18 CLL New treatment of WIDTH and length of labeling names.
C>> 1989-11-21 CLL Fixed bug that caused divide by 0 when M < N.
C>> 1989-03-07 DSVA   CLL Changed logical PRINT to integer vector KPVEC.
C>> 1988-12-01 DSVA   CLL Added PRINT into arg list.
C>> 1987-11-24 DSVA   Lawson  Initial code.
c
C     Singular Value Analysis.  Computes the singular value
c     decomposition of the matrix of a least squares problem, and
c     produces a printed report.
c     ------------------------------------------------------------------
c                         Subroutine Arguments
c     A(,)     [inout]  On entry, contains the M x N matrix of the least
c              squares problem to be analyzed.  This could be a matrix
c              obtained by preliminary orthogonal transformations
c              applied to the actual problem matrix which may have had
c              more rows (See MDATA below.)
c
c     MDA   [in]  First dimensioning parameter for A(,).  Require
c              MDA .ge. max(M, N).
c
c     M,N   [in]  No. of rows and columns, respectively, in the
c              matrix, A.  Either M > N or M .le. N is permitted.
c              Require M > 0 and N > 0.
c
c     MDATA [in]  No. of rows in actual least squares problem.
c              Generally MDATA .ge. M.  MDATA is used only in computing
c              statistics for the report and is not used as a loop
c              count or array dimension.
c
c     B()   [inout]  On entry, contains the right-side vector, b, of the
c              least squares problem.  This vector is of length, M.
c              On return, contains the vector, g = (U**t)*b, where U
c              comes from the singular value decomposition of A.  The
c              vector , g, is also of length M.
c
c     SING()   [out] On return, contains the singular values of A, in
c              descending order, in locations indexed 1 thru min(M,N).
c
c     KPVEC()  [integer array, in]  Array of integers to select print
c              options.  KPVEC(1) determines whether the rest of
c              the array is to be used or ignored.
c              If KPVEC(1) = 1, the contents of (KPVEC(I), I=2,4)
c              will be used to set internal variables as follows:
c                       PRBLK = KPVEC(2)
c                       UNIT  = KPVEC(3)
c                       WIDTH = KPVEC(4)
c              If KPVEC(1) = 0 default settings will be used.  The user
c              need not dimension KPVEC() greater than 1.  The subr will
c              set PRBLK = 111111, UNIT = -1, and WIDTH = 69.
c
c              The internal variables PRBLK, UNIT, and WIDTH are
c              interpreted as follows:
c
c              PRBLK    The decimal representation of PRBLK must be
c              representable as at most 6 digits, each being 0 or 1.
c              The decimal digits will be interpreted as independant
c              on/off flags for the 6 possible blocks of printed output.
c              Examples:  111111 selects all blocks, 0 suppresses all
c              printing,  101010 selects the 1st, 3rd, and 5th blocks,
c              etc.
c              The six blocks are:
c              1. Header, with size and scaling option parameters.
c              2. V-matrix.  Amount of output depends on M and N.
c              3. Singular values and related quantities.  Amount of
c                 output depends on N.
c              4. Listing of YNORM and RNORM and their logarithms.
c                 Amount of output depends on N.
c              5. Levenberg-Marquart analysis.
c              6. Candidate solutions.  Amount of output depends on
c                 M and N.
c
c              UNIT     Selects the output unit.  If UNIT .ge. 0,
c              UNIT will be used as the output unit number.
c              If UNIT = -1, output will be written to the "*" output
c              unit, i.e., the standard system output unit.
c              The calling program unit is responsible for opening
c              and/or closing the selected output unit if the host
c              system requires these actions.
c
c        WIDTH    Default value is 79.  Determines the width of
c        blocks 2, 3, and 6 of the output report.
c        Block 3 will use 95(+1) cols if WIDTH .ge. 95, and otherwise
c        69(+1) cols.
c        Blocks 2 and 6 are printed by subroutine DPRTSV.  These blocks
c        generally use at most WIDTH(+1) cols, but will use more if
c        the names are so long that more space is needed to print one
c        name and one numeric column.  The (+1)'s above are reminders
c        that in all cases there is one extra initial column for Fortran
c        "carriage control".  The carriage control character will always
c        be a blank.
c        Blocks 1, 4, and 5 have fixed widths of 63(+1), 66(+1) and
c        66(+1), respectively.
c
c     NAMES()  [in]  NAMES(j), for j = 1, ..., N, may contain a
c              name for the jth component of the solution
c              vector.  The declared length of the elements of the
c              NAMES() array is not specifically limited, but a
c              greater length reduces the space available for columns
c              of the matris to be printed.
c              If NAMES(1) contains only blank characters,
c              it will be assumed that no names have been provided,
c              and this subr will not access the NAMES() array beyond
c              the first element.
C
C     ISCALE   [in]  Set by the user to 1, 2, or 3 to select the column
c              scaling option.
C                  1   SUBR WILL USE IDENTITY SCALING AND IGNORE THE D()
C                      ARRAY.
C                  2   SUBR WILL SCALE NONZERO COLS TO HAVE UNIT EUCLID-
C                      EAN LENGTH AND WILL STORE RECIPROCAL LENGTHS OF
C                      ORIGINAL NONZERO COLS IN D().
C                  3   USER SUPPLIES COL SCALE FACTORS IN D(). SUBR
C                      WILL MULT COL J BY D(J) AND REMOVE THE SCALING
C                      FROM THE SOLN AT THE END.
c
c     D()   [ignored or out or in]  Usage of D() depends on ISCALE as
c              described above.  When used, its length must be
c              at least N.
c
c     WORK()   [scratch]   Work space of length at least 2*N.  Used
c              directly in this subr and also in _SVDRS.
c     ------------------------------------------------------------------
c--D replaces "?": ?SVA, ?SVDRS, ?PRTSV
c     ------------------------------------------------------------------
c          This code was originally developed by Charles L. Lawson and
c     Richard J. Hanson at Jet Propulsion Laboratory in 1973.  The
c     original code was described and listed in the book,
c
c                  Solving Least Squares Problems
c                  C. L. Lawson and R. J. Hanson
c                  Prentice-Hall, 1974
c
c     Feb 1985, Mar 1987, C. L. Lawson & S. Y. Chiu, JPL.
c     Adapted code from the Lawson & Hanson book to Fortran 77 for use
c     in the JPL MATH77 library.
c     Prefixing subprogram names with S or D for s.p. or d.p. versions.
c     Using generic names for intrinsic functions.
c     Adding calls to BLAS and MATH77 error processing subrs in some
c     program units.
c     Dec 1988 CLL.  For MATH77 this subr was intended to have PRINT in
c     the arg list, and was described that way in the MATH77 manual, but
c     PRINT was omitted in the code.  Now fixing this at Rel. 2.2 by
c     adding PRINT to the arg list.
c     Dec 1988 CLL.  Also for MATH77 the WORK() array was introduced.
c     Previous version used a long SING() array for work space.  WORK()
c     was introduced incorrectly in the S.P. version.  Now correcting
c     this and using the processor CHGTYP to keep the S.P. and D.P.
c     versions similar.
c     1989-03-07 CLL>  Changing the logical PRINT to an integer vector
c     KPVEC().  Giving user control of quantity, destination, and
c     line width of output.
c     ------------------------------------------------------------------
      integer I, IE, IPASS, ISCALE, J, K, KPVEC(4), M, MDA, MDATA
      integer MINMN, MINMN1, MPASS, N, NSOL
      integer PRBLK, UNIT, WIDTH
      double precision A(MDA,N), A1, A2, A3, A4, ALAMB, ALN10, B(M)
      double precision D(N), DEL, DENOM, EL, EL2
      double precision ONE, PCOEF, RL, RNORM, RS
      double precision SB, SING(N), SL, TEMP, TEN, THOU, TWENTY
      double precision WORK(2*N), YL, YNORM, YS, YSQ, ZERO
      character*(*) NAMES(N)
      logical BLK(6), NARROW
c++ CODE for ~.C. is active
      logical STAR
c++ END
C
      parameter( ZERO = 0.0D0, ONE = 1.0D0)
      parameter( TEN = 10.0D0, TWENTY = 20.0D0, THOU = 1000.0D0)
c     -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  220 FORMAT (1X/' INDEX  SING. VAL.    P COEF   ',
     *        '   RECIPROCAL    G COEF         G**2   ',
     *        '   CUMULATIVE  SCALED SQRT'/
     *    31x,'   SING. VAL.',26x,
     *        '  SUM of SQRS  of CUM.S.S.')
  221 FORMAT (1X/' INDEX  SING. VAL.    P COEF   ',
     *        '   RECIPROCAL    G COEF     SCALED SQRT'/
     *    31x,'   SING. VAL.',13x,'  of CUM.S.S.')
  222 FORMAT (1X/' INDEX  SING. VAL.    G COEF         G**2   ',
     *        '   CUMULATIVE  SCALED SQRT'/
     *    44x,'  SUM of SQRS  of CUM.S.S.')

  230 FORMAT (' ',4X,'0',64X,2g13.4)
  231 FORMAT (' ',4X,'0',51X, g13.4)
  232 FORMAT (' ',4X,'0',38X,2g13.4)

  240 FORMAT (' ',i5,g12.4,6g13.4)

  260 FORMAT (1X,' M  = ',I6,',   N  =',I4,',   MDATA  =',I8)
  270 FORMAT (1X/' Singular Value Analysis of the least squares',
     *        ' problem,  A*X = B,'/
     *        ' scaled as (A*D)*Y = B.')
  280 FORMAT (1X/' Scaling option No.',I2,'.  D is a diagonal',
     * ' matrix with the following diagonal elements..'/(5X,10E12.4))
  290 FORMAT (1X/' Scaling option No. 1.   D is the identity matrix.'/
     * 1X)
  300 FORMAT (1X/' INDEX',12X,'YNORM      RNORM',11X,
     * '      LOG10      LOG10'/
     * 45X,'      YNORM      RNORM'/1X)
  310 FORMAT (' ',I5,6X,2E11.3,11X,2F11.3)
  320 FORMAT (1X/
     *' Norms of solution and residual vectors for a range of values'/
     *' of the Levenberg-Marquardt parameter, LAMBDA.'//
     *        '      LAMBDA      YNORM      RNORM',
     *         '      LOG10      LOG10      LOG10'/
     *     34X,'     LAMBDA      YNORM      RNORM')
  330 FORMAT (1X, 3E11.3, 3F11.3)
c     ------------------------------------------------------------------
      IF (M.LE.0 .OR. N.LE.0) RETURN
      MINMN = MIN(M,N)
      MINMN1 = MINMN + 1
      if(KPVEC(1) .eq. 0) then
         PRBLK = 111111
         UNIT = -1
         WIDTH = 79
      else
         PRBLK = KPVEC(2)
         UNIT = KPVEC(3)
         WIDTH = KPVEC(4)
      endif
c++ CODE for ~.C. is active
      STAR = UNIT .lt. 0
c++ END
c                           Build logical array BLK() by testing
c                           decimal digits of PRBLK.
      do 20 I=6, 1, -1
         J = PRBLK/10
         BLK(I) = (PRBLK - 10*J) .gt. 0
         PRBLK = J
   20 continue
c     -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
c                         Optionally print header and M, N, MDATA
      if(BLK(1)) then
c++ CODE for ~.C. is active
         if(STAR) then
c++ END
            write (*,270)
            write (*,260) M,N,MDATA
c++ CODE for ~.C. is active
         else
            write (UNIT,270)
            write (UNIT,260) M,N,MDATA
         endif
c++ END
      endif
c     -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
c                                  Handle scaling as selected by ISCALE.
      if( ISCALE .eq. 1) then
         if(BLK(1)) then
c++ CODE for ~.C. is active
            if(STAR) then
c++ END
               write (*,290)
c++ CODE for ~.C. is active
            else
               write (UNIT,290)
            endif
c++ END
         endif
      else
C
C                                  Apply column scaling to A.
C
         DO 52 J = 1,N
            A1 = D(J)
            if( ISCALE .le. 2) then
               SB = ZERO
               DO 30 I = 1,M
   30             SB = SB + A(I,J)**2
               A1 = sqrt(SB)
               IF (A1.EQ.ZERO) A1 = ONE
               A1 = ONE/A1
               D(J) = A1
            endif
            DO 50 I = 1,M
               A(I,J) = A(I,J)*A1
   50       continue
   52    continue
         if(BLK(1)) then
c++ CODE for ~.C. is active
            if(STAR) then
c++ END
               write (*,280) ISCALE,(D(J),J = 1,N)
c++ CODE for ~.C. is active
            else
               write (UNIT,280) ISCALE,(D(J),J = 1,N)
            endif
c++ END
         endif
      endif
c     -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
C         Compute the Singular Value Decomposition of the scaled matrix.
C
      call DSVDRS (A,MDA,M,N,B,M,1,SING,WORK)
c
c                                               Determine NSOL.
      NSOL = MINMN
      do 60 J = 1,MINMN
         if(SING(J) .eq. ZERO) then
            NSOL = J-1
            go to 65
         endif
   60 continue
   65 continue
C
c              The array B() contains the vector G.
C              Compute cumulative sums of squares of components of
C              G and store them in WORK(I), I = 1,...,MINMN+1
C
      SB = ZERO
      DO 70 I = MINMN1,M
         SB = SB + B(I)**2
   70 CONTINUE
      WORK(MINMN+1) = SB
      DO  75 J = MINMN, 1, -1
         SB = SB + B(J)**2
         WORK(J) = SB
   75 CONTINUE
c     -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
C                                          PRINT THE V MATRIX.
C
      if(BLK(2)) CALL DPRTSV (A,MDA,N,N,NAMES,1, UNIT, WIDTH)
c     -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
C                                REPLACE V BY D*V IN THE ARRAY A()
      if (ISCALE .gt.1) then
         do 82 I = 1,N
            do 80 J = 1,N
               A(I,J) = D(I)*A(I,J)
   80       continue
   82    continue
      endif
c     -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
      if(BLK(3)) then
c                     Print singular values and other summary results.
c
c     Output will be done using one of two layouts.  The narrow
c     layout uses 69 cols + 1 for carriage control, and makes two passes
c     through the computation.
c     The wide layout uses 95 cols + 1 for carriage control, and makes
c     only one pass through the computation.
c
C                       G  NOW IN  B() ARRAY.  V NOW IN A(,) ARRAY.
C
      NARROW = WIDTH .lt. 95
      MPASS = 1
      if(NARROW) MPASS = 2
      do 170 IPASS = 1, MPASS
c++ CODE for ~.C. is active
         if(STAR) then
c++ END
            if(NARROW) then
               if(IPASS .eq. 1) then
                  write(*,221)
               else
                  write(*,222)
               endif
            else
               write (*,220)
            endif
c++ CODE for ~.C. is active
         else
            if(NARROW) then
               if(IPASS .eq. 1) then
                  write(UNIT,221)
               else
                  write(UNIT,222)
               endif
            else
               write (UNIT,220)
            endif
         endif
c++ END
c                               The following stmt converts from
c                               integer to floating-point.
      DENOM = max(1,MDATA)
      A3 = WORK(1)
      A4 = sqrt(A3/ DENOM  )
c++ CODE for ~.C. is active
      if(STAR) then
c++ END
         if(NARROW) then
            if(IPASS .eq. 1) then
               write(*,231) A4
            else
               write(*,232) A3, A4
            endif
         else
            write (*,230) A3,A4
         endif
c++ CODE for ~.C. is active
      else
         if(NARROW) then
            if(IPASS .eq. 1) then
               write(UNIT,231) A4
            else
               write(UNIT,232) A3, A4
            endif
         else
            write (UNIT,230) A3,A4
         endif
      endif
c++ END
C
      DO 160 K = 1,MINMN
         if (SING(K).EQ.ZERO) then
            PCOEF = ZERO
c++ CODE for ~.C. is active
            if(STAR) then
c++ END
               write (*,240) K,SING(K)
c++ CODE for ~.C. is active
            else
               write (UNIT,240) K,SING(K)
            endif
c++ END
         else
            PCOEF = B(K) / SING(K)
            A1 = ONE / SING(K)
            A2 = B(K)**2
            A3 = WORK(K+1)
c                                 The following stmt converts from
c                                 integer to floating-point.
            TEMP = MAX(1,MDATA-K)
            A4 = sqrt(A3/TEMP )
c++ CODE for ~.C. is active
            if(STAR) then
c++ END
               if(NARROW) then
                  if(IPASS .eq. 1) then
                     write(*,240) K,SING(K),PCOEF,A1,B(K),      A4
                  else
                     write(*,240) K,SING(K),         B(K),A2,A3,A4
                  endif
               else
                  write (*,240) K,SING(K),PCOEF,A1,B(K),A2,A3,A4
               endif
c++ CODE for ~.C. is active
            else
               if(NARROW) then
                  if(IPASS .eq. 1) then
                     write(UNIT,240) K,SING(K),PCOEF,A1,B(K),      A4
                  else
                     write(UNIT,240) K,SING(K),         B(K),A2,A3,A4
                  endif
               else
                  write (UNIT,240) K,SING(K),PCOEF,A1,B(K),A2,A3,A4
               endif

            endif
c++ END
         endif
  160 continue
  170 continue
      endif
c     -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
      if( BLK(4) ) then
C
C         Compute and print values of YNORM, RNORM and their logarithms.
C
c++ CODE for ~.C. is active
      if(STAR) then
c++ END
         write (*,300)
c++ CODE for ~.C. is active
      else
         write (UNIT,300)
      endif
c++ END
      YSQ = ZERO
      do 180 J = 0, NSOL
         if(J .ne. 0) YSQ = YSQ + (B(J) / SING(J))**2
         YNORM = sqrt(YSQ)
      RNORM = sqrt(WORK(J+1))
      YL = -THOU
      IF (YNORM .GT. ZERO) YL = LOG10(YNORM)
      RL = -THOU
      IF (RNORM .GT. ZERO) RL = LOG10(RNORM)
c++ CODE for ~.C. is active
      if(STAR) then
c++ END
         write (*,310) J,YNORM,RNORM,YL,RL
c++ CODE for ~.C. is active
      else
         write (UNIT,310) J,YNORM,RNORM,YL,RL
      endif
c++ END
  180 continue
      endif
c     -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
      if( BLK(5) .and. SING(1) .ne. ZERO ) then
C
C     COMPUTE VALUES OF XNORM AND RNORM FOR A SEQUENCE OF VALUES OF
C     THE LEVENBERG-MARQUARDT PARAMETER.
C
         EL = LOG10(SING(1)) + ONE
         EL2 = LOG10(SING(NSOL)) - ONE
         DEL = (EL2-EL) / TWENTY
         ALN10 = LOG(TEN)
c++ CODE for ~.C. is active
         if(STAR) then
c++ END
            write (*,320)
c++ CODE for ~.C. is active
         else
            write (UNIT,320)
         endif
c++ END
         DO 200 IE = 1,21
C                                    COMPUTE        ALAMB = 10.0**EL
            ALAMB = EXP(ALN10*EL)
            YS = ZERO
            RS = WORK(NSOL+1)
            DO 190 I = 1,MINMN
               SL = SING(I)**2 + ALAMB**2
               YS = YS + (B(I)*SING(I)/SL)**2
               RS = RS + (B(I)*(ALAMB**2)/SL)**2
  190       CONTINUE
            YNORM = sqrt(YS)
            RNORM = sqrt(RS)
            RL = -THOU
            IF (RNORM.GT.ZERO) RL = LOG10(RNORM)
            YL = -THOU
            IF (YNORM.GT.ZERO) YL = LOG10(YNORM)
c++ CODE for ~.C. is active
            if(STAR) then
c++ END
               write (*,330) ALAMB,YNORM,RNORM,EL,YL,RL
c++ CODE for ~.C. is active
            else
               write (UNIT,330) ALAMB,YNORM,RNORM,EL,YL,RL
            endif
c++ END
            EL = EL + DEL
  200    CONTINUE
      endif
c     -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
C                   Compute and optionally print candidate solutions.
C
      do 215 K = 1,NSOL
         PCOEF = B(K) / SING(K)
         DO 210 I = 1,N
                A(I,K) = A(I,K) * PCOEF
  210           IF (K.GT.1) A(I,K) = A(I,K) + A(I,K-1)
  215 continue
      if (BLK(6) .and. NSOL.GE.1)
     *       CALL DPRTSV (A,MDA,N,NSOL,NAMES,2,UNIT,WIDTH)
      return
      END


!==============================================================================!
  subroutine Field_Mod_Grad_Pressure(flow,     &
                                     p,        &
                                     density,  &
                                     grav_x, grav_y, grav_z)
!------------------------------------------------------------------------------!
!   Calculates gradient of pressure of pressure correction.
!------------------------------------------------------------------------------!
  implicit none
!---------------------------------[Arguments]----------------------------------!
  type(Field_Type) :: flow
  type(Var_Type)   :: p
  real             :: density(-p % pnt_grid % n_bnd_cells:p % pnt_grid % n_cells)
  real             :: grav_x, grav_y, grav_z
!-----------------------------------[Locals]-----------------------------------!
  type(Grid_Type), pointer :: grid
  integer                  :: s, c, c1, c2, iter
!==============================================================================!

  ! Take aliases
  grid => flow % pnt_grid

  call Grid_Mod_Exchange_Real(grid, p % n)

  do s = 1, grid % n_faces
    c1 = grid % faces_c(1,s)
    c2 = grid % faces_c(2,s)
    if(c2 < 0) then
      if(Grid_Mod_Bnd_Cond_Type(grid,c2) .ne. PRESSURE) then
        p % n(c2) = p % n(c1) + dot_product( (/p % x(c1),        &
                                               p % y(c1),        &
                                               p % z(c1)/) ,     &
                                             (/grid % dx(s),     &
                                               grid % dy(s),     &
                                               grid % dz(s)/) )
      end if
    end if
  end do

  call Field_Mod_Grad_Component(flow, p % n, 1, p % x)  ! dp/dx
  call Field_Mod_Grad_Component(flow, p % n, 2, p % y)  ! dp/dy
  call Field_Mod_Grad_Component(flow, p % n, 3, p % z)  ! dp/dz

  end subroutine


      USE PRIMEBAG	!Gain access to NEXTPRIME and ISPRIME.
Calculates the largest "left-truncatable" digit sequence that is a prime number, in various bases.
      INTEGER LBASE,MANY,ENUFF	!Some sizes.
      PARAMETER (LBASE = 13, MANY = 66666, ENUFF = 66)
      INTEGER NS,START(LBASE)	!A list of single-digit prime numbers for starters.
      INTEGER NH,LH		!Counters for the horde.
      INTEGER N,HORDEN(MANY)		!Numerical value of a digit sequence.
      INTEGER*1 HORDED(ENUFF,MANY)	!Single-digit values only.
      INTEGER B,D,DB	!The base, a digit, some power of the base.
      INTEGER L		!The length of the digit sequence: DB = B**L.
      INTEGER P		!Possibly a prime number.
      INTEGER I		!A stepper.

      MSG = 6	!I/O unit number for "standard output".
      IF (.NOT.GRASPPRIMEBAG(66)) STOP "Gan't grab my file!"	!Attempt in hope.
      NS = 0	!No starters.
      P = 1	!Start looking for some primes.
    1 P = NEXTPRIME(P)	!Thus skipping non-primes.
      IF (P.LE.LBASE) THEN	!Beyond the limit?
        NS = NS + 1		!No. Count another starter.
        START(NS) = P		!Save its value.
        GO TO 1			!And seek further.
      END IF		!One could insted prepare some values, the primes being well-known.
      WRITE (MSG,2) LBASE,NS,START(1:NS)	!But, parameterisation is easy enough.
    2 FORMAT ("Working in bases 3 to ",I0," there are ",I0,	!Announce the known.
     * " single-digit primes: ",666(I0:", "))	!The : sez stop if the list is exhausted.
      WRITE (MSG,3)		!Produce a heading for the tabular output.
    3 FORMAT (/"Base Digits Count Max. Value = (in base)")

   10 DO B = 3,LBASE	!Work through the bases.
        NH = 0			!The horde is empty.
        DO I = 1,NS		!Prepare the starters for base B.
          IF (START(I).GE.B) EXIT	!Like, they're single-digits in base B.
          NH = NH + 1			!So, count another in.
          HORDEN(NH) = START(I)		!Its numerical value.
          HORDED(1,NH) = START(I)	!Its digits. Just one.
        END DO			!On to the next single-digit prime number.
        L = 0	!Syncopation. The length of the digit sequences.
        DB = 1	!The power for the incoming digit.

   20   L = L + 1	!We're about to add another digit.
        IF (L.GE.ENUFF) STOP "Too many digits!"	!Hopefully, there's room.
        DB = DB*B	!The new power of B.
        IF (DB.LE.0) GO TO 29	!Integer overflow?
        LH = NH		!The live ones, awaiting extension.
        DO I = 1,LH	!Step through each starter.
          N = HORDEN(I)	!Grab its numerical value.
          DO D = 1,B - 1	!Consider all possible lead digits.
            P = D*DB + N		!Place it at the start of the number.
            IF (P.LE.0) GO TO 29	!Oh for IF OVERFLOW ...
            IF (ISPRIME(P)) THEN	!And if it is a prime,
              IF (NH.GE.MANY) STOP "Too many sequences!"	!Add a sequence.
              NH = NH + 1			!Count in a survivor.
              HORDEN(NH) = P			!The numerical value.
              HORDED(1:L,NH) = HORDED(1:L,I)	!The digits.
              HORDED(L + 1,NH) = D		!Plus the added high-order digit.
            END IF			!So much for persistent primality.
          END DO		!On to the next lead digit.
        END DO	!On to the next starter.

        N = NH - LH		!The number of entries added to the horde.
        IF (N.GT.0) THEN	!Were there any?
          DO I = 1,MIN(LH,N)		!Yes. Overwrite the starters.
            HORDEN(I) = HORDEN(NH)		!From the tail end of the horde.
            HORDED(1:L + 1,I) = HORDED(1:L + 1,NH)	!Digit sequences as well.
            NH = NH - 1				!One snipped off.
          END DO			!Thus fill the gap at the start.
          NH = N			!The new horde count.
          LH = NH			!All are starters for the next level.
          GO TO 20			!See how it goes.
        END IF			!So much for further progress.
        GO TO 30		!But if none, done.
   29   WRITE (MSG,28) B,L,NH,DB,P	!Curses. Offer some details.
   28   FORMAT (I4,I7,I6,28X,"Integer overflow!",2I12)
        CYCLE			!Or, GO TO the end of the loop.

   30   I = MAXLOC(HORDEN(1:NH),DIM = 1)	!Finger the mostest number.
        WRITE (MSG,31) B,L,NH,HORDEN(I),HORDED(L:1:-1,I)	!Results!
   31   FORMAT (I4,I7,I6,I11," = "666(I0:"."))	!See Format 3.

      END DO		!On to the next base.
      END	!Simple enough.


C++**********************************************************************
C SP_SHIFT
C  To process radio HI spectra from PARKES (Observations from Nov. 1989)
C  Shift and add a series of spectra (with weight)
C
C JLP
C Version of 05-10-90
C--**********************************************************************
	PROGRAM SP_SHIFT
	PARAMETER (IDIM=512)
	REAL*4 X1(IDIM),Y1(IDIM),Y2(IDIM),VELO(IDIM),SPECT(IDIM)
	REAL*4 VLIGHT,CVELOCITY,VSTEP,VAL
	INTEGER*4 NPTS
	LOGICAL QUIET,SMOOTH
	CHARACTER ANS*1,INFILE*40,OUTFILE*40,COMMENTS*80,BUFFER*80
	CHARACTER TITLE*40,PLOTDEV*32,ANSWER*1

10	FORMAT(A)

	CALL JLP_BEGIN

	WRITE(6,63)
63	FORMAT(' Program SP_SHIFT Version 07-09-90',/,
     1	' To shift and add spectra from Parkes')

	NPTS=256

C Number of files:
	WRITE(6,*) ' Number of spectra ? (>=1)'
	READ(5,*) NFILES

	WRITE(6,*) ' Hanning smoothing (3rd order)? [Y]'
	READ(5,10) ANS
	SMOOTH=(ANS.NE.'N'.AND.ANS.NE.'n')

C Input file (First one is the reference...)
78	WRITE(6,*) ' Input ASCII file (The first one is the reference...)?'
	READ(5,10) INFILE

	OPEN(1,FILE=INFILE,STATUS='OLD',ACCESS='SEQUENTIAL')
	READ(1,10) BUFFER
	READ(BUFFER,*) X1(1),Y1(1)
	COMMENTS=BUFFER(27:80)
	  DO I=2,NPTS
	   READ(1,*) X1(I),Y1(I)
	  END DO
	CLOSE(1)

	CVELOCITY=X1(128)
	WRITE(6,28) COMMENTS(1:53),CVELOCITY
28	FORMAT(' Comments: ',A53,/,' Central velocity:',G12.3)

* Weighting factor:
	WRITE(6,*) ' Weight for the sum (1.?)'
	READ(5,*) WEIGHT

* Transfer:
	DO I=1,NPTS
	  VELO(I)=X1(I)
	  SPECT(I)=Y1(I)*WEIGHT
	END DO

* Main loop:
	DO K=1,NFILES-1

C Input file (First one is the reference...)
	  WRITE(6,*) ' Input ASCII file (spectrum to shift)?'
	  READ(5,10) INFILE

	  OPEN(1,FILE=INFILE,STATUS='OLD',ACCESS='SEQUENTIAL')
	  READ(1,10) BUFFER
	  READ(BUFFER,*) X1(1),Y1(1)
	    DO I=2,NPTS
	      READ(1,*) X1(I),Y1(I)
	    END DO
	  CLOSE(1)
	  WRITE(6,28) BUFFER(27:80),X1(128)

* Weighting factor:
	  WRITE(6,*) ' Weight for the sum (1.?)'
	  READ(5,*) WEIGHT

	  SHIFT=(X1(128)-CVELOCITY)/(X1(127)-X1(128))
	  WRITE(6,*) ' Shifting value (pixels):',SHIFT
	  CALL SHIFTSP(Y1,Y2,SHIFT,NPTS)

* Transfer:
	  DO I=1,NPTS
	    SPECT(I)=SPECT(I)+Y2(I)*WEIGHT
	  END DO

	END DO

* Hanning smoothing:
	DO I=2,NPTS-1
	  VAL=SPECT(I-1)+2.*SPECT(I)+SPECT(I+1)
	  SPECT(I)=VAL/4.
	END DO

* Write the output spectrum as an ASCII file:
* with some comments on the first line, after the data:
	PRINT *,' Output ASCII file (spectrum) ?'
	READ(5,10) OUTFILE
	OPEN(2,FILE=OUTFILE,STATUS='NEW',ACCESS='SEQUENTIAL')
	WRITE(2,66) VELO(1),SPECT(1),COMMENTS(1:18),CVELOCITY
66	FORMAT(2(X,G14.7),' ',A,' CVEL:',F9.2)
	DO I=2,NPTS
	  WRITE(2,*) VELO(I),SPECT(I)
	END DO
	CLOSE(2)

	CALL JLP_END
	STOP
	END
C@**********************************************************************
C REBINX
C@**********************************************************************

	subroutine rebinx(input1,npixa,invala,invalb,minx,maxx,
     1	c,scale,mode,output1,npixb,ierr)

*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
*purpose
*       to resample a spectrum at positions given by a linear
*       transformation of the output pixel positions
*
*method
*       scan the output image, transforming the pixel positions.
*       interpolate in the input image to determine the image value
*       at these points. the routine uses nearest-neighbour or linear
*       interpolation between the 4 nearest pixels
*
*arguments
*       input1 (in)
*       real*4(idim)     (npixa)
*               the input spectrum
*       npixa (in)
*       integer
*               the dimensions of input
*       invala (in)
*       integer
*               invalid pixel flag for input
*       invalb (in)
*       integer
*               invalid pixel flag for output1
*       minx,maxx (in)
*       integer
*               range of output pixels to be replaced
*       c (in)
*       real(6)
*               coefficients giving the transformation from output
*               positions to input positions
*       scale (out)
*       real
*               scale factor which is needed if total image intensity
*               is to be conserved
*       mode (in)
*       integer
*               type of interpolation
*               1: nearest neighbour
*               2: linear
*               3: constant noise
*       output1 (in/out)
*       real*4(idim)     (npixb)
*               output image
*       npixb (in)
*       integer
*               dimensions of output1
*       ierr (out)
*       integer
*               error flag: zero for success
*
*written by
*       r.f. warren-smith
*-----------------------------------------------------------------------
*
	PARAMETER (IDIM=600)
	REAL*4 INPUT1(IDIM),OUTPUT1(IDIM)
	INTEGER XMIN,XMAX,X,XCEN
	REAL C(2),WX(-1:+1)

*
* SET UP WEIGHT ARRAYS FOR CONSTANT NOISE INTERPOLATION
*
	DATA WX(0)/1.0/

*
* CHECK ARGUMENT VALIDITY
*

	IF(MINX.GT.MAXX) THEN
	   IERR=1

	ELSE
	   IERR=0

*
* Restrict max and min x limits to lie in output image
*
	   XMIN=MIN(MAX(1,MINX),NPIXB)
	   XMAX=MIN(MAX(1,MAXX),NPIXB)

*
* Restrict interpolation method to be 1 to 3
*
	   METHOD=MIN(MAX(1,MODE),3)

*
* Scale factor to conserve counts is (abs. value of determinant)
*
	   SCALE=ABS(C(2))

*
* Scan the selected area of the output image (location x) and
* calculate the transformed position (xdash) in the input
* image
*
	      XREF=C(1)

	      DO 11 X=XMIN,XMAX
	 	  XDASH=XREF+C(2)*X
*
* find nearest pixel location
*
	         XCEN=NINT(XDASH)

*
* if nearest pixel lies outside input image, output pixel is invalid
* otherwise continue with interpolation
*

	         IF((XCEN.LT.1).OR.(XCEN.GT.NPIXA)) THEN
	            OUTPUT1(X)=INVALB

	         ELSE

*
* for nearest-neighbour interpolation, output pixel=nearest pixel,
* -----------------------------------
* or is invalid if input pixel is invalid
*

           IF(METHOD.EQ.1) THEN

               IF(INPUT1(XCEN).EQ.INVALA) THEN
                  OUTPUT1(X)=INVALB

               ELSE
                  OUTPUT1(X)=INPUT1(XCEN)
               ENDIF

*
* for linear interpolation, output pixel is invalid if nearest input
* ------------------------
* pixel is invalid. otherwise continue with interpolation
*

        ELSE IF(METHOD.EQ.2) THEN

           IF(INPUT1(XCEN).EQ.INVALA) THEN
              OUTPUT1(X)=INVALB

           ELSE

*
* find shift from next lowest pixel,line location
*
              I=XDASH
              DX=XDASH-I
*
* initiallise sums for forming weighted mean
*
              SUM=0.0
              WTSUM=0.0
*
* form weighted mean of adjacent 4 pixels, checking that each lies
* within the input image and is not invalid
*
                IF(I.GE.1) THEN

                   IF(INPUT1(I).NE.INVALA) THEN
*
* weight is calculated from the x shift from integer pixel locations
*
                      WT=(1.0-DX)*(1.0-DY)
                      SUM=SUM+INPUT1(I)*WT
                      WTSUM=WTSUM+WT
                   ENDIF
                ENDIF

               IF(I+1.LE.NPIXA) THEN

                   IF(INPUT1(I+1).NE.INVALA) THEN
                        WT=DX*(1.0-DY)
                        SUM=SUM+INPUT1(I+1)*WT
                        WTSUM=WTSUM+WT
                   ENDIF
              ENDIF

*
* assign weighted mean to output pixel (wtsum cannot be zero, since
* at least 1 input pixel must be valid)
*
              OUTPUT1(X)=SUM/WTSUM
        ENDIF

*
* for constant noise interpolation (output noise independent of
* --------------------------------
* resampling phase)
*

        ELSE IF(METHOD.EQ.3) THEN

*
* if nearest pixel is invalid, so is output pixel. otherwise continue
* with interpolation
*

            IF(INPUT1(XCEN).EQ.INVALA) THEN
                 OUTPUT1(X)=INVALB

            ELSE

*
* calculate the shift from the nearest pixel,line position
*
                DX=XDASH-XCEN

*
* calculate the x and y weight arrays (dependent on the phase dx,dy)
*
                R1=DX*DX+0.25
                WX(-1)=R1-DX
                WX(1)=R1+DX

*
* now scan the 9 nearest pixels, forming a weighted sum of all the
* valid ones
*
                SUM=0.0
                WTSUM=0.0

*
* check we are still in the image
*
                DO 21 ISHIFT=-1,1
                    II=XCEN+ISHIFT
                    IF(II.GE.1.AND.II.LE.NPIXA) THEN
*
* include the pixel if it is valid
*
                         IF(INPUT1(II).NE.INVALA) THEN
                               WT=WX(ISHIFT)
                               SUM=SUM+INPUT1(II)*WT
                               WTSUM=WTSUM+WT
                         ENDIF
                    ENDIF

21             CONTINUE

*
* assign the interpolated value to the output pixel
*
                OUTPUT1(X)=SUM/WTSUM
              ENDIF

            ENDIF
          ENDIF

11	CONTINUE

12	CONTINUE

	ENDIF

	RETURN

	END

C**********************************************************************
C Subroutine SHIFTSP
C To shift one spectrum of a given quantity
C (Interface with REBIN)
C**********************************************************************
	SUBROUTINE SHIFTSP(INPUT,OUTPUT,SHIFT,NPTS)
	REAL*4 INPUT(*),OUTPUT(*)
	REAL*4 SHIFT,C(2)
	INTEGER*4 NPTS,METHOD
	LOGICAL CONSRV

*
* Input image sucessfully obtained...
* obtain position transformation coefficients
*
*   Xnew  is  C * Xold

	C(1)=SHIFT
	C(2)=1.
*
* Obtain type of interpolation required (2=linear)
*
	 METHOD=2
*
* Determine if total data count is to be conserved
*
	 CONSRV=.FALSE.
*
* Obtain size of output image, using input size as default
*
	 NPIX=NPTS
	 NPOUT=NPIX
*
* Defines the parameters used by EDRSLIB (integer files)
	INVALA=-100000
	INVALB=0
	SCALE=1.0
	ZERO=0.0
*
* Call rebin to resample the input image over the entire area
* covered by the output image
*
	CALL REBINX(INPUT,NPIX,INVALA,INVALB,1,NPOUT,
     1	C,SCALE,METHOD,OUTPUT,NPOUT,IERR)

	RETURN
	END


      PROGRAM SHEX03
C
C  Create a tube-shaped isosurface.
C
C  The number of input data points.
C
      PARAMETER (NDATA=1000)
C
C  The number of output data points in the X coordinate direction.
C
      PARAMETER (NX=21)
C
C  The number of output data points in the Y coordinate direction.
C
      PARAMETER (NY=31)
C
C  The number of output data points in the Z coordinate direction.
C
      PARAMETER (NZ=41)
C
C  The size of the workspace.
C
      PARAMETER (NIWK=2*NDATA, NRWK=11*NDATA+6)
C
C  Dimension the arrays.
C
      DIMENSION X(NDATA), Y(NDATA), Z(NDATA), F(NDATA)
      DIMENSION IWK(NIWK), RWK(NRWK)
C
C Define the error file, the Fortran unit number, the workstation type,
C and the workstation ID to be used in calls to GKS routines.
C
C     PARAMETER (IERRF=6, LUNIT=2, IWTYPE=1,  IWKID=1)   ! NCGM
C     PARAMETER (IERRF=6, LUNIT=2, IWTYPE=8,  IWKID=1)   ! X Windows
C     PARAMETER (IERRF=6, LUNIT=2, IWTYPE=11, IWKID=1)   ! PDF
C     PARAMETER (IERRF=6, LUNIT=2, IWTYPE=20, IWKID=1)   ! PostScript
C
      PARAMETER (IERRF=6, LUNIT=2, IWTYPE=1,  IWKID=1)
C
C  Define arrays for use in plotting the isosurface.
C
      REAL XO(NX), YO(NY), ZO(NZ), OUTPUT(NX,NY,NZ)
      INTEGER I, J, K, IER
      DATA XMIN,YMIN,ZMIN,XMAX,YMAX,ZMAX / -2., -2., -2., 2.,  2., 2./
C
C  Define the input data on random coordinates bounded by the
C  above values.
C
      DO 10 I=1,NDATA
        X(I) = XMIN+(XMAX-XMIN)*DSRND1()
        Y(I) = YMIN+(YMAX-YMIN)*DSRND1()
        Z(I) = ZMIN+(ZMAX-ZMIN)*DSRND1()
        F(I)  =  0.75*X(I)**2 - 1.6*Y(I)**2 + 2.0*Z(I)**2.
   10 CONTINUE
C
C  Create the output grid.
C
      DO 102 I=1,NX
        XO(I) = XMIN+(REAL(I-1)/REAL(NX-1))*(XMAX-XMIN)
  102 CONTINUE
      DO 103 J =1,NY
        YO(J)= YMIN+(REAL(J-1)/REAL(NY-1))*(YMAX-YMIN)
  103 CONTINUE
      DO 104 K=1,NZ
        ZO(K) = ZMIN+(REAL(K-1)/REAL(NZ-1))*(ZMAX-ZMIN)
  104 CONTINUE
C
C  Find the approximating function values on the output grid.
C
      CALL SHGRID (NDATA,X,Y,Z,F,NX,NY,NZ,XO,YO,ZO,OUTPUT,IWK,RWK,IER)
C
C  Plot an isosurface.
C
C  Open GKS and define the foreground and background color.
C
      CALL GOPKS (IERRF, ISZDM)
      CALL GOPWK (IWKID, LUNIT, IWTYPE)
      CALL GACWK (IWKID)
C
      CALL TDEZ3D(NX, NY, NZ, XO, YO, ZO,
     +            OUTPUT, 0.7, 2.3, -13., 75., 6)
      CALL FRAME()
C
C Close GKS.
C
      CALL GDAWK (IWKID)
      CALL GCLWK (IWKID)
      CALL GCLKS
C
      STOP
      END
      REAL FUNCTION DSRND1()
C
C  Portable random number generator.
C
      PARAMETER (MPLIER=16807,MODLUS=2147483647,MOBYMP=127773,
     +           MOMDMP=2836)
C
      INTEGER HVLUE, LVLUE, TESTV, NEXTN
      SAVE    NEXTN
      DATA JSEED,IFRST/123456789,0/
C
      IF (IFRST .EQ. 0) THEN
        NEXTN = JSEED
        IFRST = 1
      ENDIF
C
      HVLUE = NEXTN / MOBYMP
      LVLUE = MOD(NEXTN, MOBYMP)
      TESTV = MPLIER*LVLUE - MOMDMP*HVLUE
      IF (TESTV .GT. 0) THEN
        NEXTN = TESTV
      ELSE
        NEXTN = TESTV + MODLUS
      ENDIF
      DSRND1 = REAL(NEXTN)/REAL(MODLUS)
C
      RETURN
      END