subroutine	continuum(x,wx,sx,y,nx,cont,n,rejectcont)

! determine the continuum with one of the following algorithms:
!	cont<= 0 -- do nothing
!	cont= 1 -- polynomial fitting
!	cont= 2 -- PEM (split each range in n pieces and divide each subarray by its mean value)
!	cont= 3	-- running mean with a width of n+1 pixels
!

use share, only: dp,nsynth,hs,winter
use booklib
use lsq

implicit none

!input/output
integer, intent(in)     :: cont		    	!choice of algorithm
integer, intent(in)	:: n		    	!order (cont=1)
					    	!number of pieces per wavelength
					    	!        segment (cont=2)
					    	!boxcar width is n+1 (cont=3)
real(dp),intent(in)     :: rejectcont           !rel. error threshold for data rejection when cont=1
integer, intent(in)	:: nx		    	!size for x and sx
real(dp),intent(in) 	:: x(nx),wx(nx),sx(nx)  !data, wavelengths and errors
real(dp),intent(out)    :: y(nx)            	!continuum

!locals
integer			:: p1,p2	    !dummy pixel indices
real(dp)		:: med   	    !tmp var with the array mean
integer			:: nel              !length of a section
integer			:: nel2             !length of a subsection
integer			:: j,i		    !loop index
integer			:: error	    !error code for polynomial fit
real(dp)                :: xaxis(nx)        !findgen(nx)
real(dp)		:: w(nx)	    !weights
real(dp),dimension(0:n) :: coef             !coefs. for polynomial fit
real(dp)     		:: xaxis2(nx), x2(nx)   !temporary arrays for cleaning up
					    !data  with rel. error > rejectcont

if (cont <= 0) then
  y(1:nx)=1._dp
  return
endif

!set abscissae and weights needed for polynomial fitting
if (cont == 1) then
	w(:)=0._dp
	do i=1,nx
  		xaxis(i)=i*1._dp
		if (sx(i) > 0._dp) w(i)=1._dp/sx(i)**2
	enddo
endif

do j=1,nsynth

	if (abs(hs(j)%res-0._dp) > 1e-6_dp) then	!skip photometry

	  if (winter == 2) then
		  p1=minval(minloc(wx,wx >= hs(j)%lambdamin))
		  p2=maxval(maxloc(wx,wx <= hs(j)%lambdamax))
	  else
		  p1=hs(j)%pixbegin
		  p2=hs(j)%pixend
	  endif

	  !write(*,*)'lambdamin,lambdamax=',hs(j)%lambdamin,hs(j)%lambdamax
	  !write(*,*)'p1,p2=',p1,p2
	  !write(*,*)'wx(p1),wx(p2)=',wx(p1),wx(p2)

	  nel=p2-p1+1

	  select case (cont)
		  case (1)
		        nel2=0
		        x2(1:nx)=1.
		        xaxis2(1:nx)=xaxis(1:nx)
		        do i=1,nel
			    if (abs(sx(p1+i-1)/x(p1+i-1)) < abs(rejectcont)) then
			      nel2=nel2+1
			      !xaxis2(nel2)=xaxis(p1+i-1)
			      xaxis2(nel2)=xaxis(i)
			      x2(nel2)=x(p1+i-1)
			    endif
		        enddo
		        !write(*,*) 'rejectcont=',rejectcont, nel, n, nel2
		        if (nel2 <= n) then
		          !give up
		          write(*,*)'continuum: WARNING'
		          write(*,*) 'Too few points pass the rejectcont=',rejectcont,' filter', nel, n, nel2
		          write(*,*) 'It is being ignored!'
		          nel2=nel
		          xaxis2(1:nel)=xaxis(1:nel)
		          x2(1:nel)=x(p1:p2)
		        endif
		    	if (n == 0) then
			    !order 0 is just the mean
			    y(p1:p2)=sum(x2(1:nel2))/(nel2*1._dp)
			    !y(p1:p2)=sum(x(p1:p2))/(nel*1._dp)
			else
			    !fit polynomial
			    coef(:)=0.0_dp
			    call lsq_fit(xaxis2(1:nel2)-xaxis(nel2/2),x2(1:nel2),nel2,n,coef,error)
			    !call lsq_fit(xaxis(1:nel),x(p1:p2),nel,n,coef,error)
			    !call poly_fit(xaxis(1:nel),x(p1:p2),w(p1:p2),nel,n,coef,error)

			    !evaluate it
			    y(p1:p2)=coef(0)
			    do i=1,n
				y(p1:p2)=y(p1:p2)+coef(i)*(xaxis(1:nel)-xaxis(nel2/2))**i
			    enddo
                            if (rejectcont .lt. 0) write(*,*) y
	  	  	endif
		  case (2)
		    call pem(x(p1:p2),nel,n,y(p1:p2))
	  	  case (3)
	    	    call filter1(x(p1:p2),nel,n,y(p1:p2))
	  	  case default
	    		write(*,*)'ferre: ERROR'
	    		write(*,*)'-- cont must be <=0,1,2,3'
	    		write(*,*)'-- this should have been caught in load_control!'
	    		stop
	  end select
	endif
enddo

end subroutine continuum


! MIT License
!
! Copyright (c) 2020 SHEMAT-Suite
!
! Permission is hereby granted, free of charge, to any person obtaining a copy
! of this software and associated documentation files (the "Software"), to deal
! in the Software without restriction, including without limitation the rights
! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
! copies of the Software, and to permit persons to whom the Software is
! furnished to do so, subject to the following conditions:
!
! The above copyright notice and this permission notice shall be included in all
! copies or substantial portions of the Software.
!
! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
! SOFTWARE.

!>    @brief calculate coefficents for the heat equation
!>    @param[in] ismpl local sample index
!>    @details
!> calculate coefficents for the heat equation\n
!> coefficients are stored as vectors in the diagonals a-g (d center) and rhs in w.\n
      SUBROUTINE set_tcoef(ismpl)
        use arrays
        use mod_genrl
        use mod_genrlc
        use mod_temp
        use mod_time
        use mod_linfos
        IMPLICIT NONE
        integer :: ismpl
        integer :: i, j, k

        DOUBLE PRECISION li, lj, lk, rhocf, vx, vy, vz, alfa, amean
        EXTERNAL li, lj, lk, rhocf, vx, vy, vz, alfa, amean

        DOUBLE PRECISION rijk, ra, rc, va, la, alf, p2

!$OMP master
        IF (linfos(3)>=2) WRITE(*,*) ' ... tcoef'
!$OMP end master

! initialize coefficients for sparse solvers

! inner points of grid - - - - - - - - - - - - - - - - - - - - - - - - -

!$OMP do schedule(static) collapse(3)
        DO k = 1, k0
          DO j = 1, j0
            DO i = 1, i0

              rijk = rhocf(i,j,k,ismpl)

              IF (i0>1) THEN
                IF (i<i0) THEN
                  la = li(i,j,k,ismpl)
                  ra = amean(rhocf(i+1,j,k,ismpl),rijk)
                  va = vx(i,j,k,ismpl)
                  rc = 0.5*ra*va
                  IF (la>0.D0) THEN
                    p2 = rc/la
                    alf = alfa(p2)
                  ELSE
                    alf = 0.D0
                    IF (va<0.D0) alf = -1.D0
                    IF (va>0.D0) alf = 1.D0
                  END IF
                  e(i,j,k,ismpl) = (la-(1.D0-alf)*rc)/delx(i)
                  d(i,j,k,ismpl) = d(i,j,k,ismpl) - &
                    (la+(1.D0+alf)*rc)/delx(i)
                END IF

                IF (i>1) THEN
                  la = li(i-1,j,k,ismpl)
                  ra = amean(rhocf(i-1,j,k,ismpl),rijk)
                  va = vx(i-1,j,k,ismpl)
                  rc = 0.5*ra*va
                  alf = 0.D0
                  IF (va==0.D0) THEN
                    alf = 0.D0
                  ELSE
                    IF (la>0.D0) THEN
                      p2 = rc/la
                      alf = alfa(p2)
                    ELSE
                      IF (va<0.D0) alf = -1.D0
                      IF (va>0.D0) alf = 1.D0
                    END IF
                  END IF
                  c(i,j,k,ismpl) = (la+(1.D0+alf)*rc)/delx(i)
                  d(i,j,k,ismpl) = d(i,j,k,ismpl) - &
                    (la-(1.D0-alf)*rc)/delx(i)
                END IF
              END IF

              IF (j0>1) THEN

                IF (j<j0) THEN
                  la = lj(i,j,k,ismpl)
                  ra = amean(rhocf(i,j+1,k,ismpl),rijk)
                  va = vy(i,j,k,ismpl)
                  rc = 0.5D0*ra*va
                  alf = 0.D0
                  IF (va==0.D0) THEN
                    alf = 0.D0
                  ELSE
                    IF (la>0.D0) THEN
                      p2 = rc/la
                      alf = alfa(p2)
                    ELSE
                      IF (va<0.D0) alf = -1.D0
                      IF (va>0.D0) alf = 1.D0
                    END IF
                  END IF
                  f(i,j,k,ismpl) = (la-(1.D0-alf)*rc)/dely(j)
                  d(i,j,k,ismpl) = d(i,j,k,ismpl) - &
                    (la+(1.D0+alf)*rc)/dely(j)
                END IF

                IF (j>1) THEN
                  la = lj(i,j-1,k,ismpl)
                  ra = amean(rhocf(i,j-1,k,ismpl),rijk)
                  va = vy(i,j-1,k,ismpl)
                  rc = 0.5*ra*va
                  alf = 0.D0
                  IF (va==0.D0) THEN
                    alf = 0.D0
                  ELSE
                    IF (la>0.D0) THEN
                      p2 = rc/la
                      alf = alfa(p2)
                    ELSE
                      IF (va<0.D0) alf = -1.D0
                      IF (va>0.D0) alf = 1.D0
                    END IF
                  END IF
                  b(i,j,k,ismpl) = (la+(1.D0+alf)*rc)/dely(j)
                  d(i,j,k,ismpl) = d(i,j,k,ismpl) - &
                    (la-(1.D0-alf)*rc)/dely(j)
                END IF
              END IF

              IF (k0>1) THEN

                IF (k<k0) THEN
                  la = lk(i,j,k,ismpl)
                  ra = amean(rhocf(i,j,k+1,ismpl),rijk)
                  va = vz(i,j,k,ismpl)
                  rc = 0.5*ra*va
                  alf = 0.D0
                  IF (va==0.D0) THEN
                    alf = 0.D0
                  ELSE
                    IF (la>0.D0) THEN
                      p2 = rc/la
                      alf = alfa(p2)
                    ELSE
                      IF (va<0.D0) alf = -1.D0
                      IF (va>0.D0) alf = 1.D0
                    END IF
                  END IF
                  g(i,j,k,ismpl) = (la-(1.D0-alf)*rc)/delz(k)
                  d(i,j,k,ismpl) = d(i,j,k,ismpl) - &
                    (la+(1.D0+alf)*rc)/delz(k)
                END IF

                IF (k>1) THEN
                  la = lk(i,j,k-1,ismpl)
                  ra = amean(rhocf(i,j,k-1,ismpl),rijk)
                  va = vz(i,j,k-1,ismpl)
                  rc = 0.5*ra*va
                  alf = 0.D0
                  IF (va==0.D0) THEN
                    alf = 0.D0
                  ELSE
                    IF (la>0.D0) THEN
                      p2 = rc/la
                      alf = alfa(p2)
                    ELSE
                      IF (va<0.D0) alf = -1.D0
                      IF (va>0.D0) alf = 1.D0
                    END IF
                  END IF
                  a(i,j,k,ismpl) = (la+(1.D0+alf)*rc)/delz(k)
                  d(i,j,k,ismpl) = d(i,j,k,ismpl) - &
                    (la-(1.D0-alf)*rc)/delz(k)
                END IF
              END IF

            END DO
          END DO
        END DO
!$OMP end do nowait

        RETURN
      END

