subroutine fprint(no,ncase,neqn,t,u)
!
!
! Subroutine fprint displays the numerical and
! analytical solutions to the 2 x 2 ODE problem
!
! Double precision coding is used
implicit double precision(a-h,o-z)
!
! Size the arrays
dimension u(neqn)
!
! Problem parameters
call par(a,b)
!
! Print a heading for the solution at t = 0
if(t.le.0.0d0)then
!
! Label for ODE integrator
!
! Fixed step modfied Euler
if(ncase.eq.1)then
write(no,11)
11 format(/,6x,'euler2a integrator')
!
! Variable step modified Euler
else if(ncase.eq.2)then
write(no,12)
12 format(/,6x,'euler2b integrator')
!
! Fixed step classical fourth order RK
else if(ncase.eq.3)then
write(no,13)
13 format(/,6x,'rkc4a integrator')
!
! Variable step classical fourth order RK
else if(ncase.eq.4)then
write(no,14)
14 format(/,6x,'rkc4b integrator')
!
! Fixed step RK Fehlberg 45
else if(ncase.eq.5)then
write(no,15)
15 format(/,6x,'rkf45a integrator')
!
! Variable step RK Fehlberg 45
else if(ncase.eq.6)then
write(no,16)
16 format(/,6x,'rkf45b integrator')
end if
!
! Heading
write(no,2)
2 format(/,9x,'t',3x,'u1(num)',4x,'u1(ex)',8x,'diff1',/, &
&10x, 3x,'u2(num)',4x,'u2(ex)',8x,'diff2',/)
!
! End of t = 0 heading
end if
!
! Analytical solution
u1exact=dexp(-(a-b)*t)-dexp(-(a+b)*t)
u2exact=dexp(-(a-b)*t)+dexp(-(a+b)*t)
!
! Difference between exact and numerical solution vectors
diff1=u(1)-u1exact
diff2=u(2)-u2exact
!
! Display the numerical and exact solutions,
! and their difference
write(no,3)t,u(1),u1exact,diff1,u(2),u2exact,diff2
3 format(f10.2,2f10.5,e13.4,/,10x,2f10.5,e13.4,/)
return
!
! End of fprint
end


      MODULE mtxmc_I
      INTERFACE
!...Generated by Pacific-Sierra Research 77to90  4.4G  08:27:20  03/09/06
      SUBROUTINE mtxmc (A, NAR, B, NBR, C)
      USE vast_kind_param,ONLY: DOUBLE
      INTEGER, INTENT(IN) :: NAR, NBR
      REAL(DOUBLE), DIMENSION(NBR,NAR) :: A
      REAL(DOUBLE), DIMENSION(NBR,NAR) :: B
      REAL(DOUBLE), DIMENSION(*) :: C
      END SUBROUTINE
      END INTERFACE
      END MODULE


PROGRAM REAL_KIND
    IMPLICIT NONE

    ! REAL, DIMENSION(20000000) :: A
    ! REAL:: X
    REAL(KIND = 8), DIMENSION(20000000) :: A
    REAL(KIND = 8):: X

    X = SIZE(A) - 1
    PRINT* , x, kind(x), kind(0), kind(0.0)

END PROGRAM REAL_KIND


! DART software - Copyright UCAR. This open source software is provided
! by UCAR, "as is", without charge, subject to all terms of use at
! http://www.image.ucar.edu/DAReS/DART/DART_download
!
! $Id$

PROGRAM convertdate

use time_manager_mod

implicit none

! version controlled file description for error handling, do not edit
character(len=256), parameter :: source   = &
   "$URL$"
character(len=32 ), parameter :: revision = "$Revision$"
character(len=128), parameter :: revdate  = "$Date$"

integer :: direction
type(time_type)   :: atime
integer           :: year, month, day, hour, minute, second
integer           :: jday
integer           :: days, seconds

!  days prior to beginning of each month (non&) leap year

integer, parameter, dimension( 13) :: &
   bgn_day = (/ 0,  31,  59,  90, 120, 151, &
              181, 212, 243, 273, 304, 334, 365 /), &
   bgn_day_ly = (/ 0,  31,  60,  91, 121, 152, &
                 182, 213, 244, 274, 305, 335, 366 /)

!  begin
write(6,*) 'Which direction? '
write(6,*) 'YYYY MM DD HH MM SS ===>  Gregorian day and second  (1)'
write(6,*) 'YYYY MM DD HH MM SS <===  Gregorian day and second  (2)'
write(6,*) 'YYYY MM DD          ===>  Julian day of year YYYY   (3)'
write(6,*) 'YYYY MM DD          <===  Julian day of year YYYY   (4)'

read(5,*) direction

if ( direction == 1 ) then
   write(*,*) 'Input YYYY MM DD HH MM SS: '
   read(*,*) year, month, day, hour, minute, second
   atime=set_date_gregorian(year, month, day, hour, minute, second)
   call get_time (atime, seconds, days)
   write(*,*) 'Gregorian days and second: ', days, seconds

else if ( direction == 2 ) then
   write(*,*) 'Input Gregorian days and second: '
   read(*,*) days, seconds
   atime = set_time(seconds, days)
   call get_date_gregorian(atime, year, month, day, hour, minute, second)
   write (*,FMT='(I4,5I3.2)') year, month, day, hour, minute, second

else if ( direction == 3 ) then
   write(*,*) 'Input YYYY MM DD: '
   read(*,*) year, month, day
   if(isleapyear(year)) then
      jday=bgn_day_ly(month)+day
   else
      jday=bgn_day(month)+day
   endif
   write(*,*) 'Julian day: ', year, jday

else if ( direction == 4 ) then
   write(*,*) 'Input Julian YYYY and JDAY: '
   read(*,*) year, jday
   do month=1,12
      if(isleapyear(year)) then
        if( (jday>bgn_day_ly(month)) .and. (jday<=bgn_day_ly(month+1)) ) then
          day = jday - bgn_day_ly(month)
          exit
        endif
      else
        if( (jday>bgn_day(month)) .and. (jday<=bgn_day(month+1)) ) then
          day = jday - bgn_day(month)
          exit
        endif
      endif
   enddo
   write(*,*) year, month, day
endif

contains

function isleapyear(year)
! check if year is leapyear
implicit none
integer,intent(in) :: year
logical :: isleapyear

if( mod(year,4) .ne. 0 ) then
  isleapyear=.FALSE.
else
  isleapyear=.TRUE.
  if ( mod(year,100) == 0 .and. mod(year,400) .ne. 0 ) isleapyear=.FALSE.
endif
end function isleapyear

end program convertdate

! <next few lines under version control, do not edit>
! $URL$
! $Id$
! $Revision$
! $Date$


      subroutine cbabk2(nm,n,low,igh,scale,m,zr,zi)
c
      integer i,j,k,m,n,ii,nm,igh,low
      double precision scale(n),zr(nm,m),zi(nm,m)
      double precision s
c
c     this subroutine is a translation of the algol procedure
c     cbabk2, which is a complex version of balbak,
c     num. math. 13, 293-304(1969) by parlett and reinsch.
c     handbook for auto. comp., vol.ii-linear algebra, 315-326(1971).
c
c     this subroutine forms the eigenvectors of a complex general
c     matrix by back transforming those of the corresponding
c     balanced matrix determined by  cbal.
c
c     on input
c
c        nm must be set to the row dimension of two-dimensional
c          array parameters as declared in the calling program
c          dimension statement.
c
c        n is the order of the matrix.
c
c        low and igh are integers determined by  cbal.
c
c        scale contains information determining the permutations
c          and scaling factors used by  cbal.
c
c        m is the number of eigenvectors to be back transformed.
c
c        zr and zi contain the real and imaginary parts,
c          respectively, of the eigenvectors to be
c          back transformed in their first m columns.
c
c     on output
c
c        zr and zi contain the real and imaginary parts,
c          respectively, of the transformed eigenvectors
c          in their first m columns.
c
c     questions and comments should be directed to burton s. garbow,
c     mathematics and computer science div, argonne national laboratory
c
c     this version dated august 1983.
c
c     ------------------------------------------------------------------
c
      if (m .eq. 0) go to 200
      if (igh .eq. low) go to 120
c
      do 110 i = low, igh
         s = scale(i)