!>    @brief coefficents for the heat equation (here right hand side)
!>    @param[in] ismpl local sample index
!>    @details
!> calculate coefficents for the heat equation\n
!> coefficients are stored as vectors in the diagonals a-g (d center) and rhs in w.\n
      SUBROUTINE set_tcoefrs(ismpl)
        use arrays
        use mod_genrl
        use mod_genrlc
        use mod_temp
        use mod_time
        use mod_linfos
        IMPLICIT NONE
        integer :: ismpl
        integer :: i, j, k

        DOUBLE PRECISION deltt, rce
        ! INTEGER c1, c2, c3, c4

        DOUBLE PRECISION rhoceff, por, qt, deltat
        EXTERNAL rhoceff, por, qt, deltat

        deltt = deltat(simtime(ismpl),ismpl)

! - - rhs: sources, also terms for transient caolculations - - - - - - - - -

        IF (transient .AND. tr_switch(ismpl)) THEN
! - - - - - - - transient  - - - - - - - - - - - - - - - - - - - - - - - - - -

          CALL omp_mvp(i0,j0,k0,tempold(1,cgen_time,ismpl), &
            x(1,1,1,ismpl),a(1,1,1,ismpl),b(1,1,1,ismpl), &
            c(1,1,1,ismpl),d(1,1,1,ismpl),e(1,1,1,ismpl), &
            f(1,1,1,ismpl),g(1,1,1,ismpl))

!$OMP do schedule(static) collapse(3)
          DO k = 1, k0
            DO j = 1, j0
              DO i = 1, i0
!                 add  solid and fluid heat production, boundary terms
                rce = rhoceff(i,j,k,ismpl)
                d(i,j,k,ismpl) = d(i,j,k,ismpl) - rce/(deltt*thetat)
                w(i,j,k,ismpl) = w(i,j,k,ismpl) - &
                  rce*tempold(i+(j-1)*i0+(k-1)*i0*j0,cgen_time,ismpl)/ &
                  deltt - (1.D0-thetat)*x(i,j,k,ismpl) - &
                  hpf*por(i,j,k,ismpl)
                w(i,j,k,ismpl) = w(i,j,k,ismpl)/thetat
              END DO
            END DO
          END DO
!$OMP    end do nowait
        ELSE
! - - - - - - - - steady state - - - - - - - - - - - - - - - - - - - - -
!$OMP do schedule(static) collapse(3)
          DO k = 1, k0
            DO j = 1, j0
              DO i = 1, i0
!                 solid and fluid heat production
                w(i,j,k,ismpl) = w(i,j,k,ismpl) - hpf*por(i,j,k,ismpl)
              END DO
            END DO
          END DO
!$OMP    end do nowait
        END IF

        RETURN
      END


      function dfhalo(energy)

      include 'commonblocks'

      if(energy.lt.psic) then
         dfhalo = 0.
         return
      endif
      if(energy.ge.psi0) then
         dfhalo = exp(dfnfw(1))
         return
      endif

      rj = 1. + float(npsi-1)*
     +     log((psi0-energy)/(psi0-psid))/log((psi0-psic)/(psi0-psid))
      j = int(rj)
      if(j.lt.1) j = 1
      if(j.ge.npsi) j = npsi-1

      frac = rj - float(j)
      dfhalo = exp(dfnfw(j) + frac*(dfnfw(j+1)-dfnfw(j)))

      return

      end


      SUBROUTINE PNM(M,N,X,IR,V)
      DIMENSION GAMMA(81)
      IF(N.LT.M) GO TO 2
      IF(N.EQ.0) GO TO 1
      GO TO 3
    1 V=1.0
      RETURN
    2 V=0.0
      RETURN
    3 Z=1.0
      W=Z
      IF(N.EQ.M) GO TO 4
      NMM=N-M
      DO 5 I=1,NMM
    5 Z=X*Z
    4 GAMMA(1)=1.0
      NPNN1=N+N+1
      DO 6 I=2,NPNN1
      GAMMA(I)=W*GAMMA(I-1)
    6 W=W+1.0
      W=1.0
      ABXX=ABS(X)
      IF(ABXX.LT.0.001) GO TO 7
      GO TO 8
    7 I=(N-M)/2
      I2=2*I
      NMM=N-M
      IF(I2.NE.NMM) GO TO 9
      V=GAMMA(M+N+1)/(GAMMA(I+1)*GAMMA(M+I+1))
      IF(IR.NE.0) GO TO 100
      V=V*(-1.0)**I
      GO TO 100
    9 V=0.0
      RETURN
    8 Y=W/(X*X)
      IF(IR.EQ.0) GO TO 11
      GO TO 12
   11 Y=-Y
      W=-W
   12 J=3
      V=0.0
      DO 13 I=1,22
      II=(N-M+2)/2
      IF(II.LT.I) GO TO 100
      V=V+GAMMA(N+N-I-I+3)*Z/(GAMMA(I)*GAMMA(N-I+2)*GAMMA(N-I-I-M+J))
   13 Z=Z*Y
  100 Z=1.0
      DO 101 I=1,N
  101 Z=Z+Z
      V=V/Z
      IF(IR.NE.0) GO TO 102
      GO TO 103
  102 II=N/4
      I=N-4*II
      IF(I.GT.1) GO TO 104
      GO TO 103
  104  V=-V
  103  IF(M.EQ.0) RETURN
      J=M/2
      CF=W+X*X
      Z=ABS(CF)
      J2=J+J
      IF(M.NE.J2) GO TO 107
      GO TO 105
  107 Z=SQRT(Z)
      J=M
  105 IF(J.LT.1) J=1
      DO 106 I=1,J
  106 V=V*Z
      RETURN
      END


      SUBROUTINE PHO_POLINT4F(Xa,Ya,X,Y)

      IMPLICIT NONE
      DOUBLE PRECISION c1 , c2 , c3 , cc1 , cc2 , cd1 , cd2 , d1 , d2 ,
     &                 d3 , dc1 , dd1 , den , h1 , h2 , h3 , h4 , w ,
     &                 X , Xa
      DOUBLE PRECISION Y , Ya
C  The POLINT4 routine is based on the POLINT routine from "Numerical Recipes",
C  but assuming N=4, and ignoring the error estimation.
C  suggested by Z. Sullivan.
      DIMENSION Xa(*) , Ya(*)

      h1 = Xa(1) - X
      h2 = Xa(2) - X
      h3 = Xa(3) - X
      h4 = Xa(4) - X

      w = Ya(2) - Ya(1)
      den = w/(h1-h2)
      d1 = h2*den
      c1 = h1*den

      w = Ya(3) - Ya(2)
      den = w/(h2-h3)
      d2 = h3*den
      c2 = h2*den

      w = Ya(4) - Ya(3)
      den = w/(h3-h4)
      d3 = h4*den
      c3 = h3*den

      w = c2 - d1
      den = w/(h1-h3)
      cd1 = h3*den
      cc1 = h1*den

      w = c3 - d2
      den = w/(h2-h4)
      cd2 = h4*den
      cc2 = h2*den

      w = cc2 - cd1
      den = w/(h1-h4)
      dd1 = h4*den
      dc1 = h1*den

      IF ( (h3+h4).LT.0D0 ) THEN
         Y = Ya(4) + d3 + cd2 + dd1
      ELSE IF ( (h2+h3).LT.0D0 ) THEN
         Y = Ya(3) + d2 + cd1 + dc1
      ELSE IF ( (h1+h2).LT.0D0 ) THEN
         Y = Ya(2) + c2 + cd1 + dc1
      ELSE
         Y = Ya(1) + c1 + cc1 + dc1
      END IF

C               *************************
      END SUBROUTINE


!############################################################################################
!
! Copyright 2020 Bharat Mahajan
!
! Licensed under the Apache License, Version 2.0 (the "License");
! you may not use this file except in compliance with the License.
! You may obtain a copy of the License at
!
!    http://www.apache.org/licenses/LICENSE-2.0
!
! Unless required by applicable law or agreed to in writing, software
! distributed under the License is distributed on an "AS IS" BASIS,
! WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
! See the License for the specific language governing permissions and
! limitations under the License.
!
!> \brief       Explicit Runge-Kutta Module
!! \details     A module for Explicit Runge-Kutta type numerical solvers with dense-output,
!!              vector events detection, and stiffness detection.
!! \author      Bharat Mahajan
!! \date        Created: 01/25/2019
!
!############################################################################################

module ERK

    use FLINT_base
    use ButcherTableaus
    use StepSize
    use, intrinsic :: IEEE_ARITHMETIC

    implicit none

    private

    real(WP), parameter :: DEFAULT_ABSTOL = 1.0e-9_WP !< default absolute tolerance
    real(WP), parameter :: DEFAULT_RELTOL = 1.0e-6_WP !< default relative tolerance

    !> Maximum number of events that can be detected during event-checking inside the
    !! integrator's step using the event step size
    integer, parameter :: MAXNUMSTEPSZEVENTS = 4

    real(WP), parameter :: DEFAULT_EVENTTOL = 1.0e-6_WP !< this value is used to detect events

    !> Stiffness test default number of steps. See Hairer's DOP853 code.
    integer, parameter :: STIFFTEST_STEPS = 1000

    !> All the supported ERK Methods
    enum, bind(C)
        enumerator :: ERK_DOP853 = 17   !< Hairer's DOP853
        enumerator :: ERK_DOP54       !< Dormand-Prince 5(4)
        enumerator :: ERK_VERNER98R     !< Verner's 9th-order Robust coefficients
        !enumerator :: ERK_VERNER98E     !< Verner's 9th-order Efficient coefficients
        !enumerator :: ERK_VERNER87R     !< Verner's 8th-order Robust coefficients
        !enumerator :: ERK_VERNER87E     !< Verner's 8th-order Efficient coefficients
        !enumerator :: ERK_VERNER76R     !< Verner's 7th-order Robust coefficients
        !enumerator :: ERK_VERNER76E     !< Verner's 7th-order Efficient coefficients
        enumerator :: ERK_VERNER65E      !< Verner's 6th-order Robust coefficients
    end enum

    public :: ERK_DOP853, ERK_DOP54, ERK_VERNER98R, ERK_VERNER65E  !, ERK_VERNER98E, ERK_VERNER87R, ERK_VERNER87E
    !public :: ERK_VERNER76R, ERK_VERNER76E

    !> The ERK class for all the ERK methods available to the user. It inherits FLINT_class.
    type, extends(FLINT_class), public :: ERK_class

        private

        !> Type of ERK method to use for integration, DOP853 by default
        integer(kind(ERK_DOP853)), public :: method = ERK_DOP853

        ! Specs of the chosen method, DOP853 by default
        integer :: p        = DOP853_p
        integer :: phat     = DOP853_phat
        integer :: q        = DOP853_q
        integer :: pstar    = DOP853_pstar

        ! Butcher Tableau coefficients of the chosen method
        integer :: s        !< Total number of stages
        integer :: sint     !< Number of Integration stages (including the FSAL stage)
        real(WP), dimension(ERK_MAX_A) :: a             !< a_ij
        real(WP), dimension(1:ERK_MAXSTAGES) :: b       !< b_i
        real(WP), dimension(2:ERK_MAXSTAGES) :: c       !< c_i
        real(WP), dimension(1:ERK_MAXSTAGES) :: e       !< e_i

        !> Stages that gets multiplied by non-zero dij, in other words the stages specified by dinz
        !! are the ones that contribute to the interpolating polynomial coefficients.
        !! Specify the stages in dinz and terminate the list by -1.
        integer, dimension(1:ERK_MAXSTAGES+1) :: dinz

        real(WP), dimension(1:ERK_MAXSTAGES,1:ERK_MAXIPDEGREE) :: d !< d_ij coefficients for interpolation

        logical :: IsFSALMethod !< If true then the last stage is reused as the first for the new step

    contains

        procedure, public :: Init => erk_init
        procedure, public :: Integrate => erk_int
        procedure, public :: Interpolate => erk_interp
        procedure, public :: Info => erk_info

        final :: erk_destroy !< destructor

    end type ERK_class

    interface

    module subroutine erk_init(me, DE, MaxSteps, Method, ATol, RTol, InterpOn, &
        InterpStates, MinStepSize, MaxStepSize, StepSzParams, &
        EventsOn, EventStepSz, EventOptions, EventTol)

        implicit none

        class(ERK_class), intent(inout) :: me
        class(DiffEqSys), target :: DE
        integer, intent(in) :: MaxSteps
        integer, intent(in), optional :: Method
        real(WP), dimension(:), intent(in), optional :: ATol
        real(WP), dimension(:), intent(in), optional :: RTol
        logical, intent(in), optional :: InterpOn
        integer, dimension(:), intent(in), optional :: InterpStates
        real(WP), intent(in), optional :: MinStepSize, MaxStepSize
        real(WP), dimension(5), intent(in), optional :: StepSzParams
        logical, intent(in), optional :: EventsOn
        real(WP), dimension(:), intent(in), optional :: EventStepSz
        integer(kind(FLINT_EVENTOPTION_ROOTFINDING)), dimension(:), &
                                intent(in), optional :: EventOptions
        real(WP), dimension(:), intent(in), optional :: EventTol

    end subroutine erk_init

    module subroutine erk_int(me, X0, Y0, Xf, Yf, StepSz, UseConstStepSz, IntStepsOn, Xint, Yint, &
                                EventMask, EventStates, StiffTest, params)

        implicit none

        class(ERK_class), intent(inout) :: me

        real(WP), intent(in) :: X0
        real(WP), dimension(me%pDiffEqSys%n), intent(in) :: Y0
        real(WP), intent(inout) :: Xf
        real(WP), dimension(me%pDiffEqSys%n), intent(out) :: Yf
        real(WP), intent(inout) :: StepSz
        logical, intent(in), optional :: UseConstStepSz
        logical, intent(in), optional :: IntStepsOn
        real(WP), allocatable, dimension(:), intent(out), optional :: Xint
        real(WP), allocatable, dimension(:,:), intent(out), optional :: Yint
        logical, dimension(me%pDiffEqSys%m), intent(in), optional :: EventMask
        real(WP), allocatable, dimension(:,:), intent(out), optional :: EventStates
        integer, intent(inout), optional :: StiffTest
        real(WP), dimension(:), intent(in), optional :: params

    end subroutine erk_int

    module subroutine erk_interp(me, Xarr, Yarr, SaveInterpCoeffs)

        implicit none

        class(ERK_class), intent(inout) :: me

        real(WP), dimension(1:), intent(in) :: Xarr
        real(WP), dimension(size(me%InterpStates),size(Xarr)), intent(out) :: Yarr
        logical, intent(in), optional :: SaveInterpCoeffs

    end subroutine erk_interp

    module subroutine erk_info(me, LastStatus, StatusMsg, nSteps, nAccept, nReject, nFCalls, &
                                InterpReady, h0, X0, Y0, hf, Xf, Yf)

            class(ERK_class), intent(inout) :: me
            integer(kind(FLINT_SUCCESS)), intent(out) :: LastStatus
            character(len=:), allocatable, intent(out), optional :: StatusMsg
            integer, intent(out), optional :: nSteps
            integer, intent(out), optional :: nAccept
            integer, intent(out), optional :: nReject
            integer, intent(out), optional :: nFCalls
            logical, intent(out), optional :: InterpReady
            real(WP), intent(out), optional :: h0
            real(WP), intent(out), optional :: X0
            real(WP), dimension(:), intent(out), optional :: Y0
            real(WP), intent(out), optional :: hf
            real(WP), intent(out), optional :: Xf
            real(WP), dimension(:), intent(out), optional :: Yf

    end subroutine erk_info

    pure module function InterpY(np, X, X0, h, pstar, bCoeffs) result(Yip)
        integer, intent(in) :: np
        real(WP), intent(in) :: X, X0, h
        integer, intent(in) :: pstar
        real(WP), dimension(np,0:pstar), intent(in) :: bCoeffs
        real(WP), dimension(np) :: Yip
    end function InterpY

    module subroutine erk_destroy(me)

        type(ERK_class) :: me

    end subroutine erk_destroy

    end interface

    contains