c     .......... left hand eigenvectors are back transformed
c                if the foregoing statement is replaced by
c                s=1.0d0/scale(i). ..........
         do 100 j = 1, m
            zr(i,j) = zr(i,j) * s
            zi(i,j) = zi(i,j) * s
  100    continue
c
  110 continue
c     .......... for i=low-1 step -1 until 1,
c                igh+1 step 1 until n do -- ..........
  120 do 140 ii = 1, n
         i = ii
         if (i .ge. low .and. i .le. igh) go to 140
         if (i .lt. low) i = low - ii
         k = scale(i)
         if (k .eq. i) go to 140
c
         do 130 j = 1, m
            s = zr(i,j)
            zr(i,j) = zr(k,j)
            zr(k,j) = s
            s = zi(i,j)
            zi(i,j) = zi(k,j)
            zi(k,j) = s
  130    continue
c
  140 continue
c
  200 return
      end


! See the effect of changing diffusivity on plate temperature.
program change_diffusivity

  use bmiheatf
  use testing_helpers, only: print_array
  implicit none

  character (len=*), parameter :: config_file = "test1.cfg"
  character (len=*), parameter :: &
       dname = "plate_surface__thermal_diffusivity"
  character (len=*), parameter :: &
       tname = "plate_surface__temperature"
  double precision, parameter :: end_time = 20.d0

  type (bmi_heat) :: m
  integer :: tgrid_id
  integer, dimension(2) :: tdims
  real :: diffusivity(1), temperature(50)
  integer :: status

  ! Run model to the end with alpha=1.0 (from cfg file).
  status = m%initialize(config_file)
  status = m%get_var_grid(tname, tgrid_id)
  status = m%get_grid_shape(tgrid_id, tdims)
  status = m%get_value(dname, diffusivity)
  status = m%update_until(end_time)
  status = m%get_value(tname, temperature)
  status = m%finalize()

  write(*,"(a)") "Run 1"
  write(*,"(a, f5.2)") "alpha =", diffusivity
  call print_array(temperature, tdims)

  ! Run model to the end with alpha=0.75.
  status = m%initialize(config_file)
  diffusivity = 0.25
  status = m%set_value(dname, diffusivity)
  status = m%update_until(end_time)
  status = m%get_value(tname, temperature)
  status = m%finalize()

  write(*,"(a)") "Run 2"
  write(*,"(a, f5.2)") "alpha =", diffusivity
  call print_array(temperature, tdims)
end program change_diffusivity


! Riemann solver for the LWR traffic model:

! q_t + (u_max q(1-q))_x = 0

! waves: 1
! equations: 1

! Conserved quantities:
!       1 q

! The speed limit umax should be in the common block cparam.

! See http://www.clawpack.org/riemann.html for a detailed explanation
! of the Riemann solver API.

subroutine rp1(maxm,num_eqn,num_waves,num_aux,num_ghost,num_cells, &
               ql,qr,auxl,auxr,wave,s,amdq,apdq)

    implicit none

    ! Inputs
    integer, intent(in) :: maxm, num_eqn, num_waves, num_aux, num_ghost, num_cells
    double precision, intent(in), dimension(num_eqn, 1-num_ghost:maxm+num_ghost) :: ql,qr
    double precision, intent(in), dimension(num_aux, 1-num_ghost:maxm+num_ghost) :: auxl,auxr
    ! Outputs
    double precision, intent(out) :: s(num_waves,1-num_ghost:num_cells+num_ghost)
    double precision, intent(out) :: wave(num_eqn,num_waves,1-num_ghost:num_cells+num_ghost)
    double precision, intent(out), dimension(num_eqn, 1-num_ghost:maxm+num_ghost) :: amdq,apdq
    ! Locals
    double precision :: sim1, si, flux0, fluxim1, fluxi
    integer :: i

    common /cparam/ umax
    double precision :: umax

    do i=2-num_ghost,num_cells+num_ghost
        ! Compute the wave and speed

        wave(1,1,i) = ql(1,i) - qr(1,i-1)
        s(1,i) = umax * (1.d0 - (qr(1,i-1) + ql(1,i)))

        ! compute left-going and right-going flux differences:
        !------------------------------------------------------
        amdq(1,i) = dmin1(s(1,i), 0.d0) * wave(1,1,i)
        apdq(1,i) = dmax1(s(1,i), 0.d0) * wave(1,1,i)

        ! entropy fix for transonic rarefactions:
        sim1 = umax*(1.d0 - 2.d0*qr(1,i-1))
        si = umax*(1.d0 - 2.d0*ql(1,i))
        if (sim1.lt.0.d0 .and. si.gt.0.d0) then
            flux0 = 0.25d0*umax
            fluxim1 = qr(1,i-1)*umax*(1.d0 - qr(1,i-1))
            fluxi   = ql(1,i)*umax*(1.d0 - ql(1,i))
            amdq(1,i) = flux0 - fluxim1
            apdq(1,i) = fluxi - flux0
        endif
    enddo

    return
end subroutine rp1


      PROGRAM wraplos
c----
c Convert a line of sight displacement to a phase difference given
c the wavelength of the InSAR satellite.
c----
      IMPLICIT NONE
      REAL*8 pi,tpi
      PARAMETER (pi=4.0d0*datan(1.0d0),tpi=2.0d0*pi)
      REAL*8 stlo,stla,stdp,ulos,wvl,phase
      CHARACTER*40 ifile,ofile
      LOGICAL ex

      call gcmdln(wvl,ifile,ofile)
      if (wvl.le.0.0d0) then
          write(*,*) '!! Error: wavelength is undefined'
          call usage('!! Use -w WVLNTH')
      endif
      if (ifile.eq.'none') then
          write(*,*) '!! Error: Input LOS vector file unspecified'
          call usage('!! Use -f IFILE to specify input file')
      else
          inquire(file=ifile,EXIST=ex)
          if (.not.ex) call usage('!! Error: no input file: '//ifile)
      endif
      if (ofile.eq.'none') then
          write(*,*) '!! Error: No output file specified'
          call usage('!! Use -o OFILE to specify phase output file')
      endif

      open (unit=10,file=ifile,status='old')
      open (unit=20,file=ofile,status='unknown')

c----
c Convert line of sight displacement to phase difference from satellite
c----
   13 read (10,*,end=14) stlo,stla,stdp,ulos
          ulos = 100.0d0*ulos
          phase = 2.0d0*tpi*ulos/wvl
          phase = dmod(phase,tpi)
          if (phase.lt.-pi) phase = phase + tpi
          if (phase.gt.pi) phase = phase - tpi
          write (20,9991) stlo,stla,stdp,phase
          goto 13
   14 continue

 9991 format(3F12.4,X,3E12.4)

      END

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

      SUBROUTINE gcmdln(wvl,ifile,ofile)
      IMPLICIT none
      REAL*8 wvl
      CHARACTER*40 tag,ifile,ofile
      INTEGER i,narg
      wvl = -1.0d0
      ifile = 'none'
      ofile = 'none'
      narg = iargc()
      if (narg.eq.0) call usage(' ')
      i = 0
   11 i = i + 1
      if (i.gt.narg) goto 12
          call getarg(i,tag)
          if (tag(1:2).eq.'-w') then
              i = i + 1
              call getarg(i,tag)
              read (tag,'(BN,F12.0)') wvl
          elseif (tag(1:2).eq.'-f') then
              i = i + 1
              call getarg(i,ifile)
          elseif (tag(1:2).eq.'-o') then
              i = i + 1
              call getarg(i,ofile)
          elseif (tag(1:2).eq.'-h') then
              call usage(' ')
          endif
          goto 11
   12 continue
      RETURN
      END

C----------------------------------------------------------------------C

      SUBROUTINE usage(str)
      IMPLICIT none
      INTEGER lstr
      CHARACTER str*(*)
      if (str.ne.' ') then
          lstr = len(str)
          write(*,*) str(1:lstr)
          write(*,*)
      endif
      write(*,*)
     1 'Usage: wraplos -w WVLNTH -f IFILE -o OFILE [-h]'
      write(*,*)
      write(*,*)
     1 '-w WVLNTH  Wavelength of radar signal (cm)'
      write(*,*)
     1 '-f IFILE   Input LOS displacement file (stlo stla stdp uLOS)'
      write(*,*)
     1 '-o OFILE   Output phase file (stlo stla stdp phase(rad))'
      write (*,*)
     1 '-h         Online help (this message)'
      write (*,*)
      STOP
      END


c -------------------------------------------------------------------
      SUBROUTINE DLINMSG(X,NPTS,XMSG,MFLAG,MPTCRT)
c     implicit none

c NCL: xnew = linmsg(x,mflag)

c given a series x of length npts : this routine will linearly
c .   interpolate to fill in the missing pts. missing values at the
c .   beginning and end of the series will be be determined
c .   by the sign of mprcrt.
c
c nomenclature :
c .   x         - input series which may or may not contain msg values
c .   npts      - length of the series
c .   xmsg      - missing code
c .   mflag     - note: if mflag.lt.0 then the missing values at the
c .               beginning and end of the series will be set to the
c .               value of the nearest non-msg value. if mflag.ge.0
c .               then set these values to missing.
c .   mptcrt    - if more than "mptcrt" consecutive values are
c .               encountered, the routine will not interpolate across
c .               that segment. If mptcrt=npts [most common option],
c .               then the routine will interpolate as many values as
c .               it can.
c .
c OTHER variables
c .   ncode     - code number
c .               ncode = -1  : whole series is missing
c .               ncode =  0  : series has no missing points upon return
c .                             to the calling routine. either the serie
c .                             had no missing points or this routine
c .                             has filled them with interpolated values
c .               ncode = nn  : series still has missing values. this
c .                             occurs when iabs(mptcrt) is exceeded.
c .                             nn is the number of missing values
c .                             still present.
c .   nitp      - No. of InTerpolated Points : user shouldcheck
c .               the ratio (nitp/npts)

      INTEGER NPTS,MPTCRT,NCODE,NITP,N,NEND,NSTRT
      DOUBLE PRECISION X(1:NPTS),XMSG
      INTEGER NPTCRT,NN,NBASE
      DOUBLE PRECISION SLOPE
C
C This do loop was added later to check for the special
C case were all values in X are missing.
C
      DO 5 N=1,NPTS
         IF (X(N).NE.XMSG) GO TO 10
 5    END DO
      RETURN

c c c MPTCRT = NPTS   ! updated version

 10   NSTRT = 0
      NEND = 0
      NCODE = 0
      NITP = 0
      NPTCRT = IABS(MPTCRT)
      DO 40 N = 1,NPTS
          IF (X(N).EQ.XMSG) THEN
C must be a msg pt : set indices
              IF (NSTRT.EQ.0) NSTRT = N
              NEND = N
          ELSE

c must be a valid pt : check for prior missing values
c        (1) if nstrt=0 then there are no msg prior values : skip out
c        (2) if (nend-nstrt+1).gt.nptcrt the set ncode : skip out
c        (3) if nstrt=1 then initial series values are msg : set to
c            first non-msg value
c        ... else
c            perform the linear interpolation

              IF (NSTRT.NE.0) THEN
                  IF ((NEND-NSTRT+1).GT.NPTCRT) THEN
                      GO TO 30
                  END IF

                  IF (NSTRT.EQ.1) THEN
                      NITP = NITP + (NEND-NSTRT+1)
                      IF (MFLAG.LT.0) THEN
                          DO 15 NN = NSTRT,NEND
   15                     X(NN) = X(N)
                      ELSE
                          DO 16 NN = NSTRT,NEND
   16                     X(NN) = XMSG
                      END IF
                  ELSE
                      NBASE = NSTRT - 1
                      SLOPE = (X(N)-X(NBASE))/DBLE(N-NBASE)
                      NITP = NITP + (NEND-NSTRT+1)
                      DO 20 NN = NSTRT,NEND
   20                 X(NN) = X(NBASE) + SLOPE*DBLE(NN-NBASE)
                  END IF

   30             NSTRT = 0
                  NEND = 0
              END IF
          END IF
   40 CONTINUE

c check the end points

      IF (NEND.EQ.NPTS) THEN
          NITP = NITP + (NEND-NSTRT+1)
          IF (MFLAG.LT.0) THEN
              DO 49 NN = NSTRT,NPTS
   49         X(NN) = X(NSTRT-1)
          ELSE
              DO 50 NN = NSTRT,NPTS
   50         X(NN) = XMSG
          END IF
      END IF

c     nn = 0
c     do 60 n=1,npts
c     if (x(n).eq.xmsg) then
c         nn = nn+1
c     endif
c  60 continue

c     ncode = nn
c     if (nn.eq.npts) then
C for historical reasons
c         ncode = -1
c     endif

      RETURN
      END


      subroutine calc_kappa_error(x,iel0,nelblkif,nsd,nshg)
c
c----------------------------------------
c    aims to check the error of curvature
c    calculation
c----------------------------------------
        use pointer_data
        use workfc_m
        use if_global_m
c
        implicit none
c
        include "mpif.h"
        real*8, intent(in) :: x(nshg,nsd)
        integer, intent(in) :: iel0(nelblkif)
        integer, intent(in) :: nsd,nshg,nelblkif
c
        integer :: inode(6), n, iel, iblk, npro, nsum, my_nsum, ierr
        integer, dimension(:,:), pointer :: ienif0, ienif1
        real*8 :: this_kappa, my_err, err, this_err, kappa_exact, max_err, my_max_err
        logical, dimension(nshg) :: check
c
        my_err = 0.d0
        my_max_err = 0.d0
        my_nsum = 0
        check = .false.
c
        do iblk = 1,nelblkif
c
          npro = iel0(iblk+1) - iel0(iblk)
          ienif0 => mienif0(iblk)%p
          ienif1 => mienif1(iblk)%p
c
          do iel = 1,npro
            inode(1:3) = ienif0(iel,1:3)
            inode(4:6) = ienif1(iel,1:3)
            do n = 1,6
              if (.not. check(inode(n))) then
                check(inode(n)) = .true.
              else
                cycle
              endif
              kappa_exact = 4000.d0 ! 2/r for sphere
              my_nsum = my_nsum + 1
              this_err = (sqrt(dot_product(if_kappa(inode(n),1:nsd),if_kappa(inode(n),1:nsd)))/kappa_exact - 1.d0)**2
              my_err = my_err + this_err
      write(*,*) sqrt(dot_product(if_kappa(inode(n),:),if_kappa(inode(n),:)))
c      if (this_err > 1.e-3) then
c        write(*,200) myrank,inode(n),x(inode(n),:),norm2(if_kappa(inode(n),1:nsd)),this_err
c      endif
              my_max_err = max(my_max_err,this_err)
c
            enddo
          enddo
        enddo
c
        call mpi_allreduce(my_err,err,1,MPI_DOUBLE_PRECISION,MPI_SUM, MPI_COMM_WORLD,ierr)
        call mpi_allreduce(my_max_err,max_err,1,MPI_DOUBLE_PRECISION,MPI_MAX, MPI_COMM_WORLD,ierr)
        call mpi_allreduce(my_nsum,nsum,1,MPI_INTEGER,MPI_SUM, MPI_COMM_WORLD,ierr)
c
        err = sqrt(err) / real(nsum,8)
c
        if (myrank == 0) then
          write(*,100) nsum,err,max_err
        endif
c
100   format(' Total interface nodes, L2, L_inf norms (normalized err): ',i6,x,2(2x,e24.16))
200   format('[',i4,'] node, x(1:3), kappa, err:',i6,3(f8.4),x,2(2x,e24.16))
c
      end subroutine calc_kappa_error


	SUBROUTINE GR_SSCL  ( iscale, kx, ky, imin, jmin, imax, jmax,
     +			      grid, rmin, rmax, iret )
C************************************************************************
C* GR_SSCL								*
C*									*
C* This subroutine scales a scalar grid.  If the scaling factor    	*
C* is missing, undefined or greater than 20 in absolute value, 		*
C* an appropriate scaling factor will be computed.  If the data  	*
C* are too small to be scaled with ISCALE = 20, ISCALE is set 		*
C* to IMISSD and IRET = -14.  The maximun and minimun values of the	*
C* grid are also returned.						*
C*									*
C* GR_SSCL  ( ISCALE, KX, KY, IMIN, JMIN, IMAX, JMAX, GRID,		*
C*           RMIN, RMAX, IRET )						*
C*									*
C* Input and output parameters:						*
C*	ISCALE		INTEGER		Input/output scale factor	*
C* Input parameters:							*
C*	KX		INTEGER		Number of grid points in x dir	*
C*	KY		INTEGER		Number of grid points in y dir	*
C*	IMIN		INTEGER		Minimum x grid point		*
C*	JMIN		INTEGER		Minimum y grid point		*
C*	IMAX		INTEGER		Maximum x grid point		*
C*	JMAX		INTEGER		Maximum y grid point		*
C*									*
C* Input and output parameters:						*
C*	GRID (KX,KY)	REAL		Grid of data to be scaled	*
C*									*
C* Output parameters:							*
C*	RMIN		REAL		Data minimum			*
C*	RMAX		REAL		Data maximum			*
C*	IRET		INTEGER		Return code			*
C*					  0 = normal return		*
C*					 -8 = no data in range		*
C*					 -9 = invalid subset range	*
C*					-14 = scaling not possible	*
C**									*
C* M. desJardins/GSFC	 6/88						*
C* G. Huffman/GSC	 1/89	Warn for SCALE in [-100,-20],[20,100]	*
C* M. desJardins/GSFC	 7/89	Scale larger to get integral intervals	*
C* K. Brill/GSC          5/90   Return missing scale for small grd val  *
C* K. Brill/GSC          5/90   Change SSCALE + 10. to * 10. & 5 to 9.01*
C* K. Brill/NMC		08/91	Allow for scaling when rmax = rmin	*
C* L. Sager/NMC		 8/93	GR_SSCL created from GR_SCAL		*
C* P. Bruehl/Unidata	 9/94	Cleaned up (as per MdJ), scale < abs(20)*
C* M. Linda/GSC		 9/97	Changed a key word in the prologue	*
C************************************************************************
        INCLUDE         'GEMPRM.PRM'
C*
	REAL		grid (*)
C*
	LOGICAL		set
C*
        INCLUDE         'ERMISS.FNC'
C------------------------------------------------------------------------
	iret = 0
C
C*	Get range of data.
C
	CALL GR_STAT  ( grid, kx, ky, imin, jmin, imax, jmax,
     +			rmin, rmax, ravg, rdev, iret )
	IF  ( iret .ne. 0 )  THEN
	    iscale = 0
	    RETURN
	END IF

C
C*	If value is not within -20 to 20 range, or if it is missing,
C*	compute a new value.
C
	set = .false.
	IF  ( ( iscale .eq. IMISSD ) .or. ( iscale .lt. -20 ) .or.
     +	      ( iscale .gt.  20 ) )  THEN
C
C*	    Compute the logarithm for the absolute value.
C
	    set   = .true.
	    sscale = 1.0
	    savg  = ( ABS ( rmin ) + ABS ( rmax ) ) / 2.
	    scale = 0.
	    IF  ( savg .ne. 0. )  THEN
		rlog = ALOG10  ( ABS  ( savg ) )
		IF  ( rlog .lt. 0. )  THEN
		    irlog = -rlog
		    IF  ( FLOAT (-irlog) .ne. rlog )  irlog = irlog + 1
		    scale = irlog
		END IF
	    END IF
C
C*	    Set integer scaling term.
C
	    iscale = NINT ( scale )
	END IF
C
C*	Make sure scaling is valid
C
	IF  ( iscale .lt. -20 )  THEN
	    iscale = -20
	ELSE IF  ( iscale .gt. 20 )  THEN
	    iscale = 20
	ENDIF
C
C*	Scale data if necessary
C
	IF ( iscale .ne. 0 ) THEN
	    sscale = 10. ** iscale
C
C*	    Scale rmax and rmin to new values.
C
	    rmin = rmin * sscale
	    rmax = rmax * sscale
	END IF
C
C*	Check difference between min and max to ensure integral
C*	intervals.
C
	rdif = rmax - rmin
	IF  ( set .and. ( rdif .lt. 9.01 ) .and. ( rdif .ne. 0 ) ) THEN
	    iscale = iscale + 1
	    sscale = sscale * 10.
	    rmin   = rmin * 10.
	    rmax   = rmax * 10.
	END IF
C
C*	Scale the data.
C
	IF  ( iscale .ne. 0 )  THEN
	    DO  i = 1, kx*ky
		IF  ( .not. ERMISS ( grid (i) ) )
     +                 grid (i) = grid (i) * sscale
	    END DO
	END IF
C*
	RETURN
	END