end module ERK


! This is our program.  After compilation, the executable will start with
! this file at the start of "program" and end at "end program".
program HeatEq
  ! Similar to NMUM example 10.3, but instituted in a more generalized manner.

  ! Use publicly available subroutines from the module ModHeatEq
  ! Rather than make all values with ModHeatEq available, we'll only "use"
  ! the ones we need.  This is a good habit!
  use ModHeatEq, ONLY: init_sim, run_simulation, finalize_sim

  ! implicit none after any use statements.
  implicit none

  !--------------------------------------------------------------------------
  ! begin the main part of the program.
  ! We are calling user defined subroutines to execute our simulation.

  ! Initialize simulation using custom dt, dx.
  call init_sim(0.2, 0.02)

  ! Integrate in time, write_result to file.
  ! We can forego the parentheses if there are no arguments to pass.
  call run_simulation

  ! Deallocate all arrays.
  call finalize_sim

end program HeatEq


!----------------------Function----------------------------------------!
!
      FUNCTION FNITP( FM,FL,FH,FDL,FDH )
!
!-------------------------Disclaimer-----------------------------------!
!
!     This material was prepared as an account of work sponsored by
!     an agency of the United States Government. Neither the
!     United States Government nor the United States Department of
!     Energy, nor Battelle, nor any of their employees, makes any
!     warranty, express or implied, or assumes any legal liability or
!     responsibility for the accuracy, completeness, or usefulness
!     of any information, apparatus, product, software or process
!     disclosed, or represents that its use would not infringe
!     privately owned rights.
!
!----------------------Acknowledgement---------------------------------!
!
!     This software and its documentation were produced with Government
!     support under Contract Number DE-AC06-76RLO-1830 awarded by the
!     United Department of Energy. The Government retains a paid-up
!     non-exclusive, irrevocable worldwide license to reproduce,
!     prepare derivative works, perform publicly and display publicly
!     by or for the Government, including the right to distribute to
!     other Government contractors.
!
!---------------------Copyright Notices--------------------------------!
!
!            Copyright Battelle Memorial Institute, 1996
!                    All Rights Reserved.
!
!----------------------Description-------------------------------------!
!
!     Linear interpolation function.
!
!----------------------Authors-----------------------------------------!
!
!     Written by MD White, Battelle, PNL, March, 1993.
!     Last Modified by MD White, Battelle, PNL, April 14, 1994.
!     $Id: fnitp.F 1080 2017-03-14 16:22:02Z d3c002 $
!

!----------------------Fortran 90 Modules------------------------------!
!
      USE GLB_PAR
      USE SOLTN
      USE CONST
!

!----------------------Implicit Double Precision-----------------------!
!
      IMPLICIT REAL*8 (A-H,O-Z)
      IMPLICIT INTEGER (I-N)
!
!----------------------Parameter Statements----------------------------!
!

!
!----------------------Common Blocks-----------------------------------!
!

!
!----------------------Executable Lines--------------------------------!
!
      ISUB_LOG = ISUB_LOG+1
      SUB_LOG(ISUB_LOG) = '/FNITP'
      IF( INDEX(SVN_ID(60)(1:1),'$').EQ.0 ) SVN_ID(60) =
     & '$Id: fnitp.F 1080 2017-03-14 16:22:02Z d3c002 $'
      IF( FM .LE. FL ) THEN
        FNITP = FDL
      ELSEIF( FM .GE. FH ) THEN
        FNITP = FDH
      ELSE
        FNITP = (FM-FL)*(FDH-FDL)/(FH-FL+SMALL) + FDL
      ENDIF
      ISUB_LOG = ISUB_LOG-1
!
!---  End of FNITP group
!
      RETURN
      END


! Test expression rewrites, in case where the expression cannot be
! folded to constant values.
! RUN: %flang_fc1 -fdebug-unparse %s 2>&1 | FileCheck %s

! Test rewrites of inquiry intrinsics with arguments whose shape depends
! on a function reference with non constant shape. The function reference
! must be retained.
module some_mod
contains
function returns_array(n, m)
  integer :: returns_array(10:n+10,10:m+10)
  returns_array = 0
end function

function returns_array_2(n)
  integer, intent(in) :: n
  integer :: returns_array_2(n)
  returns_array_2 = 0
end function

function returns_array_3()
  integer :: returns_array_3(7:46+2)
  returns_array_3 = 0
end function

subroutine ubound_test(x, n, m)
  integer :: x(n, m)
  !CHECK: PRINT *, [INTEGER(4)::int(size(x,dim=1),kind=4),int(size(x,dim=2),kind=4)]
  print *, ubound(x)
  !CHECK: PRINT *, ubound(returns_array(n,m))
  print *, ubound(returns_array(n, m))
  !CHECK: PRINT *, ubound(returns_array(n,m),dim=1_4)
  print *, ubound(returns_array(n, m), dim=1)
  !CHECK: PRINT *, ubound(returns_array_2(m))
  print *, ubound(returns_array_2(m))
  !CHECK: PRINT *, 42_8
  print *, ubound(returns_array_3(), dim=1, kind=8)
end subroutine

subroutine size_test(x, n, m)
  integer :: x(n, m)
  !CHECK: PRINT *, int(size(x,dim=1)*size(x,dim=2),kind=4)
  print *, size(x)
  !CHECK: PRINT *, size(returns_array(n,m))
  print *, size(returns_array(n, m))
  !CHECK: PRINT *, size(returns_array(n,m),dim=1_4)
  print *, size(returns_array(n, m), dim=1)
  !CHECK: PRINT *, size(returns_array_2(m))
  print *, size(returns_array_2(m))
  !CHECK: PRINT *, 42_8
  print *, size(returns_array_3(), kind=8)
end subroutine

subroutine shape_test(x, n, m)
  integer :: x(n, m)
  !CHECK: PRINT *, [INTEGER(4)::int(size(x,dim=1),kind=4),int(size(x,dim=2),kind=4)]
  print *, shape(x)
  !CHECK: PRINT *, shape(returns_array(n,m))
  print *, shape(returns_array(n, m))
  !CHECK: PRINT *, shape(returns_array_2(m))
  print *, shape(returns_array_2(m))
  !CHECK: PRINT *, [INTEGER(8)::42_8]
  print *, shape(returns_array_3(), kind=8)
end subroutine

subroutine lbound_test(x, n, m)
  integer :: x(n, m)
  !CHECK: PRINT *, [INTEGER(4)::1_4,1_4]
  print *, lbound(x)
  !CHECK: PRINT *, [INTEGER(4)::1_4,1_4]
  print *, lbound(returns_array(n, m))
  !CHECK: PRINT *, 1_4
  print *, lbound(returns_array(n, m), dim=1)
  !CHECK: PRINT *, 1_4
  print *, lbound(returns_array_2(m), dim=1)
  !CHECK: PRINT *, 1_4
  print *, lbound(returns_array_3(), dim=1)
end subroutine
end module


program test_limit
use iso_fortran_env,only:int8,int16,int32,int64,real32,real64,real128
use mod_testing,only:assert,initialize_tests,report_tests
use mod_functional,only:limit,arange

implicit none

logical,dimension(:),allocatable :: tests
logical :: test_failed
integer :: n,norder,ntests
integer,parameter :: stdout = 6

n = 1
ntests = 11
call initialize_tests(tests,ntests)

tests(n) = assert(limit(2_int8,1_int8,3_int8) == 2_int8,&
                  'limit, int8')
n = n + 1

tests(n) = assert(limit(2_int16,1_int16,3_int16) == 2_int16,&
                  'limit, int16')
n = n + 1

tests(n) = assert(limit(2_int32,1_int32,3_int32) == 2_int32,&
                  'limit, int32')
n = n + 1

tests(n) = assert(limit(2_int64,1_int64,3_int64) == 2_int64,&
                  'limit, int64')
n = n + 1

tests(n) = assert(limit(2._real32,1._real32,3._real32) == 2._real32,&
                  'limit, real32')
n = n + 1

tests(n) = assert(limit(2._real64,1._real64,3._real64) == 2._real64,&
                  'limit, real32')
n = n + 1

tests(n) = assert(limit(2._real128,1._real128,3._real128) == 2._real128,&
                  'limit, real128')
n = n + 1

tests(n) = assert(limit(cmplx(-0.5,1.5),cmplx(0,0),cmplx(1,1)) == cmplx(0,1),&
                  'limit, complex real32')
n = n + 1

tests(n) = assert(limit(cmplx(-0.5_real64,1.5_real64),cmplx(0._real64,0._real64),&
                        cmplx(1._real64,1._real64)) == cmplx(0._real64,1._real64),&
                  'limit, complex real64')
n = n + 1

tests(n) = assert(limit(cmplx(-0.5_real128,1.5_real128),cmplx(0._real128,0._real128),&
                        cmplx(1._real128,1._real128)) == cmplx(0._real128,1._real128),&
                  'limit, complex real128')
n = n + 1

tests(n) = assert(all(limit(arange(1,3),2,2) == [2,2,2]),&
                  'limit works on arrays')
n = n + 1

test_failed = .false.
call report_tests(tests,test_failed)
if(test_failed)stop 1

endprogram test_limit


module stdlib_stats_distribution_PRNG
    use stdlib_kinds, only: int8, int16, int32, int64
    use stdlib_error, only: error_stop
    implicit none
    private
    integer, parameter :: MAX_INT_BIT_SIZE = bit_size(1_int64)
    integer(int64) :: st(4) ! internal states for xoshiro256ss function
    integer(int64) :: si = 614872703977525537_int64 ! default seed value
    logical :: seed_initialized = .false.

    public :: random_seed
    public :: dist_rand

    interface dist_rand
    !! Version experimental
    !!
    !! Generation of random integers with different kinds
    !! ([Specification](../page/specs/stdlib_stats_distribution_PRNG.html#
    !! description))
        module procedure dist_rand_iint8
        module procedure dist_rand_iint16
        module procedure dist_rand_iint32
        module procedure dist_rand_iint64
    end interface dist_rand

    interface random_seed
    !! Version experimental
    !!
    !! Set seed value for random number generator
    !! ([Specification](../page/specs/stdlib_stats_distribution_PRNG.html#
    !! description))
    !!
        module procedure random_distribution_seed_iint8
        module procedure random_distribution_seed_iint16
        module procedure random_distribution_seed_iint32
        module procedure random_distribution_seed_iint64
    end interface random_seed

    contains

    function dist_rand_iint8(n) result(res)
    !! Random integer generation for various kinds
    !! result = [-2^k, 2^k - 1], k = 7, 15, 31, 63, depending on input kind
    !! Result will be operated by bitwise operators to generate desired integer
    !! and real pseudorandom numbers
    !!
        integer(int8), intent(in) :: n
        integer(int8) :: res
        integer :: k

        k = MAX_INT_BIT_SIZE - bit_size(n)
        if(k < 0) call error_stop("Error(dist_rand): Integer bit size is"       &
                  //" greater than 64bit")
        res = shiftr(xoshiro256ss( ), k)
    end function dist_rand_iint8

    function dist_rand_iint16(n) result(res)
    !! Random integer generation for various kinds
    !! result = [-2^k, 2^k - 1], k = 7, 15, 31, 63, depending on input kind
    !! Result will be operated by bitwise operators to generate desired integer
    !! and real pseudorandom numbers
    !!
        integer(int16), intent(in) :: n
        integer(int16) :: res
        integer :: k

        k = MAX_INT_BIT_SIZE - bit_size(n)
        if(k < 0) call error_stop("Error(dist_rand): Integer bit size is"       &
                  //" greater than 64bit")
        res = shiftr(xoshiro256ss( ), k)
    end function dist_rand_iint16

    function dist_rand_iint32(n) result(res)
    !! Random integer generation for various kinds
    !! result = [-2^k, 2^k - 1], k = 7, 15, 31, 63, depending on input kind
    !! Result will be operated by bitwise operators to generate desired integer
    !! and real pseudorandom numbers
    !!
        integer(int32), intent(in) :: n
        integer(int32) :: res
        integer :: k

        k = MAX_INT_BIT_SIZE - bit_size(n)
        if(k < 0) call error_stop("Error(dist_rand): Integer bit size is"       &
                  //" greater than 64bit")
        res = shiftr(xoshiro256ss( ), k)
    end function dist_rand_iint32

    function dist_rand_iint64(n) result(res)
    !! Random integer generation for various kinds
    !! result = [-2^k, 2^k - 1], k = 7, 15, 31, 63, depending on input kind
    !! Result will be operated by bitwise operators to generate desired integer
    !! and real pseudorandom numbers
    !!
        integer(int64), intent(in) :: n
        integer(int64) :: res
        integer :: k

        k = MAX_INT_BIT_SIZE - bit_size(n)
        if(k < 0) call error_stop("Error(dist_rand): Integer bit size is"       &
                  //" greater than 64bit")
        res = shiftr(xoshiro256ss( ), k)
    end function dist_rand_iint64

    function xoshiro256ss( ) result (res)
    ! Generate random 64-bit integers
    ! Written in 2018 by David Blackman and Sebastiano Vigna (vigna@acm.org)
    ! http://prng.di.unimi.it/xoshiro256starstar.c
    !
    ! This is xoshiro256** 1.0, one of our all-purpose, rock-solid
    ! generators. It has excellent (sub-ns) speed, a state (256 bits) that is
    ! large enough for any parallel application, and it passes all tests we
    ! are aware of.
    !
    ! The state must be seeded so that it is not everywhere zero. If you have
    ! a 64-bit seed, we suggest to seed a splitmix64 generator and use its
    ! output to fill st.
    !
    ! Fortran 90 version translated from C by Jim-215-Fisher
    !
        integer(int64) :: res, t

        if(.not. seed_initialized) call random_distribution_seed_iint64(si,t)
        res = rol64(st(2) * 5, 7) * 9
        t = shiftl(st(2), 17)
        st(3) = ieor(st(3), st(1))
        st(4) = ieor(st(4), st(2))
        st(2) = ieor(st(2), st(3))
        st(1) = ieor(st(1), st(4))
        st(3) = ieor(st(3), t)
        st(4) = rol64(st(4), 45)
    end function xoshiro256ss

    pure function rol64(x, k) result(res)
        integer(int64), intent(in) :: x
        integer, intent(in) :: k
        integer(int64) :: t1, t2, res

        t1 = shiftr(x, (64 - k))
        t2 = shiftl(x, k)
        res = ior(t1, t2)
    end function rol64

    function splitmix64(s) result(res)
    ! Written in 2015 by Sebastiano Vigna (vigna@acm.org)
    ! This is a fixed-increment version of Java 8's SplittableRandom
    ! generator.
    ! See http://dx.doi.org/10.1145/2714064.2660195 and
    ! http://docs.oracle.com/javase/8/docs/api/java/util/SplittableRandom.html
    !
    ! It is a very fast generator passing BigCrush, and it can be useful if
    ! for some reason you absolutely want 64 bits of state.
    !
    ! Fortran 90 translated from C by Jim-215-Fisher
    !
        integer(int64) :: res
        integer(int64), intent(in), optional :: s
        integer(int64) :: int01 = -7046029254386353131_int64,                  &
                          int02 = -4658895280553007687_int64,                  &
                          int03 = -7723592293110705685_int64
    ! Values are converted from C unsigned integer of 0x9e3779b97f4a7c15,
    ! 0xbf58476d1ce4e5b9, 0x94d049bb133111eb

        if(present(s)) si = s
        res = si
        si = res + int01
        res = ieor(res, shiftr(res, 30)) * int02
        res = ieor(res, shiftr(res, 27)) * int03
        res = ieor(res, shiftr(res, 31))
    end function splitmix64

    subroutine random_distribution_seed_iint8(put, get)
    !! Set seed value for random number generator
    !!
        integer(int8), intent(in) :: put
        integer(int8), intent(out) :: get
        integer(int64) :: tmp
        integer :: i

        tmp = splitmix64(int(put, kind = int64))
        do i = 1, 10
            tmp = splitmix64( )
        end do
        do i = 1, 4
            tmp = splitmix64( )
            st(i) = tmp
        end do
        get = int(tmp, kind = int8)
        seed_initialized = .true.
    end subroutine random_distribution_seed_iint8

    subroutine random_distribution_seed_iint16(put, get)
    !! Set seed value for random number generator
    !!
        integer(int16), intent(in) :: put
        integer(int16), intent(out) :: get
        integer(int64) :: tmp
        integer :: i

        tmp = splitmix64(int(put, kind = int64))
        do i = 1, 10
            tmp = splitmix64( )
        end do
        do i = 1, 4
            tmp = splitmix64( )
            st(i) = tmp
        end do
        get = int(tmp, kind = int16)
        seed_initialized = .true.
    end subroutine random_distribution_seed_iint16

    subroutine random_distribution_seed_iint32(put, get)
    !! Set seed value for random number generator
    !!
        integer(int32), intent(in) :: put
        integer(int32), intent(out) :: get
        integer(int64) :: tmp
        integer :: i

        tmp = splitmix64(int(put, kind = int64))
        do i = 1, 10
            tmp = splitmix64( )
        end do
        do i = 1, 4
            tmp = splitmix64( )
            st(i) = tmp
        end do
        get = int(tmp, kind = int32)
        seed_initialized = .true.
    end subroutine random_distribution_seed_iint32

    subroutine random_distribution_seed_iint64(put, get)
    !! Set seed value for random number generator
    !!
        integer(int64), intent(in) :: put
        integer(int64), intent(out) :: get
        integer(int64) :: tmp
        integer :: i

        tmp = splitmix64(int(put, kind = int64))
        do i = 1, 10
            tmp = splitmix64( )
        end do
        do i = 1, 4
            tmp = splitmix64( )
            st(i) = tmp
        end do
        get = int(tmp, kind = int64)
        seed_initialized = .true.
    end subroutine random_distribution_seed_iint64

end module stdlib_stats_distribution_PRNG


MODULE PARAM
 USE NRTYPE
 IMPLICIT NONE
 !-----------------------------------------------------------
 COMPLEX(DP), PARAMETER :: IM = CMPLX(0.0_DP,1.0_DP,KIND=DP)
 INTEGER :: N, M, NS, NABL, NZ, MX, NELT, KU, KL, INFO, NDIAG
 INTEGER, ALLOCATABLE, DIMENSION(:) :: IPIV
 REAL(DP) :: C0, L, H, HABL, F, ZS, ABL, K0, LMBDA0, DZ, DR, A0, A2, B, TI, TF, P0, NORM, RCOND
 REAL(DP), EXTERNAL :: ZLANGE, ZLANGB
 REAL(DP), ALLOCATABLE, DIMENSION(:) :: LPG, LPG2, WORK, RWORK
 REAL(DP), ALLOCATABLE, DIMENSION(:,:) :: LP, LP2, COND
 REAL(DP) :: H0, X0, S, XL, XR, ANGLE, THETA
 REAL(DP), ALLOCATABLE, DIMENSION(:) :: GHX, LIN, TERR, TERR1, TERR2
 COMPLEX(DP) :: A, ALPHA, BETA, BETA1, BETA2, TAU1, TAU2, SIGMA1, SIGMA2, IMP, R
 COMPLEX(DP), ALLOCATABLE, DIMENSION(:) :: ALT, C, K, DK2, CWORK
 COMPLEX(DP), ALLOCATABLE, DIMENSION(:,:) :: PHI, P, T, D, I, E, M1, M2, MB1, MB2, M1T, M2T, MB1T, MB2T, TEMP
 TYPE(SPRS2_DP), SAVE :: SPMAT, SP1, SP2
 !-----------------------------------------------------------
END MODULE PARAM


MODULE PhysicalConstantsModule

  USE KindModule, ONLY: &
    DP

  IMPLICIT NONE
  PRIVATE

  REAL(DP), PUBLIC, PARAMETER :: &
    SpeedOfLightMKS          = 2.99792458e8_DP, &
    GravitationalConstantMKS = 6.673e-11_DP, &
    BoltzmannConstantMKS     = 1.3806503e-23_DP, &
    ElectronVoltMKS          = 1.602176462e-19_DP, &
    PlanckConstantMKS        = 6.62606876e-34_DP, &
    AvogadroConstantMKS      = 6.02214199e23_DP

  REAL(DP), PUBLIC, PARAMETER :: &
    SpeedOfLightCGS          = 2.99792458e10_DP

END MODULE PhysicalConstantsModule


: aabb  ( x y w h - x1 y1 x2 y2 )  2over 2+ ;
: lowerupper  ( n n - lower higher )  2dup > if  swap  then ;
: between  ( n n - n )  lowerupper  over -  #1 +  rnd + ;
: vary  ( n rnd - n )  dup 0.5 *  -rot rnd +  swap - ;
: 2vary  ( n n rnd rnd - n n )  rot swap vary >r vary r> ;
: either  ( a b - a | b )  2 rnd if  drop  else  nip  then ;
: 2ratio  ( x y w h xfactor. yfactor. - x y )  2* 2+ ;
: middle  ( x y w h - x y )  0.5 0.5 2ratio ;
: 2halve  0.5 0.5 2* ;

\ center a rectangle (1) in the middle of another one (2).  returns x/y of top-left corner.
: center  ( w1 h1 x y w2 h2 - x y )  2halve 2rot 2halve 2- 2+ ;

\ find a random position in the rectangle (x,y,x+w,y+h)
: 2rnd  ( x y - x y )  rnd swap rnd swap ;
: somewhere  ( x y w h - x y )  2rnd 2+ ;

\ find if 2 rectangles (x1,y1,x2,y2) and (x3,y3,x4,y4) overlap.
: overlap? ( xyxy xyxy - flag )
  2swap 2rot rot >= -rot <= and >r rot >= -rot <= and r> and ;

: within?  ( xy xyxy - flag )  2>r 2>r 2dup 2r> 2r> overlap? ;


	INCLUDE 'VICMAIN_FOR'
	SUBROUTINE MAIN44
C
C       10-91  REA  REWRITTEN
C	10-02  REA  Second input file option added. The second input, if used,
C		    holds the filter window, and overrides the NLW, NSW, SYMM,
C		    and WEIGHTS parameters.
C
	PARAMETER (MAXSIZE=90000)
	EXTERNAL FILT
	REAL*4 WTS(MAXSIZE),BUF(5000)
	CHARACTER*4 FORMAT
	LOGICAL XVPTST,QLCYCLE,QSCYCLE,QINT
	COMMON /FLTCOM/ INUNIT,IOUTUNIT,ISL,ISS,NL,NS,NLIN,NSIN,
     +			OFFSET,GAIN,DIV,XMIN,XMAX,QLCYCLE,QSCYCLE,QINT
C
C						open datasets, check size field
	CALL XVUNIT(INUNIT,'INP',1,ISTAT,' ')
	CALL XVOPEN(INUNIT,ISTAT,'U_FORMAT','REAL','OPEN_ACT','SA',
     +		  'IO_ACT','SA',' ')
	CALL XVSIZE(ISL,ISS,NL,NS,NLIN,NSIN)
	IF(ISL+NL-1 .GT. NLIN) THEN
	    CALL XVMESSAGE(
     +             ' Number of lines requested exceeds input size',' ')
	    CALL ABEND
	ENDIF
	IF(ISS+NS-1 .GT. NSIN) THEN
	    CALL XVMESSAGE(
     +             ' Number of samples requested exceeds input size',
     +		   ' ')
	    CALL ABEND
	ENDIF
	CALL XVUNIT(IOUTUNIT,'OUT',1,ISTAT,' ')
	CALL XVOPEN(IOUTUNIT,ISTAT,'OP','WRITE','U_FORMAT','REAL',
     &		  'OPEN_ACT','SA','IO_ACT','SA','U_NL',NL,'U_NS',NS,' ')
C
C						determine default cutoff values
	CALL XVGET(INUNIT,ISTAT,'FORMAT',FORMAT,' ')
	IF (FORMAT .EQ. 'BYTE') THEN
	    XMIN = 0.0
	    XMAX = 255.0
	    QINT = .TRUE.
	ELSE IF (FORMAT .EQ. 'HALF') THEN
	    XMIN = -32768.0
	    XMAX = 32767.0
	    QINT = .TRUE.
	ELSE IF (FORMAT .EQ. 'FULL') THEN
	    XMIN = -2147483000
	    XMAX =  2147483000
	    QINT = .TRUE.
	ELSE
	    XMIN = -1.0E33
	    XMAX =  1.0E33
	    QINT = .FALSE.
	END IF
C							  check for second input
C							 and process, if present
	CALL XVPCNT('INP',ICOUNT)
	IF (ICOUNT .EQ. 2) THEN
	    CALL XVUNIT(INUNIT2,'INP',2,ISTAT,' ')
	    CALL XVOPEN(INUNIT2,ISTAT,'U_FORMAT','REAL','OPEN_ACT','SA',
     +			'IO_ACT','SA',' ')
	    CALL XVGET(INUNIT2,ISTAT,'NL',NLW,'NS',NSW,' ')
	    INDEX = 1
	    DO I=1,NLW
		IF (INDEX+NSW-1 .GT. MAXSIZE) THEN
		    CALL XVMESSAGE(
     +			'The filter window is too large to process',' ')
		    CALL ABEND
		ENDIF
		CALL XVREAD(INUNIT2,WTS(INDEX),ISTAT,' ')
		INDEX = INDEX + NSW
	    END DO
	ELSE
C						process NLW, NSW, SYMM & WEIGHTS

	    CALL XVP('NLW',NLW,ICOUNT)
	    CALL XVP('NSW',NSW,ICOUNT)
C							    build weights matrix
	    CALL XVPARM('WEIGHTS',BUF,ICOUNT,IDEF,0)
	    IF (XVPTST('ALL') .OR. XVPTST('ASYMMETR')) THEN
		IF (ICOUNT .NE. NLW*NSW) THEN
		    CALL XVMESSAGE(
     +			' NLW*NSW weights values must be provided',' ')
		    CALL ABEND
		ENDIF
		CALL MVE(7,ICOUNT,BUF,WTS,1,1)
	    ELSE IF (XVPTST('UPPER').OR.XVPTST('NONSYMME')) THEN
		IF (ICOUNT .NE. NSW*((NLW+1)/2)) THEN
		    CALL XVMESSAGE(
     +		  'NSW*((NLW+1)/2) weights values must be provided',' ')
		    CALL ABEND
		ENDIF
		CALL MVE(7,ICOUNT,BUF,WTS,1,1)
		LOC1 = ICOUNT - 2*NSW + 1
		LOC2 = ICOUNT + 1
		DO I=1,NLW/2
		    CALL MVE(7,NSW,BUF(LOC1),WTS(LOC2),1,1)
		    LOC1 = LOC1 - NSW
		    LOC2 = LOC2 + NSW
		END DO
	    ELSE IF (XVPTST('LEFT')) THEN
		IF (ICOUNT .NE. NLW*((NSW+1)/2)) THEN
		    CALL XVMESSAGE(
     +		    'NLW*((NSW+1)/2) weights values must be provided',' ')
		    CALL ABEND
		ENDIF
		LOC1 = 1
		LOC2 = 1
		NUM = (NSW+1)/2
		DO I=1,NLW
		    CALL MVE(7,NUM,BUF(LOC1),WTS(LOC2),1,1)
		    CALL MVE(7,NUM-1,BUF(LOC1+NUM-2),WTS(LOC2+NUM),-1,1)
		    LOC1 = LOC1 + NUM
		    LOC2 = LOC2 + NSW
		END DO
	    ELSE
		IF (ICOUNT .NE. ((NLW+1)/2)*((NSW+1)/2) ) THEN
		    CALL XVMESSAGE(
     +	' ((NLW+1)/2) * ((NSW+1)/2) weights values must be provided',' ')
		    CALL ABEND
		ENDIF
		LOC1 = 1
		LOC2 = 1
		NUM = (NSW+1)/2
		DO I=1,(NLW+1)/2
		    CALL MVE(7,NUM,BUF(LOC1),WTS(LOC2),1,1)
		    CALL MVE(7,NUM-1,BUF(LOC1+NUM-2),WTS(LOC2+NUM),-1,1)
		    LOC1 = LOC1 + NUM
		    LOC2 = LOC2 + NSW
		END DO
		LOC1 = LOC1 - 2*NUM
		DO I=1,(NLW-1)/2
		    CALL MVE(7,NUM,BUF(LOC1),WTS(LOC2),1,1)
		    CALL MVE(7,NUM-1,BUF(LOC1+NUM-2),WTS(LOC2+NUM),-1,1)
		    LOC1 = LOC1 - NUM
		    LOC2 = LOC2 + NSW
		END DO
	    END IF
	END IF
C
	IF((NLW/2)*2 .EQ. NLW) THEN
	    CALL XVMESSAGE(' NLW cannot be an even integer',' ')
	    CALL ABEND
	ENDIF
	IF((NSW/2)*2 .EQ. NSW) THEN
	    CALL XVMESSAGE(' NSW cannot be an even integer',' ')
	    CALL ABEND
	ENDIF
C
	CALL XVP('SCALE',BUF,ICOUNT)
	OFFSET = BUF(1)
	GAIN = BUF(2)
C
	CALL XVP('RANGE',BUF,ICOUNT)
	IF (ICOUNT .EQ. 2) THEN
	    XMIN = BUF(1)
	    XMAX = BUF(2)
	ELSE
	    CALL XVP('DNMIN',BUF,ICOUNT)
	    IF (ICOUNT .EQ. 1) XMIN = BUF(1)
	    CALL XVP('DNMAX',XMAX,ICOUNT)
	    IF (ICOUNT .EQ. 1) XMAX = BUF(1)
	END IF
C							edge treatment
	IF (XVPTST('CYCLE')) THEN
	    QLCYCLE = .TRUE.
	    QSCYCLE = .TRUE.
	ELSE
	    QLCYCLE = XVPTST('LCYCLE')
	    QSCYCLE = XVPTST('SCYCLE')
	END IF
	CALL XVP('DIVIDE',DIV,ICOUNT)
	IF ( ICOUNT .EQ. 0) THEN
	    DIV = 0.0
	    DO I=1,NLW*NSW
		DIV = DIV + WTS(I)
	    END DO
	END IF
	IF (DIV .EQ. 0.0) DIV = 1.0
C
	NSX = NS + NSW
	NSO = NS
	N1 = 4*NLW*NSX				! bytes in input array
	N2 = 4*NSO				! bytes in output array
C
	CALL STACKA(9,FILT,2,N1,N2,WTS,NSX,NLW,NSW,NSO)
C
	CALL XVCLOSE(IUNIT,STAT,' ')
	CALL XVCLOSE(OUNIT,STAT,' ')
	RETURN
	END
C**********************************************************************
	SUBROUTINE FILT(BUF,N1,OUT,N2,WTS,NSX,NLW,NSW,NSO)
C
	REAL BUF(NSX,NLW),OUT(NSO),WTS(NSW,NLW)
	LOGICAL QLCYCLE,QSCYCLE,QINT
	COMMON /FLTCOM/ INUNIT,IOUTUNIT,ISL,ISS,NL,NS,NLIN,NSIN,
     +			OFFSET,GAIN,DIV,XMIN,XMAX,QLCYCLE,QSCYCLE,QINT
C
	NLW2 = NLW/2			! half of the line weights
	NSW2 = NSW/2			! half of the sample weights
	IST = MAX(ISS-NSW2,1)		! first sample to be read in
	LAST = MIN(ISS+NS+NSW2-1,NSIN)	! last sample to be read in
	NLEFT = IST - ISS + NSW2	! number of pixels to pad on left
	NRIGHT = NS + NSW2 - LAST 	! number of pixels to pad on right
	NSREAD = LAST - IST + 1		! number of samples to be read
	LOC = NLW			! line position in input buffer
C
C						Set up input buffer
	DO LINE = ISL+NLW2, ISL-NLW2, -1
	    IF (LINE .GE. 1) THEN
		CALL XVREAD(INUNIT,BUF(NLEFT+1,LOC),ISTAT,'LINE',LINE,
     +			    'SAMP',IST,'NSAMPS',NSREAD,' ')
		IF (QSCYCLE) THEN
		    CALL CYCLE(BUF(1,LOC),NLEFT,NRIGHT,NS+2*NSW2)
		ELSE
		    CALL REFLCT(BUF(1,LOC),NLEFT,NRIGHT,NS+2*NSW2)
		END IF
	    ELSE
		IF (QLCYCLE) THEN
		    CALL XVREAD(INUNIT,BUF(NLEFT+1,LOC),ISTAT,'LINE',
     +			       NLIN+LINE,'SAMP',IST,'NSAMPS',NSREAD,' ')
		    IF (QSCYCLE) THEN
			CALL CYCLE(BUF(1,LOC),NLEFT,NRIGHT,NS+2*NSW2)
		    ELSE
			CALL REFLCT(BUF(1,LOC),NLEFT,NRIGHT,NS+2*NSW2)
		    END IF
		ELSE
		    CALL MVE(7,NS+NSW-1,BUF(1,NLW-LOC),BUF(1,LOC),1,1)
		END IF
	    END IF
	    LOC = LOC - 1
	END DO
C
	LOC = 1					!location for next line into BUF
	LINE = ISL + NLW2 +1			!line number of next line
C						   looping thru all output lines
	DO L=1,NL
C						    compute value for each pixel
	    DO ISAMP=1,NS
		SUM = 0.0
		DO I=1,NLW
		    LLOC = MOD(LOC+I-2,NLW) + 1
		    DO J=1,NSW
			SUM = SUM + WTS(J,I)*BUF(ISAMP+J-1,LLOC)
		    END DO
		END DO
		SUM = GAIN*(SUM/DIV) + OFFSET
		OUT(ISAMP) = MIN(MAX(SUM,XMIN), XMAX)
		IF (QINT) OUT(ISAMP) = NINT(OUT(ISAMP))
	    END DO
	    CALL XVWRIT(IOUTUNIT,OUT,ISTAT,'NSAMPS',NS,' ')
C							read in next needed line
	    IF (LINE .LE. NLIN) THEN
		CALL XVREAD(INUNIT,BUF(NLEFT+1,LOC),ISTAT,'LINE',LINE,
     +			    'SAMP',IST,'NSAMPS',NSREAD,' ')
		IF (QSCYCLE) THEN
		    CALL CYCLE(BUF(1,LOC),NLEFT,NRIGHT,NS+2*NSW2)
		ELSE
		    CALL REFLCT(BUF(1,LOC),NLEFT,NRIGHT,NS+2*NSW2)
		END IF
	    ELSE
		IF (QLCYCLE) THEN
		    CALL XVREAD(INUNIT,BUF(NLEFT+1,LOC),ISTAT,'LINE',
     +			       LINE-NLIN,'SAMP',IST,'NSAMPS',NSREAD,' ')
		    IF (QSCYCLE) THEN
			CALL CYCLE(BUF(1,LOC),NLEFT,NRIGHT,NS+2*NSW2)
		    ELSE
			CALL REFLCT(BUF(1,LOC),NLEFT,NRIGHT,NS+2*NSW2)
		    END IF
		ELSE
		    LOC2 = LOC - (LINE - NLIN)
		    IF (LOC2 .LT. 1) LOC2=LOC2+NLW
		    CALL MVE(7,NS+NSW-1,BUF(1,LOC2),BUF(1,LOC),1,1)
		END IF
	    END IF
	    LOC = LOC + 1
	    IF (LOC .GT. NLW) LOC = 1
	    LINE = LINE + 1
	END DO
	RETURN
	END
C******************************************************************************
	SUBROUTINE CYCLE(BUF,NLEFT,NRIGHT,LEN)
C
	REAL BUF(LEN)
C
	N = LEN - NLEFT - NRIGHT
	DO I=1,NLEFT
	    BUF(I) = BUF(I+N)
	END DO
	DO I=LEN-NRIGHT+1, LEN
	    BUF(I) = BUF(I-N)
	END DO
	RETURN
	END
C******************************************************************************
	SUBROUTINE REFLCT(BUF,NLEFT,NRIGHT,LEN)
C
	REAL BUF(LEN)
C
	DO I=1,NLEFT
	    BUF(I) = BUF(2*NLEFT-I+1)
	END DO
	DO I=1,NRIGHT
	    BUF(LEN-I+1) = BUF(LEN-2*NRIGHT+I)
	END DO
	RETURN
	END


*> \brief \b ZGET51
*
*  =========== DOCUMENTATION ===========
*
* Online html documentation available at
*            http://www.netlib.org/lapack/explore-html/
*
*  Definition:
*  ===========
*
*       SUBROUTINE ZGET51( ITYPE, N, A, LDA, B, LDB, U, LDU, V, LDV, WORK,
*                          RWORK, RESULT )
*
*       .. Scalar Arguments ..
*       INTEGER            ITYPE, LDA, LDB, LDU, LDV, N
*       DOUBLE PRECISION   RESULT
*       ..
*       .. Array Arguments ..
*       DOUBLE PRECISION   RWORK( * )
*       COMPLEX*16         A( LDA, * ), B( LDB, * ), U( LDU, * ),
*      $                   V( LDV, * ), WORK( * )
*       ..
*
*
*> \par Purpose:
*  =============
*>
*> \verbatim
*>
*>      ZGET51  generally checks a decomposition of the form
*>
*>              A = U B VC>
*>      where * means conjugate transpose and U and V are unitary.
*>
*>      Specifically, if ITYPE=1
*>
*>              RESULT = | A - U B V* | / ( |A| n ulp )
*>
*>      If ITYPE=2, then:
*>
*>              RESULT = | A - B | / ( |A| n ulp )
*>
*>      If ITYPE=3, then:
*>
*>              RESULT = | I - UU* | / ( n ulp )
*> \endverbatim
*
*  Arguments:
*  ==========
*
*> \param[in] ITYPE
*> \verbatim
*>          ITYPE is INTEGER
*>          Specifies the type of tests to be performed.
*>          =1: RESULT = | A - U B V* | / ( |A| n ulp )
*>          =2: RESULT = | A - B | / ( |A| n ulp )
*>          =3: RESULT = | I - UU* | / ( n ulp )
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*>          N is INTEGER
*>          The size of the matrix.  If it is zero, ZGET51 does nothing.
*>          It must be at least zero.
*> \endverbatim
*>
*> \param[in] A
*> \verbatim
*>          A is COMPLEX*16 array, dimension (LDA, N)
*>          The original (unfactored) matrix.
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*>          LDA is INTEGER
*>          The leading dimension of A.  It must be at least 1
*>          and at least N.
*> \endverbatim
*>
*> \param[in] B
*> \verbatim
*>          B is COMPLEX*16 array, dimension (LDB, N)
*>          The factored matrix.
*> \endverbatim
*>
*> \param[in] LDB
*> \verbatim
*>          LDB is INTEGER
*>          The leading dimension of B.  It must be at least 1
*>          and at least N.
*> \endverbatim
*>
*> \param[in] U
*> \verbatim
*>          U is COMPLEX*16 array, dimension (LDU, N)
*>          The unitary matrix on the left-hand side in the
*>          decomposition.
*>          Not referenced if ITYPE=2
*> \endverbatim
*>
*> \param[in] LDU
*> \verbatim
*>          LDU is INTEGER
*>          The leading dimension of U.  LDU must be at least N and
*>          at least 1.
*> \endverbatim
*>
*> \param[in] V
*> \verbatim
*>          V is COMPLEX*16 array, dimension (LDV, N)
*>          The unitary matrix on the left-hand side in the
*>          decomposition.
*>          Not referenced if ITYPE=2
*> \endverbatim
*>
*> \param[in] LDV
*> \verbatim
*>          LDV is INTEGER
*>          The leading dimension of V.  LDV must be at least N and
*>          at least 1.
*> \endverbatim
*>
*> \param[out] WORK
*> \verbatim
*>          WORK is COMPLEX*16 array, dimension (2*N**2)
*> \endverbatim
*>
*> \param[out] RWORK
*> \verbatim
*>          RWORK is DOUBLE PRECISION array, dimension (N)
*> \endverbatim
*>
*> \param[out] RESULT
*> \verbatim
*>          RESULT is DOUBLE PRECISION
*>          The values computed by the test specified by ITYPE.  The
*>          value is currently limited to 1/ulp, to avoid overflow.
*>          Errors are flagged by RESULT=10/ulp.
*> \endverbatim
*
*  Authors:
*  ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date November 2011
*
*> \ingroup complex16_eig
*
*  =====================================================================
      SUBROUTINE ZGET51( ITYPE, N, A, LDA, B, LDB, U, LDU, V, LDV, WORK,
     $                   RWORK, RESULT )
*
*  -- LAPACK test routine (version 3.4.0) --
*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*     November 2011
*
*     .. Scalar Arguments ..
      INTEGER            ITYPE, LDA, LDB, LDU, LDV, N
      DOUBLE PRECISION   RESULT
*     ..
*     .. Array Arguments ..
      DOUBLE PRECISION   RWORK( * )
      COMPLEX*16         A( LDA, * ), B( LDB, * ), U( LDU, * ),
     $                   V( LDV, * ), WORK( * )
*     ..
*
*  =====================================================================
*
*     .. Parameters ..
      DOUBLE PRECISION   ZERO, ONE, TEN
      PARAMETER          ( ZERO = 0.0D+0, ONE = 1.0D+0, TEN = 10.0D+0 )
      COMPLEX*16         CZERO, CONE
      PARAMETER          ( CZERO = ( 0.0D+0, 0.0D+0 ),
     $                   CONE = ( 1.0D+0, 0.0D+0 ) )
*     ..
*     .. Local Scalars ..
      INTEGER            JCOL, JDIAG, JROW
      DOUBLE PRECISION   ANORM, ULP, UNFL, WNORM
*     ..
*     .. External Functions ..
      DOUBLE PRECISION   DLAMCH, ZLANGE
      EXTERNAL           DLAMCH, ZLANGE
*     ..
*     .. External Subroutines ..
      EXTERNAL           ZGEMM, ZLACPY
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          DBLE, MAX, MIN
*     ..
*     .. Executable Statements ..
*
      RESULT = ZERO
      IF( N.LE.0 )
     $   RETURN
*
*     Constants
*
      UNFL = DLAMCH( 'Safe minimum' )
      ULP = DLAMCH( 'Epsilon' )*DLAMCH( 'Base' )
*
*     Some Error Checks
*
      IF( ITYPE.LT.1 .OR. ITYPE.GT.3 ) THEN
         RESULT = TEN / ULP
         RETURN
      END IF
*
      IF( ITYPE.LE.2 ) THEN
*
*        Tests scaled by the norm(A)
*
         ANORM = MAX( ZLANGE( '1', N, N, A, LDA, RWORK ), UNFL )
*
         IF( ITYPE.EQ.1 ) THEN
*
*           ITYPE=1: Compute W = A - UBV'
*
            CALL ZLACPY( ' ', N, N, A, LDA, WORK, N )
            CALL ZGEMM( 'N', 'N', N, N, N, CONE, U, LDU, B, LDB, CZERO,
     $                  WORK( N**2+1 ), N )
*
            CALL ZGEMM( 'N', 'C', N, N, N, -CONE, WORK( N**2+1 ), N, V,
     $                  LDV, CONE, WORK, N )
*
         ELSE
*
*           ITYPE=2: Compute W = A - B
*
            CALL ZLACPY( ' ', N, N, B, LDB, WORK, N )
*
            DO 20 JCOL = 1, N
               DO 10 JROW = 1, N
                  WORK( JROW+N*( JCOL-1 ) ) = WORK( JROW+N*( JCOL-1 ) )
     $                - A( JROW, JCOL )
   10          CONTINUE
   20       CONTINUE
         END IF
*
*        Compute norm(W)/ ( ulp*norm(A) )
*
         WNORM = ZLANGE( '1', N, N, WORK, N, RWORK )
*
         IF( ANORM.GT.WNORM ) THEN
            RESULT = ( WNORM / ANORM ) / ( N*ULP )
         ELSE
            IF( ANORM.LT.ONE ) THEN
               RESULT = ( MIN( WNORM, N*ANORM ) / ANORM ) / ( N*ULP )
            ELSE
               RESULT = MIN( WNORM / ANORM, DBLE( N ) ) / ( N*ULP )
            END IF
         END IF
*
      ELSE
*
*        Tests not scaled by norm(A)
*
*        ITYPE=3: Compute  UU' - I
*
         CALL ZGEMM( 'N', 'C', N, N, N, CONE, U, LDU, U, LDU, CZERO,
     $               WORK, N )
*
         DO 30 JDIAG = 1, N
            WORK( ( N+1 )*( JDIAG-1 )+1 ) = WORK( ( N+1 )*( JDIAG-1 )+
     $         1 ) - CONE
   30    CONTINUE
*
         RESULT = MIN( ZLANGE( '1', N, N, WORK, N, RWORK ),
     $            DBLE( N ) ) / ( N*ULP )
      END IF
*
      RETURN
*
*     End of ZGET51
*
      END


      subroutine getstrl( y, x, ien, strnrm, shgl, shp )

      include "common.h"

      dimension y(nshg,5)
      dimension x(numnp,3),            xl(npro,nenl,3)
      dimension ien(npro,nshl),        yl(npro,nshl,5),
     &          u1(npro),              u2(npro),
     &          u3(npro),              dxdxi(npro,nsd,nsd),
     &          strnrm(npro,maxsh),    dxidx(npro,nsd,nsd),
     &          shgl(nsd,nshl,maxsh),       shg(npro,nshl,nsd),
     &          shp(nshl,maxsh)
      dimension tmp(npro),             fresli(npro,24)

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

      if(matflg(1,1).eq.0) then ! compressible
      yl (:,:,1) = yl(:,:,1) / (Rgas * yl(:,:,5))
      else
      yl (:,:,1) = one
      endif

      do intp = 1, ngauss

c  calculate the metrics
c
c
c.... --------------------->  Element Metrics  <-----------------------
c
c.... compute the deformation gradient
c
        dxdxi = zero
c
          do n = 1, nenl
            dxdxi(:,1,1) = dxdxi(:,1,1) + xl(:,n,1) * shgl(1,n,intp)
            dxdxi(:,1,2) = dxdxi(:,1,2) + xl(:,n,1) * shgl(2,n,intp)
            dxdxi(:,1,3) = dxdxi(:,1,3) + xl(:,n,1) * shgl(3,n,intp)
            dxdxi(:,2,1) = dxdxi(:,2,1) + xl(:,n,2) * shgl(1,n,intp)
            dxdxi(:,2,2) = dxdxi(:,2,2) + xl(:,n,2) * shgl(2,n,intp)
            dxdxi(:,2,3) = dxdxi(:,2,3) + xl(:,n,2) * shgl(3,n,intp)
            dxdxi(:,3,1) = dxdxi(:,3,1) + xl(:,n,3) * shgl(1,n,intp)
            dxdxi(:,3,2) = dxdxi(:,3,2) + xl(:,n,3) * shgl(2,n,intp)
            dxdxi(:,3,3) = dxdxi(:,3,3) + xl(:,n,3) * shgl(3,n,intp)
          enddo
c
c.... compute the inverse of deformation gradient
c
        dxidx(:,1,1) =   dxdxi(:,2,2) * dxdxi(:,3,3)
     &                 - dxdxi(:,3,2) * dxdxi(:,2,3)
        dxidx(:,1,2) =   dxdxi(:,3,2) * dxdxi(:,1,3)
     &                 - dxdxi(:,1,2) * dxdxi(:,3,3)
        dxidx(:,1,3) =   dxdxi(:,1,2) * dxdxi(:,2,3)
     &                 - dxdxi(:,1,3) * dxdxi(:,2,2)
        tmp          = one / ( dxidx(:,1,1) * dxdxi(:,1,1)
     &                       + dxidx(:,1,2) * dxdxi(:,2,1)
     &                       + dxidx(:,1,3) * dxdxi(:,3,1) )
        dxidx(:,1,1) = dxidx(:,1,1) * tmp
        dxidx(:,1,2) = dxidx(:,1,2) * tmp
        dxidx(:,1,3) = dxidx(:,1,3) * tmp
        dxidx(:,2,1) = (dxdxi(:,2,3) * dxdxi(:,3,1)
     &                - dxdxi(:,2,1) * dxdxi(:,3,3)) * tmp
        dxidx(:,2,2) = (dxdxi(:,1,1) * dxdxi(:,3,3)
     &                - dxdxi(:,3,1) * dxdxi(:,1,3)) * tmp
        dxidx(:,2,3) = (dxdxi(:,2,1) * dxdxi(:,1,3)
     &                - dxdxi(:,1,1) * dxdxi(:,2,3)) * tmp
        dxidx(:,3,1) = (dxdxi(:,2,1) * dxdxi(:,3,2)
     &                - dxdxi(:,2,2) * dxdxi(:,3,1)) * tmp
        dxidx(:,3,2) = (dxdxi(:,3,1) * dxdxi(:,1,2)
     &                - dxdxi(:,1,1) * dxdxi(:,3,2)) * tmp
        dxidx(:,3,3) = (dxdxi(:,1,1) * dxdxi(:,2,2)
     &                - dxdxi(:,1,2) * dxdxi(:,2,1)) * tmp
c

      fresli=zero
      do i=1,nshl
        fresli(:,22) = fresli(:,22)+shp(i,intp)*yl(:,i,1)  ! density at qpt
c       fresli(:,24) = fresli(:,24)+shp(i,intp)*yl(:,i,5)  !temperature at qpt
      enddo
c
c
c     fresli(:,22)=fresli(:,22)*wght
c     fresli(:,24)=fresli(:,24)*wght

      do n = 1,nshl
        shg(:,n,1) = (shgl(1,n,intp) * dxidx(:,1,1)
     &              + shgl(2,n,intp) * dxidx(:,2,1)
     &              + shgl(3,n,intp) * dxidx(:,3,1))
        shg(:,n,2) = (shgl(1,n,intp) * dxidx(:,1,2)
     &              + shgl(2,n,intp) * dxidx(:,2,2)
     &              + shgl(3,n,intp) * dxidx(:,3,2))
        shg(:,n,3) = (shgl(1,n,intp) * dxidx(:,1,3)
     &              + shgl(2,n,intp) * dxidx(:,2,3)
     &              + shgl(3,n,intp) * dxidx(:,3,3))
      enddo

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

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

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

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

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

      enddo !end of loop over integration points

      return
      end


      SUBROUTINE BDLAAPP( ISIDE, M, N, NB, A, LDA, NITRAF, ITRAF,
     $                    DTRAF, WORK )
      IMPLICIT NONE
*
*     .. Scalar Arguments ..
      INTEGER            ISIDE, LDA, M, N, NB, NITRAF
*     ..
*     .. Array Arguments ..
      INTEGER            ITRAF( * )
      DOUBLE PRECISION   A( LDA, * ), DTRAF( * ), WORK( * )
*
*
*  Purpose
*  =======
*
*  BDLAAPP computes
*
*          B = Q**T * A       or       B = A * Q,
*
*  where A is an M-by-N matrix and Q is an orthogonal matrix represented
*  by the parameters in the arrays ITRAF and DTRAF as described in
*  BDTREXC.
*
*  This is an auxiliary routine called by BDTRSEN.
*
*  Arguments
*  =========
*
*  ISIDE   (input) INTEGER
*          Specifies whether Q multiplies A from the left or right as
*          follows:
*          = 0: compute B = Q**T * A;
*          = 1: compute B = A * Q.
*
*  M       (input) INTEGER
*          The number of rows of A.
*
*  N       (input) INTEGER
*          The number of columns of A.
*
*  NB      (input) INTEGER
*          If ISIDE = 0, the Q is applied block column-wise to the rows
*          of A and NB specifies the maximal width of the block columns.
*          If ISIDE = 1, this variable is not referenced.
*
*  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
*          On entry, the matrix A.
*          On exit, A is overwritten by B.
*
*  LDA     (input) INTEGER
*          The leading dimension of the array A. LDA >= max(1,N).
*
*  NITRAF  (input) INTEGER
*          Length of the array ITRAF. NITRAF >= 0.
*
*  ITRAF   (input) INTEGER array, length NITRAF
*          List of parameters for representing the transformation
*          matrix Q, see BDTREXC.
*
*  DTRAF   (output) DOUBLE PRECISION array, length k, where
*          List of parameters for representing the transformation
*          matrix Q, see BDTREXC.
*
*  WORK    (workspace) DOUBLE PRECISION array, dimension (N)
*
*  =====================================================================
*

*     .. Parameters ..
      DOUBLE PRECISION   ZERO, ONE
      PARAMETER          ( ZERO = 0.0D+0, ONE = 1.0D+0 )
*     ..
*     .. Local Scalars ..
      INTEGER            I, IT, J, NNB, PD
      DOUBLE PRECISION   TAU
*     ..
*     .. External Subroutines ..
      EXTERNAL           DLARFX, DROT
*     .. Intrinsic Functions ..
      INTRINSIC          MIN
*     ..
*     .. Executable Statements ..
*
*     Quick return if possible.
*
      IF( M.LE.0 .OR. N.LE.0 )
     $   RETURN
*
      IF( ISIDE.EQ.0 ) THEN
*
*        Apply Q from left.
*
         DO 20 J = 1, N, NB
            PD = 1
            NNB = MIN( NB, N - J + 1 )
            DO 10 I = 1, NITRAF
               IT = ITRAF(I)
               IF( IT.LE.M ) THEN
*
*                 Apply Givens rotation.
*
                  CALL DROT( NNB, A(IT,J), LDA, A(IT+1,J), LDA,
     $                       DTRAF(PD), DTRAF(PD+1) )
                  PD = PD + 2
               ELSE IF( IT.LE.2*M ) THEN
*
*                 Apply Householder reflector of first kind.
*
                  TAU = DTRAF(PD)
                  DTRAF(PD) = ONE
                  CALL DLARFX( 'Left', 3, NNB, DTRAF(PD), TAU,
     $                         A(IT-M,J), LDA, WORK )
                  DTRAF(PD) = TAU
                  PD = PD + 3
               ELSE
*
*                 Apply Householder reflector of second kind.
*
                  TAU = DTRAF(PD+2)
                  DTRAF(PD+2) = ONE
                  CALL DLARFX( 'Left', 3, NNB, DTRAF(PD), TAU,
     $                         A(IT-2*M,J), LDA, WORK )
                  DTRAF(PD+2) = TAU
                  PD = PD + 3
               END IF
   10       CONTINUE
   20    CONTINUE
      ELSE
         PD = 1
         DO 30 I = 1, NITRAF
            IT = ITRAF(I)
            IF( IT.LE.N ) THEN
*
*              Apply Givens rotation.
*
               CALL DROT( M, A(1,IT), 1, A(1,IT+1), 1, DTRAF(PD),
     $                    DTRAF(PD+1) )
               PD = PD + 2
            ELSE IF( IT.LE.2*N ) THEN
*
*              Apply Householder reflector of first kind.
*
               TAU = DTRAF(PD)
               DTRAF(PD) = ONE
               CALL DLARFX( 'Right', M, 3, DTRAF(PD), TAU, A(1,IT-N),
     $                      LDA, WORK )
               DTRAF(PD) = TAU
               PD = PD + 3
            ELSE
*
*              Apply Householder reflector of second kind.
*
               TAU = DTRAF(PD+2)
               DTRAF(PD+2) = ONE
               CALL DLARFX( 'Right', M, 3, DTRAF(PD), TAU, A(1,IT-2*N),
     $                      LDA, WORK )
               DTRAF(PD+2) = TAU
               PD = PD + 3
            END IF
   30    CONTINUE
      END IF
*
      RETURN
*
*     End of BDLAAPP
*
      END


      subroutine ksinit (x,xlb,xub,scale,work,mdv,mcon,mobj,mside,
     1                   mscale,jprnt,jtmax,jgrad,jsdrst,rdfun,adfun,
     2                   fdelt,fdmin,rhomn,rhomx,rhodl,munit,ireq)
      implicit double precision (a-h,o-z)
      common /kscomm/ rdf   ,adf   ,fdl   ,fdm   ,rho   ,drho  ,rhomax,
     1                fun0  ,slope ,delx  ,alpha ,alpmax,a1    ,a2    ,
     2                a3    ,a4    ,f1    ,f2    ,f3    ,f4    ,alim  ,
     3                atest ,ftest ,ifscl ,ifoff ,isx   ,isx0  ,isxlb ,
     4                isxub ,iscl  ,ig0   ,idf   ,islp  ,iobj0 ,iy    ,
     5                ip    ,ih    ,ihess ,iside ,isact ,idobj ,idg   ,
     6                itmp1 ,itmp2 ,inext ,jnext ,jsel  ,itcnt ,icntr ,
     7                icnta ,isdflg,isdrst,ifncl ,nunit ,ndv   ,ncon  ,
     8                nobj  ,nside ,nscale,iprnt ,itmax ,igrad ,limit
      dimension x(*),xlb(*),xub(*),scale(*),work(*)
c
c          routine to initialize optimization parameters
c          for routine ksopt
c
c          input parameters are
c
c               x     -- initial design variable values
c
c               xlb   -- lower bounds on design variables
c
c               xub   -- upper bounds on design variables
c
c               scale -- scale factors for design variables
c
c               work  -- scratch array
c
c               mdv   -- number of design variables
c
c               mcon  -- number of constraints
c
c               mobj  -- number of objective functions
c
c               mside -- flag  =0 if no side constraints
c
c               mscale-- flag selecting design variable scaling
c                        =0 -- no scaling
c                        <0 -- user supplied scaling in vector scale
c                        >0 -- automatic scaling by ksopt every mscale
c                              iterations
c
c               jprnt -- print level flag (3 digit)
c                        each print level includes all lower print levels
c
c                        hundreds digit - one-dimensional search print
c                                         0 = no print
c                                         1 = alpha and k-s function
c                                         2 = proposed d.v. vector
c
c                        tens     digit - gradient print
c                                         0 = no print
c                                         1 = df and dg
c
c                        ones     digit - d.v. and constraint print
c                                         0 = no print
c                                         1 = initial and final iterations
c                                         2 = all iterations
c                                         3 = slope and search direction
c                                         4 = hessian matrix
c
c               jtmax -- maximum number of iterations
c                        (default is 20)
c
c               jgrad -- flag selecting user supplied information
c                        =0 -- user supplies function and constraints
c                              with gradients computed by finite
c                              differences from within ksopt
c                        =1 -- user supplies all function, constraint,
c                              and gradient information
c                        (default is 0)
c
c               jsdrst-- number of iterations before restarting search
c                        direction with steepest descent
c                        (default is ndv+1)
c
c               rdfun -- relative function change for termination
c                        (default is 0.01)
c
c               adfun -- absolute function change for termination
c                        (default is 0.0)
c
c               fdelt -- step size for computing finite differences
c                        derivatives
c                        (default is 0.01)
c
c               fdmin -- minimum difference for computing
c                        finite differences
c                        (default is 0.0001)
c
c               rhomn -- minimum multiplier for ks function
c                        (default is 5.0)
c
c               rhomx -- maximum multiplier for ks function
c                        (default is 100.0)
c
c               rhodl -- increment for rho
c                        (default is computed internally)
c
c               munit -- fortran unit number for output file
c                        (default is 0)
c
c          output parameters are
c
c               work  -- array containing information required
c                        by routine ksopt.  this array must not
c                        be altered during execution of ksopt.
c
c               ireq  -- required length of work array
c
c          author   - Gregory A. Wrenn
c          location - Lockheed Engineering and Sciences Co.
c                     144 Research Drive
c                     Hampton, Va. 23666
c
c          last modification - 19 July 1996
c
c          these subroutines are compatible with fortran 77
c
      jsel   = 1
      ndv    = mdv
      ncon   = mcon
      nobj   = mobj
      nside  = 0
      nscale = mscale
      iprnt  = 1
      itmax  = 20
      igrad  = 0
      isdrst = jsdrst
      rdf    = 0.01
      adf    = 0.0
      fdl    = 0.01
      fdm    = 0.0001
      rho    = 5.0
      rhomax = 100.0
      drho   = 0.0
      nunit  = 0
      itcnt  = 1
      icntr  = 0
      icnta  = 0
      isdflg = 0
      ifncl  = 0
c
      if (mdv   .le. 0)   ndv   = 0
      if (mcon  .le. 0)   ncon  = 0
      if (mobj  .le. 0)   nobj  = 0
      if (mside .ne. 0)   nside = 1
      if (jprnt .ge. 0)   iprnt = jprnt
      if (jtmax .gt. 0)   itmax = jtmax
      if (jgrad .ne. 0)   igrad = 1
      if (jsdrst.le. 0)   isdrst= ndv + 1
      if (rdfun .gt. 0.0) rdf   = rdfun
      if (adfun .gt. 0.0) adf   = adfun
      if (fdelt .gt. 0.0) fdl   = fdelt
      if (fdmin .gt. 0.0) fdm   = fdmin
      if (rhomn .gt. 0.0) rho   = rhomn
      if (rhomx .ge. rho) rhomax= rhomx
      if (rhodl .gt. 0.0) drho  = rhodl
      if (munit .gt. 0)   nunit = munit
c
      ntmp  = 2 * ndv
      if (ntmp .lt. (nobj + ncon)) ntmp = nobj + ncon
      ifscl = 64
      ifoff = ifscl + nobj
      isx   = ifoff + nobj
      isx0  = isx   + ndv
      isxlb = isx0  + ndv
      isxub = isxlb + ndv
      iscl  = isxub + ndv
      ig0   = iscl  + 2 * ndv
      idf   = ig0   + ncon
      islp  = idf   + ndv
      iobj0 = islp  + ndv
      iy    = iobj0 + nobj
      ip    = iy    + ndv
      ih    = ip    + ndv
      ihess = ih    + ndv * (ndv + 1) / 2
      iside = ihess + ndv * (ndv + 1) / 2
      isact = iside + ndv
      idobj = isact + ndv
      idg   = idobj + nobj * ndv
      itmp1 = idg   + ncon * ndv
      itmp2 = itmp1 + ntmp
      ireq  = itmp2 + ntmp - 1
c
      if (ndv .eq. 0) go to 40
      do 30 i = 1,ndv
        j = i - 1
        xx  = x(i)
        if (nside .eq. 0) go to 20
        xbl = xlb(i)
        xbu = xub(i)
        if (xbl .le. xbu) go to 10
        xb = (xbl + xbu) / 2.0
        xbl = xb
        xbu = xb
   10 continue
        if (xx .lt. xbl) xx = xbl
        if (xx .gt. xbu) xx = xbu
        x(i) = xx
   20 continue
        ss = 1.0
        if (nscale .gt. 0) ss = abs(xx)
        if (nscale .lt. 0) ss = abs(scale(i))
        if (ss .lt. 1.0e-04) ss = 1.0
        work(iscl  + j) = ss
        work(isx   + j) = xx / ss
        work(isx0  + j) = xx / ss
        if (nside .eq. 0) go to 30
        work(isxlb + j) = xbl / ss
        work(isxub + j) = xbu / ss
   30 continue
c
      if (drho .gt. 0.0) go to 40
      drho = (rhomax - rho) / 5.0
      if (drho .lt. 10.0) drho = 10.0
      if (drho .gt. 40.0) drho = 40.0
c
   40 continue
c
      if (iprnt .eq. 0 .and. ndv .gt. 0 .and. nobj .gt. 0) go to 60
      write (nunit,70)
      write (nunit,80) ireq
      if (ndv .eq. 0) write (nunit,90)
      if (nobj .eq. 0) write (nunit,100)
      write (nunit,110) ndv,ncon,nobj,nside,nscale,iprnt,itmax,igrad
      write (nunit,120) rdf,adf,fdl,fdm,rho,rhomax,drho
      if (nside .ne. 0) go to 50
      write (nunit,130)
      write (nunit,140) (i,x(i),work(iscl+i-1),i=1,ndv)
      go to 60
   50 continue
      write (nunit,150)
      write (nunit,160) (i,x(i),work(iscl+i-1),
     1                   work(isxlb+i-1)*work(iscl+i-1),
     2                   work(isxub+i-1)*work(iscl+i-1),i=1,ndv)
   60 continue
      if (ndv .eq. 0 .or. nobj .eq. 0) jsel = 0
      call kscomp (work(1))
      return
c
   70 format (1h1,
     1        20x,40h========================================/
     1        21x,40h=                                      =/
     2        21x,40h=    KSOPT Multiobjective Optimizer    =/
     3        21x,40h=                                      =/
     4        21x,40h=    Version 2.8         19 July 96    =/
     5        21x,40h=                                      =/
     6        21x,40h=    Written by    Gregory A. Wrenn    =/
     7        21x,40h=                                      =/
     8        21x,40h========================================///)
   80 format (10x,43hThe work array must be dimensioned at least,
     1        i10,12h words long.//)
   90 format (/53h   Number of design variables is zero -- optimization,
     1        16h is not possible//)
  100 format (/44h   Number of objective functions is zero -- ,
     1        28hoptimization is not possible//)
  110 format (/10h      ndv=,i5,10h     ncon=,i5,10h     nobj=,i5,
     1         10h    nside=,i5,//10h   nscale=,i5,10h   iprint=,i5,
     2         10h    itmax=,i5,10h    igrad=,i5)
  120 format (/10h    rdfun=,e14.7,2x,10h    adfun=,e14.7/
     1        /10h    fdelt=,e14.7,2x,10h    fdmin=,e14.7/
     2        /10h   rhomin=,e14.7,2x,10h   rhomax=,e14.7,2x,
     3         10h     drho=,e14.7)
  130 format (/42(1h-)/
     1        5x,6h d.v. ,6x,7hinitial,9x,6h scale/
     2        5x,6hnumber,6x,7h value ,9x,6hfactor/
     3        1x,42(1h-))
  140 format (4x,i5,4x,e12.5,4x,e12.5)
  150 format (/73(1h-)/
     1        5x,6h d.v. ,6x,7hinitial,9x,6h scale,10x,5hlower,
     2        11x,5hupper/
     3        5x,6hnumber,6x,7h value ,9x,6hfactor,10x,5hbound,
     4        11x,5hbound/
     5        1x,73(1h-))
  160 format (4x,i5,4x,e12.5,4x,e12.5,4x,e12.5,4x,e12.5)
      end


	SUBROUTINE AF_SLAT  ( clat, clatd, iret )
C************************************************************************
C* AF_SLAT								*
C*									*
C* This subroutine decodes and stores the latitude from AMDAR, AIREP,	*
C* and PIREP reports.							*
C*									*
C* AF_SLAT  ( CLAT, CLATD, IRET )					*
C*									*
C* Input parameters:							*
C*	CLAT		CHAR*		Encoded	latitude 		*
C*	CLATD		CHAR		Direction of latitude 	 	*
C*					  "N" = north, "S" = south	*
C*									*
C* Output parameters:							*
C*	RIVALS (IRSLAT)	REAL		Latitude in degrees		*
C*	IRET		INTEGER		Return code 			*
C*					  0 = normal return 		*
C*					 -1 = error during decoding	*
C*									*
C**									*
C* Log:									*
C* J. Ator/NP12		09/96						*
C* J. Ator/NP12		10/96	Allow AIREP lat/long combination 	*
C* J. Ator/NP12		08/97	New interface format, style changes	*
C* A. Hardy/GSC         03/98   Changed latitude lengths                *
C************************************************************************
	INCLUDE		'GEMPRM.PRM'
	INCLUDE		'afcmn.cmn'
C*
	CHARACTER*(*)	clat
	CHARACTER	clatd
C-----------------------------------------------------------------------
	iret = -1
C
	lclat = LEN ( clat )
	IF  ( ( lclat .eq. 3 ) .or. ( lclat .eq. 4 ) )  THEN
C
C*	    The latitude was reported in degrees and minutes.
C*	    Decode the minutes.
C
	    CALL ST_INTG  ( clat (lclat-1:lclat), iltmin, ier )
	    ldglat = lclat - 2
	    IF  (  ( ier .ne. 0 )  .or.
     +		 ( ( iltmin .lt. 0 ) .or. ( iltmin .gt. 59 ) )  )  THEN
		logmsg = 'latitude minutes '  //  clat (lclat-1:lclat)
		CALL DC_WLOG  ( 2, 'AF', 2, logmsg, ierwlg )
		RETURN
	    END IF
	ELSE IF  ( ( lclat .le. 2 ) .and.
     +		     ( bultyp .ne. AMDAR ) )  THEN
C
C*	    The latitude was reported in degrees.
C
	    iltmin = 0
	    ldglat = lclat
	ELSE
	    logmsg = 'latitude '  //  clat (1:lclat)
	    CALL DC_WLOG  ( 2, 'AF', 2, logmsg, ierwlg )
	    RETURN
	END IF
C
C*	Decode the degrees.
C
        CALL ST_INTG  ( clat (1:ldglat), iltdeg, ier )
	IF  (  ( ier .ne. 0 )  .or.
     +		( ( iltdeg .lt. 0 ) .or. ( iltdeg .gt. 90 ) )  )  THEN
	    logmsg = 'latitude degrees '  //  clat (1:ldglat)
	    CALL DC_WLOG  ( 2, 'AF', 2, logmsg, ierwlg )
	    RETURN
	END IF
C
C*	Compute the latitude.
C
	slat = FLOAT ( iltdeg ) + ( FLOAT ( iltmin ) / 60.0 )
	IF  ( clatd .eq. 'S' )  THEN
	    slat = slat * (-1)
	ELSE IF  ( clatd .ne. 'N' )  THEN
	    logmsg = 'latitude direction '  //  clatd
	    CALL DC_WLOG  ( 2, 'AF', 2, logmsg, ierwlg )
	    RETURN
	END IF
C
C*	Store the latitude.
C
	rivals ( irslat ) = slat
C
	iret = 0
C*
	RETURN
	END