      subroutine cwidth ( w,b,nequ,ncols,integs,nbloks, d, x,iflag )
c  this program is a variation of the theme in the algorithm bandet1
c  by martin and wilkinson (numer.math. 9(1976)279-307). it solves
c  the linear system
c			    a*x  =  b
c  of  nequ  equations in case	a  is almost block diagonal with all
c  blocks having  ncols  columns using no more storage than it takes to

c  store the interesting part of  a . such systems occur in the determ-

c  ination of the b-spline coefficients of a spline approximation.
c
c			    parameters
c  w	 on input, a two-dimensional array of size (nequ,ncols) contain-
c	 ing the interesting part of the almost block diagonal coeffici-
c	 ent matrix  a (see description and example below). the array
c	 integs  describes the storage scheme.
c	 on output, w  contains the upper triangular factor  u	of the
c	 lu factorization of a possibly permuted version of  a . in par-
c	 ticular, the determinant of  a  could now be found as
c	     iflag*w(1,1)*w(2,1)* ... * w(nequ,1)  .
c  b	 on input, the right side of the linear system, of length  nequ.
c	 the contents of  b  are changed during execution.
c  nequ  number of equations in system
c  ncols block width, i.e., number of columns in each block.
c  integs  integer array, of size (2,nequ), describing the block struct-
c	 ure of  a .
c	    integs(1,i) = no. of rows in block i	       =  nrow
c	    integs(2,i) = no. of elimination steps in block i
c			= overhang over next block	       =  last
c  nbloks  number of blocks
c  d	 work array, to contain row sizes . if storage is scarce, the
c	 array	x  could be used in the calling sequence for  d .
c  x	 on output, contains computed solution (if iflag .ne. 0), of
c	 length  nequ .
c  iflag  on output, integer
c	  = (-1)**(no.of interchanges during elimination)
c		 if  a	is invertible
c	  =  0	 if  a	is singular
c
c	 ------  block structure of  a	------
c     the interesting part of  a  is taken to consist of  nbloks  con-
c  secutive blocks, with the i-th block made up of  nrowi = integs(1,i)

c  consecutive rows and  ncols	consecutive columns of	a , and with
c  the first  lasti = integs(2,i) columns to the left of the next block.
c  these blocks are stored consecutively in the workarray  w .
c     for example, here is an 11th order matrix and its arrangement in
c  the workarray  w . (the interesting entries of  a  are indicated by
c  their row and column index modulo 10.)
c
c		   ---	 a   ---			  ---	w   ---

c
c		      nrow1=3
c	   11 12 13 14					   11 12 13 14
c	   21 22 23 24					   21 22 23 24
c	   31 32 33 34	    nrow2=2			   31 32 33 34
c   last1=2	 43 44 45 46				   43 44 45 46
c		 53 54 55 56	     nrow3=3		   53 54 55 56
c	  last2=3	  66 67 68 69			   66 67 68 69
c			  76 77 78 79			   76 77 78 79
c			  86 87 88 89	nrow4=1 	   86 87 88 89
c		   last3=1   97 98 99 90   nrow5=2	   97 98 99 90
c		      last4=1	08 09 00 01		   08 09 00 01
c				18 19 10 11		   18 19 10 11
c			 last5=4
c
c  for this interpretation of  a  as an almost block diagonal matrix,
c  we have  nbloks = 5 , and the integs array is
c
c			 i=  1	 2   3	 4   5
c		   k=
c  integs(k,i) =      1      3	 2   3	 1   2
c		      2      2	 3   1	 1   4
c
c	--------  method  --------
c     gauss elimination with scaled partial pivoting is used, but mult-

c  ipliers are	n o t  s a v e d  in order to save storage. rather, the

c  right side is operated on during elimination.
c     the two parameters
c		   i p v t e q	 and  l a s t e q
c  are used to keep track of the action.  ipvteq is the index of the
c  variable to be eliminated next, from equations  ipvteq+1,...,lasteq,

c  using equation  ipvteq (possibly after an interchange) as the pivot
c  equation. the entries in the pivot column are  a l w a y s  in column
c  1 of  w . this is accomplished by putting the entries in rows
c  ipvteq+1,...,lasteq	revised by the elimination of the  ipvteq-th
c  variable one to the left in	w . in this way, the columns of the
c  equations in a given block (as stored in  w ) will be aligned with
c  those of the next block at the moment when these next equations be-
c  come involved in the elimination process.
c     thus, for the above example, the first elimination steps proceed
c  as follows.
c
c  *11 12 13 14    11 12 13 14	  11 12 13 14	 11 12 13 14
c  *21 22 23 24   *22 23 24	  22 23 24	 22 23 24
c  *31 32 33 34   *32 33 34	 *33 34 	 33 34
c   43 44 45 46    43 44 45 46	 *43 44 45 46	*44 45 46	 etc.
c   53 54 55 56    53 54 55 56	 *53 54 55 56	*54 55 56
c   66 67 68 69    66 67 68 69	  66 67 68 69	 66 67 68 69
c	 .		.	       .	      .
c
c     in all other respects, the procedure is standard, including the
c  scaled partial pivoting.
c
      integer nbloks, ipvtp1, jmax
      integer iflag,integs(2,nbloks),ncols,nequ,   i,ii,icount,ipvteq
     *			   ,istar,j,lastcl,lasteq,lasti,nexteq,nrowad
      real b(nequ),d(nequ),w(nequ,ncols),x(nequ),   awi1od,colmax
     *	   ,ratio,sum				   ,rowmax,temp
      iflag = 1
      ipvteq = 0
      lasteq = 0
c				  the i-loop runs over the blocks
      do 50 i=1,nbloks
c
c	 the equations for the current block are added to those current-
c	 ly involved in the elimination process, by increasing	lasteq
c	 by  integs(1,i) after the rowsize of these equations has been
c	 recorded in the array	d .
c
	 nrowad = integs(1,i)
	 do 10 icount=1,nrowad
	    nexteq = lasteq + icount
	    rowmax = 0.
	    do 5 j=1,ncols
    5	       rowmax = amax1(rowmax,abs(w(nexteq,j)))
	    if (rowmax .eq. 0.) 	go to 999
   10	    d(nexteq) = rowmax
	 lasteq = lasteq + nrowad
c
c	 there will be	lasti = integs(2,i)  elimination steps before
c	 the equations in the next block become involved. further,
c	 l a s t c l  records the number of columns involved in the cur-
c	 rent elimination step. it starts equal to  ncols  when a block

c	 first becomes involved and then drops by one after each elim-
c	 ination step.
c
	 lastcl = ncols
	 lasti = integs(2,i)
	 do 30 icount=1,lasti
	    ipvteq = ipvteq + 1
	    if (ipvteq .lt. lasteq)	go to 11
	    if ( abs(w(ipvteq,1))+d(ipvteq) .gt. d(ipvteq) )
     *					go to 50
					go to 999
c
c	 determine the smallest  i s t a r  in	(ipvteq,lasteq)  for
c	 which	abs(w(istar,1))/d(istar)  is as large as possible, and
c	 interchange equations	ipvteq	and  istar  in case  ipvteq
c	 .lt. istar .
c
   11	    colmax = abs(w(ipvteq,1))/d(ipvteq)
	    istar = ipvteq
	    ipvtp1 = ipvteq + 1
	    do 13 ii=ipvtp1,lasteq
	       awi1od = abs(w(ii,1))/d(ii)
	       if (awi1od .le. colmax)	go to 13
	       colmax = awi1od
	       istar = ii
   13	       continue
	    if ( abs(w(istar,1))+d(istar) .eq. d(istar) )
     *					go to 999
	    if (istar .eq. ipvteq)	go to 16
	    iflag = -iflag
	    temp = d(istar)
	    d(istar) = d(ipvteq)
	    d(ipvteq) = temp
	    temp = b(istar)
	    b(istar) = b(ipvteq)
	    b(ipvteq) = temp
	    do 14 j=1,lastcl
	       temp = w(istar,j)
	       w(istar,j) = w(ipvteq,j)
   14	       w(ipvteq,j) = temp
c
c	 subtract the appropriate multiple of equation	ipvteq	from
c	 equations  ipvteq+1,...,lasteq to make the coefficient of the
c	 ipvteq-th unknown (presently in column 1 of  w ) zero, but
c	 store the new coefficients in	w  one to the left from the old.
c
   16	    do 20 ii=ipvtp1,lasteq
	       ratio = w(ii,1)/w(ipvteq,1)
	       do 18 j=2,lastcl
   18		  w(ii,j-1) = w(ii,j) - ratio*w(ipvteq,j)
	       w(ii,lastcl) = 0.
   20	       b(ii) = b(ii) - ratio*b(ipvteq)
   30	    lastcl = lastcl - 1
   50	 continue
c
c  at this point,  w  and  b  contain an upper triangular linear system

c  equivalent to the original one, with  w(i,j) containing entry
c  (i, i-1+j ) of the coefficient matrix. solve this system by backsub-

c  stitution, taking into account its block structure.
c
c			   i-loop over the blocks, in reverse order
      i = nbloks
   59	 lasti = integs(2,i)
	 jmax = ncols - lasti
	 do 70 icount=1,lasti
	    sum = 0.
	    if (jmax .eq. 0)		go to 61
	    do 60 j=1,jmax
   60	       sum = sum + x(ipvteq+j)*w(ipvteq,j+1)
   61	    x(ipvteq) = (b(ipvteq)-sum)/w(ipvteq,1)
	    jmax = jmax + 1
   70	    ipvteq = ipvteq - 1
	 i = i - 1
	 if (i .gt. 0)			go to 59
					return
  999 iflag = 0
					return
      end


SUBROUTINE f_interpz3d(data3d,zdata,desiredloc,missingval,out2d,nx,ny,nz)

    IMPLICIT NONE

    INTEGER, INTENT(IN) :: nx,ny,nz
    REAL(KIND=8), DIMENSION(nx,ny,nz), INTENT(IN) ::  data3d
    REAL(KIND=8), DIMENSION(nx,ny), INTENT(OUT) :: out2d
    REAL(KIND=8), DIMENSION(nx,ny,nz), INTENT(IN) :: zdata
    REAL(KIND=8), INTENT(IN) :: desiredloc
    REAL(KIND=8), INTENT(IN) :: missingval

    INTEGER :: i,j,kp,ip,im
    LOGICAL :: dointerp
    REAL(KIND=8) :: height,w1,w2

    height = desiredloc

    ! does vertical coordinate increase or decrease with increasing k?
    ! set offset appropriately

    ip = 0
    im = 1
    IF (zdata(1,1,1).GT.zdata(1,1,nz)) THEN
        ip = 1
        im = 0
    END IF

    DO i = 1,nx
        DO j = 1,ny
            ! Initialize to missing.  Was initially hard-coded to -999999.
            out2d(i,j) = missingval
            dointerp = .FALSE.
            kp = nz

            DO WHILE ((.NOT. dointerp) .AND. (kp >= 2))
                IF (((zdata(i,j,kp-im) < height) .AND. (zdata(i,j,kp-ip) > height))) THEN
                    w2 = (height-zdata(i,j,kp-im))/(zdata(i,j,kp-ip)-zdata(i,j,kp-im))
                    w1 = 1.D0 - w2
                    out2d(i,j) = w1*data3d(i,j,kp-im) + w2*data3d(i,j,kp-ip)
                    dointerp = .TRUE.
                END IF
                kp = kp - 1
            END DO

        END DO
    END DO

    RETURN

END SUBROUTINE f_interpz3d

SUBROUTINE f_interp2dxy(v3d,xy,v2d,nx,ny,nz,nxy)

    IMPLICIT NONE

    INTEGER,INTENT(IN) :: nx,ny,nz,nxy
    REAL(KIND=8),DIMENSION(nx,ny,nz),INTENT(IN) :: v3d
    REAL(KIND=8),DIMENSION(nxy,nz),INTENT(OUT) :: v2d
    REAL(KIND=8),DIMENSION(2,nxy),INTENT(IN) :: xy

    INTEGER :: i,j,k,ij
    REAL(KIND=8) :: w11,w12,w21,w22,wx,wy

    DO ij = 1,nxy
      i = MAX0(1,MIN0(nx-1,INT(xy(1,ij)+1)))
      j = MAX0(1,MIN0(ny-1,INT(xy(2,ij)+1)))
      wx = DBLE(i+1) - (xy(1,ij)+1)
      wy = DBLE(j+1) - (xy(2,ij)+1)
      w11 = wx*wy
      w21 = (1.D0-wx)*wy
      w12 = wx* (1.D0-wy)
      w22 = (1.D0-wx)* (1.D0-wy)
      DO k = 1,nz
          v2d(ij,k) = w11*v3d(i,j,k) + w21*v3d(i+1,j,k) + &
              w12*v3d(i,j+1,k) + w22*v3d(i+1,j+1,k)
      END DO
    END DO

    RETURN

END SUBROUTINE f_interp2dxy

SUBROUTINE f_interp1d(v_in,z_in,z_out,vmsg,v_out,nz_in,nz_out)

    IMPLICIT NONE

    INTEGER,INTENT(IN) :: nz_in, nz_out
    REAL(KIND=8),DIMENSION(nz_in),INTENT(IN) :: v_in,z_in
    REAL(KIND=8),DIMENSION(nz_out),INTENT(IN) :: z_out
    REAL(KIND=8),DIMENSION(nz_out),INTENT(OUT) :: v_out
    REAL(KIND=8),INTENT(IN) :: vmsg

    INTEGER :: kp,k,im,ip
    LOGICAL :: interp
    REAL(KIND=8) :: height,w1,w2

    ! does vertical coordinate increase of decrease with increasing k?
    ! set offset appropriately

    ip = 0
    im = 1
    IF (z_in(1).GT.z_in(nz_in)) THEN
      ip = 1
      im = 0
    END IF

    DO k = 1,nz_out
      v_out(k) = vmsg

      interp = .FALSE.
      kp = nz_in
      height = z_out(k)

      DO WHILE ((.NOT.interp) .AND. (kp.GE.2))
          IF (((z_in(kp-im).LE.height).AND.(z_in(kp-ip).GT.height))) THEN
              w2 = (height-z_in(kp-im))/(z_in(kp-ip)-z_in(kp-im))
              w1 = 1.d0 - w2
              v_out(k) = w1*v_in(kp-im) + w2*v_in(kp-ip)
              interp = .TRUE.
          END IF
          kp = kp - 1
      END DO
    END DO

    RETURN

END SUBROUTINE f_interp1d

! This routine assumes
!    index order is (i,j,k)
!    wrf staggering
!
!    units: pressure (Pa), temperature(K), height (m), mixing ratio
!     (kg kg{-1}) availability of 3d p, t, and qv; 2d terrain; 1d
! half-level zeta string
!    output units of SLP are Pa, but you should divide that by 100 for the
!          weather weenies.
!    virtual effects are included
!

SUBROUTINE f_computeslp(z,t,p,q,t_sea_level,t_surf,level,throw_exception,&
                        sea_level_pressure,nx,ny,nz)

    IMPLICIT NONE

    EXTERNAL throw_exception
    !     Estimate sea level pressure.
    INTEGER, INTENT(IN) :: nx,ny,nz
    REAL(KIND=8),DIMENSION(nx,ny,nz),INTENT(IN) :: z
    REAL(KIND=8),DIMENSION(nx,ny,nz),INTENT(IN) :: t,p,q
    !     The output is the 2d sea level pressure.
    REAL(KIND=8),DIMENSION(nx,ny),INTENT(OUT) :: sea_level_pressure
    INTEGER,DIMENSION(nx,ny), INTENT(INOUT) ::  level
    REAL(KIND=8),DIMENSION(nx,ny),INTENT(INOUT) :: t_surf,t_sea_level

    !     Some required physical constants:

    REAL(KIND=8), PARAMETER :: R=287.04D0, G=9.81D0, GAMMA=0.0065D0

    !     Specific constants for assumptions made in this routine:

    REAL(KIND=8), PARAMETER :: TC=273.16D0+17.5D0, PCONST=10000

    LOGICAL, PARAMETER :: ridiculous_mm5_test=.TRUE.
    !      PARAMETER (ridiculous_mm5_test = .FALSE.)

    !     Local variables:

    INTEGER :: i,j,k
    INTEGER :: klo,khi

    REAL(KIND=8) :: plo,phi,tlo,thi,zlo,zhi
    REAL(KIND=8) :: p_at_pconst,t_at_pconst,z_at_pconst
    REAL(KIND=8) :: z_half_lowest

    LOGICAL :: l1,l2,l3,found

    !  Find least zeta level that is PCONST Pa above the surface.  We
    !  later use this level to extrapolate a surface pressure and
    !  temperature, which is supposed to reduce the effect of the diurnal
    !  heating cycle in the pressure field.

    DO j = 1,ny
      DO i = 1,nx
          level(i,j) = -1

          k = 1
          found = .FALSE.
          DO WHILE ((.NOT. found) .AND. (k <= nz))
              IF (p(i,j,k) < p(i,j,1)-PCONST) THEN
                  level(i,j) = k
                  found = .TRUE.
              END IF
              k = k + 1
          END DO

          IF (level(i,j) == -1) THEN
              !PRINT '(A,I4,A)','Troubles finding level ', NINT(PCONST)/100,' above ground.'
              !PRINT '(A,I4,A,I4,A)','Problems first occur at (',I,',',J,')'
              !PRINT '(A,F6.1,A)','Surface pressure = ',p(i,j,1)/100,' hPa.'
              CALL throw_exception('Error in finding 100 hPa up')
          END IF
      END DO
    END DO

    !     Get temperature PCONST Pa above surface.  Use this to extrapolate
    !     the temperature at the surface and down to sea level.

    DO J = 1,ny
      DO I = 1,nx

          klo = MAX(level(i,j)-1,1)
          khi = MIN(klo+1,nz-1)

          IF (klo == khi) THEN
              !PRINT '(A)','Trapping levels are weird.'
              !PRINT '(A,I3,A,I3,A)','klo = ',klo,', khi = ',khi,': and they should not be equal.'
              CALL throw_exception('Error trapping levels')
          END IF

          plo = p(i,j,klo)
          phi = p(i,j,khi)
          tlo = t(i,j,klo)* (1.D0+0.608D0*q(i,j,klo))
          thi = t(i,j,khi)* (1.D0+0.608D0*q(i,j,khi))
    !         zlo = zetahalf(klo)/ztop*(ztop-terrain(i,j))+terrain(i,j)
    !         zhi = zetahalf(khi)/ztop*(ztop-terrain(i,j))+terrain(i,j)
          zlo = z(i,j,klo)
          zhi = z(i,j,khi)

          p_at_pconst = p(i,j,1) - PCONST
          t_at_pconst = thi - (thi-tlo)*LOG(p_at_pconst/phi)*LOG(plo/phi)
          z_at_pconst = zhi - (zhi-zlo)*LOG(p_at_pconst/phi)*LOG(plo/phi)

          t_surf(i,j) = t_at_pconst * (p(i,j,1)/p_at_pconst)**(GAMMA*R/G)
          t_sea_level(i,j) = t_at_pconst + GAMMA*z_at_pconst

      END DO
    END DO

    ! If we follow a traditional computation, there is a correction to the
    ! sea level temperature if both the surface and sea level
    ! temperatures are *too* hot.

    IF (ridiculous_mm5_test) THEN
      DO J = 1,ny
          DO I = 1,nx
              l1 = t_sea_level(i,j) < TC
              l2 = t_surf(i,j) <= TC
              l3 = .NOT. l1
              IF (l2 .AND. l3) THEN
                  t_sea_level(i,j) = TC
              ELSE
                  t_sea_level(i,j) = TC - 0.005D0* (t_surf(i,j)-TC)**2
              END IF
          END DO
      END DO
    END IF

    !     The grand finale: ta da!

    DO J = 1,ny
      DO I = 1,nx
    !   z_half_lowest=zetahalf(1)/ztop*(ztop-terrain(i,j))+terrain(i,j)
          z_half_lowest = z(i,j,1)

    ! Convert to hPa in this step, by multiplying by 0.01. The original
    ! Fortran routine didn't do this, but the NCL script that called it
    ! did, so we moved it here.
          sea_level_pressure(i,j) = 0.01 * (p(i,j,1)*EXP((2.D0*G*z_half_lowest)/&
                (R*(t_sea_level(i,j)+t_surf(i,j)))))
      END DO
    END DO

    !     PRINT *,'sea pres input at weird location i=20,j=1,k=1'
    !     PRINT *,'t=',t(20,1,1),t(20,2,1),t(20,3,1)
    !     PRINT *,'z=',z(20,1,1),z(20,2,1),z(20,3,1)
    !     PRINT *,'p=',p(20,1,1),p(20,2,1),p(20,3,1)
    !     PRINT *,'slp=',sea_level_pressure(20,1),
    !    *         sea_level_pressure(20,2),sea_level_pressure(20,3)

    RETURN

END SUBROUTINE f_computeslp

! Temperature from potential temperature in kelvin.
SUBROUTINE f_computetk(pressure,theta,tk,nx)

    IMPLICIT NONE

    INTEGER, INTENT(IN) :: nx
    REAL(KIND=8) :: pi
    REAL(KIND=8), DIMENSION(nx), INTENT(IN) :: pressure
    REAL(KIND=8), DIMENSION(nx), INTENT(IN) :: theta
    REAL(KIND=8), DIMENSION(nx), INTENT(OUT) :: tk

    INTEGER :: i
    REAL(KIND=8), PARAMETER :: P1000MB=100000.D0, R_D=287.D0, CP=7.D0*R_D/2.D0

    DO i = 1,nx
        pi = (pressure(i)/P1000MB)**(R_D/CP)
        tk(i) = pi*theta(i)
    END DO

    RETURN

END SUBROUTINE f_computetk

! Dewpoint.  Note:  1D array arguments.
SUBROUTINE f_computetd(pressure,qv_in,td,nx)

    IMPLICIT NONE

    INTEGER, INTENT(IN) :: nx
    REAL(KIND=8),DIMENSION(nx),INTENT(IN) :: pressure
    REAL(KIND=8),DIMENSION(nx),INTENT(IN) :: qv_in
    REAL(KIND=8),DIMENSION(nx),INTENT(OUT) :: td

    REAL(KIND=8) :: qv,tdc

    INTEGER :: i

    DO i = 1,nx
      qv = DMAX1(qv_in(i),0.D0)
      ! vapor pressure
      tdc = qv*pressure(i)/ (.622D0 + qv)

      ! avoid problems near zero
      tdc = DMAX1(tdc,0.001D0)
      td(i) = (243.5D0*LOG(tdc)-440.8D0)/ (19.48D0-LOG(tdc))
    END DO

    RETURN

END SUBROUTINE f_computetd

! Relative Humidity.  Note:  1D array arguments
SUBROUTINE f_computerh(qv,p,t,rh,nx)

    IMPLICIT NONE

    INTEGER, INTENT(IN) :: nx
    REAL(KIND=8),DIMENSION(nx),INTENT(IN) :: qv,p,t
    REAL(KIND=8),DIMENSION(nx),INTENT(OUT) :: rh

    REAL(KIND=8), PARAMETER :: SVP1=0.6112D0,SVP2=17.67D0,SVP3=29.65D0,SVPT0=273.15D0

    INTEGER :: i
    REAL(KIND=8) :: qvs,es,pressure,temperature
    REAL(KIND=8), PARAMETER :: R_D=287.D0,R_V=461.6D0,EP_2=R_D/R_V
    REAL(KIND=8), PARAMETER :: EP_3=0.622D0

    DO i = 1,nx
        pressure = p(i)
        temperature = t(i)
        ! es  = 1000.*svp1*
        es = 10.D0*SVP1*EXP(SVP2* (temperature-SVPT0)/(temperature-SVP3))
        ! qvs = ep_2*es/(pressure-es)
        qvs = EP_3*es/ (0.01D0*pressure- (1.D0-EP_3)*es)
        ! rh = 100*amax1(1., qv(i)/qvs)
        ! rh(i) = 100.*qv(i)/qvs
        rh(i) = 100.D0*DMAX1(DMIN1(qv(i)/qvs,1.0D0),0.0D0)
    END DO

    RETURN

END SUBROUTINE f_computerh

SUBROUTINE f_computeabsvort(u,v,msfu,msfv,msft,cor,dx,dy,av,nx,ny,nz,nxp1,nyp1)

    IMPLICIT NONE

    INTEGER, INTENT(IN) :: nx,ny,nz,nxp1,nyp1
    REAL(KIND=8),DIMENSION(nxp1,ny,nz),INTENT(IN) :: u
    REAL(KIND=8),DIMENSION(nx,nyp1,nz),INTENT(IN) :: v
    REAL(KIND=8),DIMENSION(nx,ny,nz),INTENT(OUT) :: av
    REAL(KIND=8),DIMENSION(nxp1,ny),INTENT(IN):: msfu
    REAL(KIND=8),DIMENSION(nx,nyp1),INTENT(IN) :: msfv
    REAL(KIND=8),DIMENSION(nx,ny),INTENT(IN) :: msft
    REAL(KIND=8),DIMENSION(nx,ny),INTENT(IN) :: cor
    REAL(KIND=8) :: dx,dy

    INTEGER :: jp1,jm1,ip1,im1,i,j,k
    REAL(KIND=8) :: dsy,dsx,dudy,dvdx,avort
    REAL(KIND=8) :: mm

    !          PRINT*,'nx,ny,nz,nxp1,nyp1'
    !          PRINT*,nx,ny,nz,nxp1,nyp1
    DO k = 1,nz
      DO j = 1,ny
          jp1 = MIN(j+1,ny)
          jm1 = MAX(j-1,1)
          DO i = 1,nx
              ip1 = MIN(i+1,nx)
              im1 = MAX(i-1,1)
    !         PRINT *,jp1,jm1,ip1,im1
              dsx = (ip1-im1)*dx
              dsy = (jp1-jm1)*dy
              mm = msft(i,j)*msft(i,j)
    !         PRINT *,j,i,u(i,jp1,k),msfu(i,jp1),u(i,jp1,k)/msfu(i,jp1)
              dudy = 0.5D0* (u(i,jp1,k)/msfu(i,jp1)+u(i+1,jp1,k)/&
                            msfu(i+1,jp1)-u(i,jm1,k)/&
                            msfu(i,jm1)-u(i+1,jm1,k)/&
                            msfu(i+1,jm1))/dsy*mm
              dvdx = 0.5D0* (v(ip1,j,k)/msfv(ip1,j)+v(ip1,j+1,k)/&
                            msfv(ip1,j+1)-v(im1,j,k)/&
                            msfv(im1,j)-v(im1,j+1,k)/&
                            msfv(im1,j+1))/dsx*mm
              avort = dvdx - dudy + cor(i,j)
              av(I,J,K) = avort*1.D5
          END DO
      END DO
    END DO

    RETURN

END SUBROUTINE f_computeabsvort

SUBROUTINE f_computepvo(u,v,theta,prs,msfu,msfv,msft,cor,dx,dy,pv,nx,ny,nz,nxp1,nyp1)

    IMPLICIT NONE

    INTEGER,INTENT(IN) :: nx,ny,nz,nxp1,nyp1
    REAL(KIND=8),DIMENSION(nxp1,ny,nz),INTENT(IN) :: u
    REAL(KIND=8),DIMENSION(nx,nyp1,nz),INTENT(IN) :: v
    REAL(KIND=8),DIMENSION(nx,ny,nz),INTENT(IN) :: prs
    REAL(KIND=8),DIMENSION(nx,ny,nz),INTENT(IN) :: theta
    REAL(KIND=8),DIMENSION(nx,ny,nz),INTENT(OUT) :: pv
    REAL(KIND=8),DIMENSION(nxp1,ny),INTENT(IN) ::  msfu
    REAL(KIND=8),DIMENSION(nx,nyp1),INTENT(IN) :: msfv
    REAL(KIND=8),DIMENSION(nx,ny),INTENT(IN) :: msft
    REAL(KIND=8),DIMENSION(nx,ny),INTENT(IN) :: cor
    REAL(KIND=8) :: dx,dy

    INTEGER :: kp1,km1,jp1,jm1,ip1,im1,i,j,k
    REAL(KIND=8) :: dsy,dsx,dp,dudy,dvdx,dudp,dvdp,dthdp,avort
    REAL(KIND=8) :: dthdx,dthdy,mm

    !          PRINT*,'nx,ny,nz,nxp1,nyp1'
    !          PRINT*,nx,ny,nz,nxp1,nyp1
    DO k = 1,nz
      kp1 = MIN(k+1,nz)
      km1 = MAX(k-1,1)
      DO J = 1,ny
          jp1 = MIN(j+1,ny)
          jm1 = MAX(j-1,1)
          DO i = 1,nx
              ip1 = MIN(i+1,nx)
              im1 = MAX(i-1,1)
    !         PRINT *,jp1,jm1,ip1,im1
              dsx = (ip1-im1)*dx
              dsy = (jp1-jm1)*dy
              mm = msft(i,j)*msft(i,j)
    !         PRINT *,j,i,u(i,jp1,k),msfu(i,jp1),u(i,jp1,k)/msfu(i,jp1)
              dudy = 0.5D0* (u(i,jp1,k)/msfu(i,jp1)+u(i+1,jp1,k)/&
                            msfu(i+1,jp1)-u(i,jm1,k)/&
                            msfu(i,jm1)-u(i+1,jm1,k)/&
                            msfu(i+1,jm1))/dsy*mm
              dvdx = 0.5D0* (v(ip1,j,k)/msfv(ip1,j)+v(ip1,j+1,k)/&
                            msfv(ip1,j+1)-v(im1,j,k)/&
                            msfv(im1,j)-v(im1,j+1,k)/&
                            msfv(im1,j+1))/dsx*mm
              avort = dvdx - dudy + cor(i,j)
              dp = prs(i,j,kp1) - prs(i,j,km1)
              dudp = 0.5D0* (u(i,j,kp1)+u(i+1,j,kp1)-u(i,j,km1)-u(i+1,j,km1))/dp
              dvdp = 0.5D0* (v(i,j,kp1)+v(i,j+1,kp1)-v(i,j,km1)-v(i,J+1,km1))/dp
              dthdp = (theta(i,j,kp1)-theta(i,j,km1))/dp
              dthdx = (theta(ip1,j,k)-theta(im1,j,k))/dsx*msft(i,j)
              dthdy = (theta(i,jp1,k)-theta(i,jm1,k))/dsy*msft(i,j)
              pv(i,j,k) = -9.81D0* (dthdp*avort-dvdp*dthdx+dudp*dthdy)*10000.D0
    !               if(i.eq.300 .and. j.eq.300) then
    !                 PRINT*,'avort,dudp,dvdp,dthdp,dthdx,dthdy,pv'
    !                 PRINT*,avort,dudp,dvdp,dthdp,dthdx,dthdy,pv(i,j,k)
    !               endif
              pv(i,j,k) = pv(i,j,k)*1.D2
          END DO
      END DO
    END DO

    RETURN

END SUBROUTINE f_computepvo

! Theta-e
SUBROUTINE f_computeeth(qvp,tmk,prs,eth,miy,mjx,mkzh)

    IMPLICIT NONE

    ! Input variables
    ! Qvapor [g/kg]
    REAL(KIND=8),DIMENSION(miy,mjx,mkzh),INTENT(IN) :: qvp
    ! Temperature [K]
    REAL(KIND=8),DIMENSION(miy,mjx,mkzh),INTENT(IN) :: tmk
    ! full pressure (=P+PB) [hPa]
    REAL(KIND=8),DIMENSION(miy,mjx,mkzh),INTENT(IN) :: prs
    !
    ! Output variable
    ! equivalent potential temperature [K]
    REAL(KIND=8),DIMENSION(miy,mjx,mkzh),INTENT(OUT) :: eth
    ! Sizes
    INTEGER,INTENT(IN) :: miy,mjx,mkzh

    ! local variables
    REAL(KIND=8) :: q
    REAL(KIND=8) :: t
    REAL(KIND=8) :: p
    REAL(KIND=8) :: e
    REAL(KIND=8) :: tlcl
    INTEGER :: i,j,k

    ! parameters
    REAL(KIND=8),PARAMETER :: EPS = 0.622D0
    REAL(KIND=8),PARAMETER :: RGAS = 287.04D0
    REAL(KIND=8),PARAMETER :: RGASMD = .608D0
    REAL(KIND=8),PARAMETER :: CP = 1004.D0
    REAL(KIND=8),PARAMETER :: CPMD = .887D0
    REAL(KIND=8),PARAMETER :: GAMMA = RGAS/CP
    REAL(KIND=8),PARAMETER :: GAMMAMD = RGASMD - CPMD
    REAL(KIND=8),PARAMETER :: TLCLC1 = 2840.D0
    REAL(KIND=8),PARAMETER :: TLCLC2 = 3.5D0
    REAL(KIND=8),PARAMETER :: TLCLC3 = 4.805D0
    REAL(KIND=8),PARAMETER :: TLCLC4 = 55.D0
    REAL(KIND=8),PARAMETER :: THTECON1 = 3376.D0
    REAL(KIND=8),PARAMETER :: THTECON2 = 2.54D0
    REAL(KIND=8),PARAMETER :: THTECON3 = .81D0

    DO k = 1,mkzh
      DO j = 1,mjx
          DO i = 1,miy
              q = MAX(qvp(i,j,k),1.D-15)
              t = tmk(i,j,k)
              p = prs(i,j,k)/100.
              e = q*p / (EPS+q)
              tlcl = TLCLC1 / (LOG(t**TLCLC2/e)-TLCLC3) + TLCLC4
              eth(i,j,k) = t * (1000.D0/p)**(GAMMA * (1.D0+GAMMAMD*q))*&
                        EXP((THTECON1/tlcl-THTECON2)*q*(1.D0+THTECON3*q))
          END DO
      END DO
    END DO

    RETURN

END SUBROUTINE f_computeeth

SUBROUTINE f_computeuvmet(u,v,longca,longcb,flong,flat,&
                        cen_long,cone,rpd,istag,is_msg_val,umsg,vmsg,uvmetmsg,&
                        uvmet,nx,ny,nxp1,nyp1,nz)

    IMPLICIT NONE

    ! ISTAG should be 0 if the U,V grids are not staggered.
    ! That is, NY = NYP1 and NX = NXP1.

    INTEGER,INTENT(IN) :: nx,ny,nz,nxp1,nyp1,istag
    LOGICAL,INTENT(IN) :: is_msg_val
    REAL(KIND=8),DIMENSION(nxp1,ny,nz),INTENT(IN):: u
    REAL(KIND=8),DIMENSION(nx,nyp1,nz),INTENT(IN) :: v
    REAL(KIND=8),DIMENSION(nx,ny),INTENT(IN) :: flong
    REAL(KIND=8),DIMENSION(nx,ny),INTENT(IN) :: flat
    REAL(KIND=8),DIMENSION(nx,ny),INTENT(INOUT) :: longca
    REAL(KIND=8),DIMENSION(nx,ny),INTENT(INOUT) :: longcb
    REAL(KIND=8),INTENT(IN) :: cen_long,cone,rpd
    REAL(KIND=8),INTENT(IN) :: umsg,vmsg,uvmetmsg
    REAL(KIND=8),DIMENSION(nx,ny,nz,2),INTENT(OUT) :: uvmet

    INTEGER :: i,j,k
    REAL(KIND=8) :: uk,vk

    ! msg stands for missing value in this code
    !      WRITE (6,FMT=*) ' in compute_uvmet ',NX,NY,NXP1,NYP1,ISTAG

    DO J = 1,ny
      DO I = 1,nx

          longca(i,j) = flong(i,j) - cen_long
          IF (longca(i,j).GT.180.D0) THEN
              longca(i,j) = longca(i,j) - 360.D0
          END IF
          IF (longca(i,j).LT.-180.D0) THEN
              longca(i,j) = longca(i,j) + 360.D0
          END IF
          IF (flat(i,j).LT.0.D0) THEN
              longcb(i,j) = -longca(i,j)*cone*rpd
          ELSE
              longcb(i,j) = longca(i,j)*cone*rpd
          END IF

          longca(i,j) = COS(longcb(i,j))
          longcb(i,j) = SIN(longcb(i,j))

      END DO
    END DO

    !      WRITE (6,FMT=*) ' computing velocities '
    DO k = 1,nz
        DO j = 1,ny
         DO i = 1,nx
            IF (istag.EQ.1) THEN
               IF (is_msg_val .AND. (u(i,j,k) .EQ. umsg .OR. v(i,j,k) .EQ. vmsg &
                   .OR. u(i+1,j,k) .EQ. umsg .OR. v(i,j+1,k) .EQ. vmsg)) THEN
                  uvmet(i,j,k,1) = uvmetmsg
                  uvmet(i,j,k,2) = uvmetmsg
               ELSE
                  uk = 0.5D0* (u(i,j,k)+u(i+1,j,k))
                  vk = 0.5D0* (v(i,j,k)+v(i,j+1,k))
                  uvmet(i,j,k,1) = vk*longcb(i,j) + uk*longca(i,j)
                  uvmet(i,j,k,2) = vk*longca(i,j) - uk*longcb(i,j)
               END IF
            ELSE
               IF (is_msg_val .AND. (u(i,j,k) .EQ. umsg .OR. v(i,j,k) .EQ. vmsg)) THEN
                  uvmet(i,j,k,1) = uvmetmsg
                  uvmet(i,j,k,2) = uvmetmsg
               ELSE
                  uk = u(i,j,k)
                  vk = v(i,j,k)
                  uvmet(i,j,k,1) = vk*longcb(i,j) + uk*longca(i,j)
                  uvmet(i,j,k,2) = vk*longca(i,j) - uk*longcb(i,j)
               END IF
            END IF
         END DO
        END DO
    END DO

    RETURN

END SUBROUTINE f_computeuvmet

SUBROUTINE f_computeomega(qvp,tmk,www,prs,omg,mx,my,mz)

    IMPLICIT NONE

    INTEGER,INTENT(IN) :: mx, my, mz
    REAL(KIND=8),INTENT(IN),DIMENSION(mx,my,mz) :: qvp
    REAL(KIND=8),INTENT(IN),DIMENSION(mx,my,mz) :: tmk
    REAL(KIND=8),INTENT(IN),DIMENSION(mx,my,mz) :: www
    REAL(KIND=8),INTENT(IN),DIMENSION(mx,my,mz) :: prs
    REAL(KIND=8),INTENT(OUT),DIMENSION(mx,my,mz) :: omg

    ! Local variables
    INTEGER :: i, j, k
    REAL(KIND=8),PARAMETER :: GRAV=9.81, RGAS=287.04, EPS=0.622

    DO k=1,mz
        DO j=1,my
          DO i=1,mx
              omg(i,j,k)=-GRAV*prs(i,j,k) / &
              (RGAS*((tmk(i,j,k)*(EPS+qvp(i,j,k))) / &
              (EPS*(1.+qvp(i,j,k)))))*www(i,j,k)
          END DO
        END DO
    END DO
    !
    RETURN

END SUBROUTINE f_computeomega

SUBROUTINE f_computetv(temp,qv,tv,nx,ny,nz)

    IMPLICIT NONE

    INTEGER, INTENT(IN) :: nx,ny,nz
    REAL(KIND=8),DIMENSION(nx,ny,nz),INTENT(IN) :: temp
    REAL(KIND=8),DIMENSION(nx,ny,nz),INTENT(IN) :: qv
    REAL(KIND=8),DIMENSION(nx,ny,nz),INTENT(OUT) :: tv

    INTEGER :: i,j,k
    REAL(KIND=8),PARAMETER :: EPS = 0.622D0

    DO k=1,nz
        DO j=1,ny
          DO i=1,nx
            tv(i,j,k) = temp(i,j,k) * (EPS+qv(i,j,k)) / (EPS * (1.D0+qv(i,j,k)))
          END DO
        END DO
    END DO

    RETURN

END SUBROUTINE f_computetv

! Need to deal with the fortran stop statements
SUBROUTINE f_computewetbulb(prs,tmk,qvp,PSADITHTE,PSADIPRS,PSADITMK,throw_exception,twb,nx,ny,nz)

    IMPLICIT NONE

    EXTERNAL throw_exception
    INTEGER,INTENT(IN) :: nx, ny, nz
    REAL(KIND=8),DIMENSION(nx,ny,nz),INTENT(IN) :: prs
    REAL(KIND=8),DIMENSION(nx,ny,nz),INTENT(IN) :: tmk
    REAL(KIND=8),DIMENSION(nx,ny,nz),INTENT(IN) :: qvp
    REAL(KIND=8),DIMENSION(150),INTENT(IN) :: PSADITHTE
    REAL(KIND=8),DIMENSION(150),INTENT(IN) ::PSADIPRS
    REAL(KIND=8),DIMENSION(150,150),INTENT(IN) :: PSADITMK
    REAL(KIND=8),DIMENSION(nx,ny,nz),INTENT(OUT) :: twb
    !EXTERNAL throw_exception

    INTEGER :: i,j,k
    INTEGER :: jtch,jt,ipch,ip
    REAL(KIND=8) :: q, t, p, e, tlcl, eth
    REAL(KIND=8) :: fracip,fracip2,fracjt,fracjt2
    REAL(KIND=8) :: tonpsadiabat

    REAL(KIND=8),PARAMETER :: EPS=0.622
    REAL(KIND=8),PARAMETER :: RGAS=287.04
    REAL(KIND=8),PARAMETER :: RGASMD=.608
    REAL(KIND=8),PARAMETER :: CP=1004.
    REAL(KIND=8),PARAMETER :: CPMD=.887
    REAL(KIND=8),PARAMETER :: GAMMA=RGAS/CP
    REAL(KIND=8),PARAMETER :: GAMMAMD=RGASMD-CPMD
    REAL(KIND=8),PARAMETER :: CELKEL=273.15
    REAL(KIND=8),PARAMETER :: TLCLC1=2840.
    REAL(KIND=8),PARAMETER :: TLCLC2=3.5
    REAL(KIND=8),PARAMETER :: TLCLC3=4.805
    REAL(KIND=8),PARAMETER :: TLCLC4=55.
    REAL(KIND=8),PARAMETER :: THTECON1=3376.
    REAL(KIND=8),PARAMETER :: THTECON2=2.54
    REAL(KIND=8),PARAMETER :: THTECON3=.81

    DO k=1,nz
        DO j=1,ny
          DO i=1,nx
            q=dmax1(qvp(i,j,k),1.d-15)
            t=tmk(i,j,k)
            p=prs(i,j,k)/100.
            e=q*p/(EPS+q)
            tlcl=TLCLC1/(DLOG(t**TLCLC2/e)-TLCLC3)+TLCLC4
            eth=t*(1000./p)**(GAMMA*(1.+GAMMAMD*q))*&
                EXP((THTECON1/tlcl-THTECON2)*q*(1.+THTECON3*q))

        !   Now we need to find the temperature (in K) on a moist adiabat
        !   (specified by eth in K) given pressure in hPa.  It uses a
        !   lookup table, with data that was generated by the Bolton (1980)
        !   formula for theta_e.

        !     First check if pressure is less than min pressure in lookup table.
        !     If it is, assume parcel is so dry that the given theta-e value can
        !     be interpretted as theta, and get temperature from the simple dry
        !     theta formula.
        !

            IF (p.LE.psadiprs(150)) THEN
              tonpsadiabat=eth*(p/1000.)**GAMMA
            ELSE

        !   Otherwise, look for the given thte/prs point in the lookup table.

            jt=-1
            DO jtch=1,150-1
              IF (eth.GE.psadithte(jtch).AND.eth.LT.psadithte(jtch+1)) THEN
                 jt=jtch
                 EXIT
              ENDIF
            END DO
    !        jt=-1
    !    213        CONTINUE
            ip=-1
            DO ipch=1,150-1
              IF (p.LE.psadiprs(ipch).AND.p.GT.psadiprs(ipch+1)) THEN
                 ip=ipch
                 EXIT
              ENDIF
            END DO
    !        ip=-1
    !    215        CONTINUE
            IF (jt.EQ.-1.OR.ip.EQ.-1) THEN
                CALL throw_exception('Outside of lookup table bounds. prs,thte=',p,eth)
              !STOP ! TODO: Need to make python throw an exception here
            ENDIF
            fracjt=(eth-psadithte(jt))/(psadithte(jt+1)-psadithte(jt))
            fracjt2=1.-fracjt
            fracip=(psadiprs(ip)-p)/(psadiprs(ip)-psadiprs(ip+1))
            fracip2=1.-fracip
            IF (psaditmk(ip,jt).GT.1e9.OR.psaditmk(ip+1,jt).GT.1e9.OR.psaditmk(ip,jt+1).GT.1e9.OR.psaditmk(ip+1,jt+1).GT.1e9) THEN
                !PRINT*,'Tried to access missing tmperature in lookup table.'
                CALL throw_exception('Prs and Thte probably unreasonable. prs,thte=',p,eth)
               !STOP ! TODO: Need to make python throw an exception here
            ENDIF
            tonpsadiabat=fracip2*fracjt2*psaditmk(ip,jt)+fracip*&
                    fracjt2*psaditmk(ip+1,jt)+fracip2*fracjt*psaditmk(ip,jt+1)+fracip*&
                    fracjt *psaditmk(ip+1,jt+1)
            ENDIF

            twb(i,j,k)=tonpsadiabat

          END DO
        END DO
    END DO

    RETURN

END SUBROUTINE f_computewetbulb

SUBROUTINE f_computesrh(u, v, ght, ter, top, sreh, miy, mjx, mkzh)

    IMPLICIT NONE

    INTEGER,INTENT(IN) :: miy, mjx, mkzh
    REAL(KIND=8),DIMENSION(miy,mjx,mkzh),INTENT(IN) :: u, v, ght
    REAL(KIND=8),INTENT(IN) :: top
    REAL(KIND=8),DIMENSION(miy,mjx),INTENT(IN) :: ter
    REAL(KIND=8),DIMENSION(miy,mjx),INTENT(OUT) :: sreh

    ! This helicity code was provided by Dr. Craig Mattocks, and
    ! verified by Cindy Bruyere to produce results equivalent to
    ! those generated by RIP4. (The code came from RIP4?)

    REAL(KIND=8) :: dh, sdh, su, sv, ua, va, asp, adr, bsp, bdr
    REAL(KIND=8) :: cu, cv, x, sum
    INTEGER :: i, j, k, k10, k3, ktop
    REAL(KIND=8),PARAMETER :: PI=3.14159265d0, DTR=PI/180.d0, DPR=180.d0/PI

    DO j = 1, mjx-1
        DO i = 1, miy-1
            sdh = 0.d0
            su = 0.d0
            sv = 0.d0
            k3 = 0
            k10 = 0
            ktop = 0
            DO k = mkzh, 2, -1
                IF (((ght(i,j,k) - ter(i,j)) .GT. 10000.d0) .AND.(k10 .EQ. 0)) THEN
                    k10 = k
                    EXIT
                ENDIF
                IF (((ght(i,j,k) - ter(i,j)) .GT. top) .AND.(ktop .EQ. 0)) THEN
                    ktop = k
                ENDIF
                IF (((ght(i,j,k) - ter(i,j)) .GT. 3000.d0) .AND.(k3 .EQ. 0)) THEN
                    k3 = k
                ENDIF
            END DO

            IF (k10 .EQ. 0) THEN
                k10 = 2
            ENDIF
            DO k = k3, k10, -1
                dh = ght(i,j,k-1) - ght(i,j,k)
                sdh = sdh + dh
                su = su + 0.5d0*dh*(u(i,j,k-1)+u(i,j,k))
                sv = sv + 0.5d0*dh*(v(i,j,k-1)+v(i,j,k))
            END DO
            ua = su / sdh
            va = sv / sdh
            asp = SQRT(ua*ua + va*va)
            IF (ua .EQ. 0.d0 .AND. va .EQ. 0.d0) THEN
                adr = 0.d0
            ELSE
                adr = DPR * (PI + ATAN2(ua,va))
            ENDIF
            bsp = 0.75d0 * asp
            bdr = adr + 30.d0
            IF (bdr .GT. 360.d0) THEN
                bdr = bdr-360.d0
            ENDIF
            cu = -bsp * SIN(bdr*dtr)
            cv = -bsp * COS(bdr*dtr)
            sum = 0.d0
            DO k = mkzh-1, ktop, -1
                x = ((u(i,j,k)-cu) * (v(i,j,k)-v(i,j,k+1))) - ((v(i,j,k)-cv) * (u(i,j,k)-u(i,j,k+1)))
                sum = sum + x
            END DO
            sreh(i,j) = -sum
        END DO
    END DO

    RETURN

END SUBROUTINE f_computesrh

SUBROUTINE f_computeuh(zp,mapfct,dx,dy,uhmnhgt,uhmxhgt,us,vs,w,tem1,tem2,uh,nx,ny,nz,nzp1)

  IMPLICIT NONE

  INTEGER, INTENT(IN) :: nx,ny,nz,nzp1
  REAL(KIND=8),DIMENSION(nx,ny,nzp1),INTENT(IN)  :: zp
  REAL(KIND=8),DIMENSION(nx,ny),INTENT(IN) :: mapfct
  REAL(KIND=8),INTENT(IN)  :: dx,dy
  REAL(KIND=8),INTENT(IN)  :: uhmnhgt,uhmxhgt
  REAL(KIND=8),DIMENSION(nx,ny,nz),INTENT(IN)  :: us
  REAL(KIND=8),DIMENSION(nx,ny,nz),INTENT(IN)  :: vs
  REAL(KIND=8),DIMENSION(nx,ny,nzp1),INTENT(IN)  :: w
  REAL(KIND=8),DIMENSION(nx,ny),INTENT(OUT) :: uh
  REAL(KIND=8),DIMENSION(nx,ny,nz),INTENT(INOUT) :: tem1
  REAL(KIND=8),DIMENSION(nx,ny,nz),INTENT(INOUT) :: tem2
!
! Misc local variables
!
  INTEGER :: i,j,k,kbot,ktop
  REAL(KIND=8) :: twodx,twody,wgtlw,sum,wmean,wsum,wavg
  REAL(KIND=8) :: helbot,heltop,wbot,wtop
  REAL(KIND=8) :: zbot,ztop
!
! Initialize arrays
!
  uh=0.0
  tem1=0.0
!
! Calculate vertical component of helicity at scalar points
!   us: u at scalar points
!   vs: v at scalar points
!
  twodx=2.0*dx
  twody=2.0*dy
  DO k=2,nz-2
    DO j=2,ny-1
      DO i=2,nx-1
        wavg=0.5*(w(i,j,k)+w(i,j,k+1))
        tem1(i,j,k)=wavg *                                      &
            ((vs(i+1,j,k)-vs(i-1,j,k))/(twodx*mapfct(i,j))  -   &
             (us(i,j+1,k)-us(i,j-1,k))/(twody*mapfct(i,j)))
        tem2(i,j,k)=0.5*(zp(i,j,k)+zp(i,j,k+1))
      END DO
    END DO
  END DO
!
! Integrate over depth uhminhgt to uhmxhgt AGL
!
!  WRITE(6,'(a,f12.1,a,f12.1,a)') &
!        'Calculating UH from ',uhmnhgt,' to ',uhmxhgt,' m AGL'
  DO j=2,ny-2
    DO i=2,nx-2
      zbot=zp(i,j,2)+uhmnhgt
      ztop=zp(i,j,2)+uhmxhgt
!
! Find wbar, weighted-mean vertical velocity in column
! Find w at uhmnhgt AGL (bottom)
!
      DO k=2,nz-3
        IF(zp(i,j,k) > zbot) EXIT
      END DO
      kbot=k
      wgtlw=(zp(i,j,kbot)-zbot)/(zp(i,j,kbot)-zp(i,j,kbot-1))
      wbot=(wgtlw*w(i,j,kbot-1))+((1.-wgtlw)*w(i,j,kbot))
!
! Find w at uhmxhgt AGL (top)
!
      DO k=2,nz-3
        IF(zp(i,j,k) > ztop) EXIT
      END DO
      ktop=k
      wgtlw=(zp(i,j,ktop)-ztop)/(zp(i,j,ktop)-zp(i,j,ktop-1))
      wtop=(wgtlw*w(i,j,ktop-1))+((1.-wgtlw)*w(i,j,ktop))
!
! First part, uhmnhgt to kbot
!
      wsum=0.5*(w(i,j,kbot)+wbot)*(zp(i,j,kbot)-zbot)
!
! Integrate up through column
!
      DO k=(kbot+1),(ktop-1)
        wsum=wsum+0.5*(w(i,j,k)+w(i,j,k-1))*(zp(i,j,k)-zp(i,j,k-1))
      END DO
!
! Last part, ktop-1 to uhmxhgt
!
      wsum=wsum+0.5*(wtop+w(i,j,ktop-1))*(ztop-zp(i,j,ktop-1))
      wmean=wsum/(uhmxhgt-uhmnhgt)

      IF(wmean > 0.) THEN    ! column updraft, not downdraft
!
! Find helicity at uhmnhgt AGL (bottom)
!
        DO k=2,nz-3
          IF(tem2(i,j,k) > zbot) EXIT
        END DO
        kbot=k
        wgtlw=(tem2(i,j,kbot)-zbot)/(tem2(i,j,kbot)-tem2(i,j,kbot-1))
        helbot=(wgtlw*tem1(i,j,kbot-1))+((1.-wgtlw)*tem1(i,j,kbot))
!
! Find helicity at uhmxhgt AGL (top)
!
        DO k=2,nz-3
          IF(tem2(i,j,k) > ztop) EXIT
        END DO
        ktop=k
        wgtlw=(tem2(i,j,ktop)-ztop)/(tem2(i,j,ktop)-tem2(i,j,ktop-1))
        heltop=(wgtlw*tem1(i,j,ktop-1))+((1.-wgtlw)*tem1(i,j,ktop))
!
! First part, uhmnhgt to kbot
!
        sum=0.5*(tem1(i,j,kbot)+helbot)*(tem2(i,j,kbot)-zbot)
!
! Integrate up through column
!
        DO k=(kbot+1),(ktop-1)
          sum=sum+0.5*(tem1(i,j,k)+tem1(i,j,k-1))*(tem2(i,j,k)-tem2(i,j,k-1))
        END DO
!
! Last part, ktop-1 to uhmxhgt
!
        uh(i,j)=sum+0.5*(heltop+tem1(i,j,ktop-1))*(ztop-tem2(i,j,ktop-1))
      END IF
    END DO
  END DO

  uh = uh * 1000.   ! Scale according to Kain et al. (2008)

  RETURN

END SUBROUTINE f_computeuh

SUBROUTINE f_computepw(p,tv,qv,ht,zdiff,pw,nx,ny,nz,nzh)

    IMPLICIT NONE

    REAL(KIND=8),DIMENSION(nx,ny,nz),INTENT(IN) :: p,tv,qv
    REAL(KIND=8),DIMENSION(nx,ny,nzh),INTENT(IN) :: ht
    REAL(KIND=8),DIMENSION(nx,ny),INTENT(OUT) :: pw
    REAL(KIND=8),DIMENSION(nx,ny),INTENT(INOUT) :: zdiff
    INTEGER,INTENT(IN) :: nx,ny,nz,nzh

    INTEGER :: i,j,k
    REAL(KIND=8),PARAMETER :: R=287.06

    pw = 0
    DO k=1,nz
        DO j=1,ny
            DO i=1,nx
                zdiff(i,j) = ht(i,j,k+1) - ht(i,j,k)
                pw(i,j) = pw(i,j) + ((p(i,j,k)/(R * tv(i,j,k))) * qv(i,j,k) * zdiff(i,j))
            END DO
        END DO
    END DO

    RETURN

END SUBROUTINE f_computepw

SUBROUTINE f_computedbz(prs,tmk,qvp,qra,qsn,qgr,sn0,ivarint,iliqskin,dbz,nx,ny,nz)

    IMPLICIT NONE

    !   Arguments
    INTEGER, INTENT(IN) :: nx,ny,nz
    INTEGER, INTENT(IN) :: sn0,ivarint,iliqskin
    REAL(KIND=8),DIMENSION(nx,ny,nz),INTENT(OUT) :: dbz
    REAL(KIND=8),DIMENSION(nx,ny,nz),INTENT(IN) :: prs
    REAL(KIND=8),DIMENSION(nx,ny,nz),INTENT(IN) :: tmk
    REAL(KIND=8),DIMENSION(nx,ny,nz),INTENT(INOUT) :: qvp
    REAL(KIND=8),DIMENSION(nx,ny,nz),INTENT(INOUT) :: qra
    REAL(KIND=8),DIMENSION(nx,ny,nz),INTENT(INOUT) :: qsn
    REAL(KIND=8),DIMENSION(nx,ny,nz),INTENT(INOUT) :: qgr

    !   Local Variables
    INTEGER :: i,j,k
    REAL(KIND=8) :: temp_c,virtual_t
    REAL(KIND=8) :: gonv,ronv,sonv
    REAL(KIND=8) :: factor_g,factor_r,factor_s
    REAL(KIND=8) :: factorb_g,factorb_s
    REAL(KIND=8) :: rhoair,z_e

    !   Constants used to calculate variable intercepts
    REAL(KIND=8),PARAMETER :: R1 = 1.D-15
    REAL(KIND=8),PARAMETER :: RON = 8.D6
    REAL(KIND=8),PARAMETER :: RON2 = 1.D10
    REAL(KIND=8),PARAMETER :: SON = 2.D7
    REAL(KIND=8),PARAMETER :: GON = 5.D7
    REAL(KIND=8),PARAMETER :: RON_MIN = 8.D6
    REAL(KIND=8),PARAMETER :: RON_QR0 = 0.00010D0
    REAL(KIND=8),PARAMETER :: RON_DELQR0 = 0.25D0*RON_QR0
    REAL(KIND=8),PARAMETER :: RON_CONST1R = (RON2-RON_MIN)*0.5D0
    REAL(KIND=8),PARAMETER :: RON_CONST2R = (RON2+RON_MIN)*0.5D0

    !   Constant intercepts
    REAL(KIND=8),PARAMETER :: RN0_R = 8.D6
    REAL(KIND=8),PARAMETER :: RN0_S = 2.D7
    REAL(KIND=8),PARAMETER :: RN0_G = 4.D6

    !   Other constants
    REAL(KIND=8),PARAMETER :: GAMMA_SEVEN = 720.D0
    REAL(KIND=8),PARAMETER :: RHOWAT = 1000.D0
    REAL(KIND=8),PARAMETER :: RHO_R = RHOWAT
    REAL(KIND=8),PARAMETER :: RHO_S = 100.D0
    REAL(KIND=8),PARAMETER :: RHO_G = 400.D0
    REAL(KIND=8),PARAMETER :: ALPHA = 0.224D0
    REAL(KIND=8),PARAMETER :: CELKEL = 273.15D0
    REAL(KIND=8),PARAMETER :: PI = 3.141592653589793D0
    REAL(KIND=8),PARAMETER :: RD = 287.04D0

    !   Force all Q arrays to be 0.0 or greater.
    DO k = 1,nz
     DO j = 1,ny
        DO i = 1,nx
           IF (qvp(i,j,k).LT.0.0) THEN
              qvp(i,j,k) = 0.0
           END IF
           IF (qra(i,j,k).LT.0.0) THEN
              qra(i,j,k) = 0.0
           END IF
           IF (qsn(i,j,k).LT.0.0) THEN
              qsn(i,j,k) = 0.0
           END IF
           IF (qgr(i,j,k).LT.0.0) THEN
              qgr(i,j,k) = 0.0
           END IF
        END DO
     END DO
    END DO

    !   Input pressure is Pa, but we need hPa in calculations

    IF (sn0.EQ.0) THEN
      DO k = 1,nz
          DO j = 1,ny
              DO i = 1,nx
                  IF (tmk(i,j,k).LT.CELKEL) THEN
                      qsn(i,j,k) = qra(i,j,k)
                      qra(i,j,k) = 0.D0
                  END IF
              END DO
          END DO
      END DO
    END IF

    factor_r = GAMMA_SEVEN*1.D18* (1.D0/ (PI*RHO_R))**1.75D0
    factor_s = GAMMA_SEVEN*1.D18* (1.D0/ (PI*RHO_S))**1.75D0*(RHO_S/RHOWAT)**2*ALPHA
    factor_g = GAMMA_SEVEN*1.D18* (1.D0/ (PI*RHO_G))**1.75D0*(RHO_G/RHOWAT)**2*ALPHA

    DO k = 1,nz
      DO j = 1,ny
          DO i = 1,nx

              virtual_t = tmk(i,j,k)* (0.622D0+qvp(i,j,k))/(0.622D0* (1.D0+qvp(i,j,k)))
              rhoair = prs(i,j,k) / (RD*virtual_t)

    !      Adjust factor for brightband, where snow or graupel particle
    !      scatters like liquid water (alpha=1.0) because it is assumed to
    !      have a liquid skin.

              IF (iliqskin.EQ.1 .AND. tmk(i,j,k).GT.CELKEL) THEN
                  factorb_s = factor_s/ALPHA
                  factorb_g = factor_g/ALPHA
              ELSE
                  factorb_s = factor_s
                  factorb_g = factor_g
              END IF

    !      Calculate variable intercept parameters

              IF (ivarint.EQ.1) THEN

                  temp_c = DMIN1(-0.001D0,tmk(i,j,k)-CELKEL)
                  sonv = DMIN1(2.0D8,2.0D6*EXP(-0.12D0*temp_c))

                  gonv = gon
                  IF (qgr(i,j,k).GT.R1) THEN
                      gonv = 2.38D0* (PI*RHO_G/(rhoair*qgr(i,j,k)))**0.92D0
                      gonv = MAX(1.D4,MIN(gonv,GON))
                  END IF

                  ronv = RON2
                  IF (qra(i,j,k).GT.R1) THEN
                      ronv = RON_CONST1R*TANH((RON_QR0-qra(i,j,k))/RON_DELQR0) + RON_CONST2R
                  END IF

              ELSE

                  ronv = RN0_R
                  sonv = RN0_S
                  gonv = RN0_G

              END IF

    !      Total equivalent reflectivity factor (z_e, in mm^6 m^-3) is
    !      the sum of z_e for each hydrometeor species:

              z_e = factor_r*(rhoair*qra(i,j,k))**1.75D0/ronv**.75D0 + &
                factorb_s*(rhoair*qsn(i,j,k))**1.75D0/sonv**.75D0 + &
                factorb_g* (rhoair*qgr(i,j,k))**1.75D0/gonv**.75D0

    !      Adjust small values of Z_e so that dBZ is no lower than -30
              z_e = MAX(z_e,.001D0)

    !      Convert to dBZ
              dbz(i,j,k) = 10.D0*LOG10(z_e)

          END DO
      END DO
    END DO

    RETURN

END SUBROUTINE f_computedbz

SUBROUTINE rotatecoords(ilat,ilon,olat,olon,lat_np,lon_np,lon_0,direction)

    IMPLICIT NONE

    REAL(KIND=8),INTENT(IN) :: ilat,ilon
    REAL(KIND=8),INTENT(OUT) :: olat,olon
    REAL(KIND=8),INTENT(IN) :: lat_np,lon_np,lon_0
    INTEGER,INTENT(IN) :: direction

    !  >=0, default : computational -> geographical
    !  < 0          : geographical  -> computational

    REAL(KIND=8) :: rlat,rlon
    REAL(KIND=8) :: phi_np,lam_np,lam_0,dlam
    REAL(KIND=8) :: sinphi,cosphi,coslam,sinlam
    REAL(KIND=8),PARAMETER :: PI=3.141592653589793d0
    REAL(KIND=8),PARAMETER :: RAD_PER_DEG=PI/180.d0
    REAL(KIND=8),PARAMETER :: DEG_PER_RAD=180.d0/PI

    !convert all angles to radians
    phi_np = lat_np*RAD_PER_DEG
    lam_np = lon_np*RAD_PER_DEG
    lam_0 = lon_0*RAD_PER_DEG
    rlat = ilat*RAD_PER_DEG
    rlon = ilon*RAD_PER_DEG

    IF (direction.LT.0) THEN
    ! the equations are exactly the same except for one
    ! small difference with respect to longitude ...
      dlam = pi - lam_0
    ELSE
      dlam = lam_np
    END IF

    sinphi = COS(phi_np)*COS(rlat)*COS(rlon-dlam) + SIN(phi_np)*SIN(rlat)
    cosphi = SQRT(1.d0-sinphi*sinphi)
    coslam = SIN(phi_np)*COS(rlat)*COS(rlon-dlam) - COS(phi_np)*SIN(rlat)
    sinlam = COS(rlat)*SIN(rlon-dlam)

    IF (cosphi.NE.0.d0) THEN
      coslam = coslam/cosphi
      sinlam = sinlam/cosphi
    END IF

    olat = DEG_PER_RAD*ASIN(sinphi)
    olon = DEG_PER_RAD*(ATAN2(sinlam,coslam)-dlam-lam_0+lam_np)

    RETURN

END SUBROUTINE rotatecoords

SUBROUTINE f_lltoij(map_proj,truelat1,truelat2,stdlon,lat1,lon1,&
                   pole_lat,pole_lon,knowni,knownj,dx,latinc,&
                   loninc,lat,lon,throw_exception,loc)

    IMPLICIT NONE

    EXTERNAL throw_exception
    ! Converts input lat/lon values to the cartesian (i,j) value
    ! for the given projection.

    INTEGER,INTENT(IN) :: map_proj
    REAL(KIND=8),INTENT(IN) :: stdlon
    REAL(KIND=8),INTENT(IN) ::lat1,lon1,pole_lat,pole_lon,knowni,knownj
    REAL(KIND=8),INTENT(IN) ::dx,latinc,loninc
    REAL(KIND=8),INTENT(INOUT) :: lat,lon,truelat1,truelat2 ! these might get modified
    REAL(KIND=8),DIMENSION(2),INTENT(OUT) :: loc

    REAL(KIND=8) :: deltalon1
    REAL(KIND=8) :: tl1r
    REAL(KIND=8) :: clain,dlon,rsw,deltalon,deltalat
    REAL(KIND=8) :: reflon,scale_top,ala1,alo1,ala,alo,rm,polei,polej
    ! earth radius divided by dx
    REAL(KIND=8) :: rebydx
    REAL(KIND=8) :: ctl1r,arg,cone,hemi
    REAL(KIND=8) :: i,j
    REAL(KIND=8) :: lat1n,lon1n,olat,olon

    ! Contants
    REAL(KIND=8),PARAMETER :: PI=3.141592653589793d0
    REAL(KIND=8),PARAMETER :: RAD_PER_DEG=PI/180.d0
    REAL(KIND=8),PARAMETER :: DEG_PER_RAD=180.d0/PI
    REAL(KIND=8),PARAMETER :: RE_M=6370000.d0 ! radius of earth in meters

    !      lat1     ! sw latitude (1,1) in degrees (-90->90n)
    !      lon1     ! sw longitude (1,1) in degrees (-180->180e)
    !      dx       ! grid spacing in meters at truelats
    !      dlat     ! lat increment for lat/lon grids
    !      dlon     ! lon increment for lat/lon grids
    !      stdlon   ! longitude parallel to y-axis (-180->180e)
    !      truelat1 ! first true latitude (all projections)
    !      truelat2 ! second true lat (lc only)
    !      hemi     ! 1 for nh, -1 for sh
    !      cone     ! cone factor for lc projections
    !      polei    ! computed i-location of pole point
    !      polej    ! computed j-location of pole point
    !      rsw      ! computed radius to sw corner
    !      knowni   ! x-location of known lat/lon
    !      knownj   ! y-location of known lat/lon
    !      re_m     ! radius of spherical earth, meters
    !      rebydx   ! earth radius divided by dx

    rebydx = RE_M/dx

    ! Get rid of compiler warnings
    i=0
    j=0

    hemi = 1.0d0
    IF (truelat1.LT.0.0d0) THEN
      hemi = -1.0d0
    END IF

    ! mercator
    IF (map_proj.EQ.3) THEN

      ! preliminary variables
      clain = COS(RAD_PER_DEG*truelat1)
      dlon = dx/(RE_M*clain)

      ! compute distance from equator to origin, and store in
      ! the rsw tag.
      rsw = 0.d0
      IF (lat1.NE.0.d0) THEN
          rsw = (DLOG(TAN(0.5d0*((lat1+90.d0)*RAD_PER_DEG))))/dlon
      END IF

      deltalon = lon - lon1
      IF (deltalon.LT.-180.d0) deltalon = deltalon + 360.d0
      IF (deltalon.GT.180.d0) deltalon = deltalon - 360.d0
      i = knowni + (deltalon/(dlon*DEG_PER_RAD))
      j = knownj + (DLOG(TAN(0.5d0*((lat+90.d0)*RAD_PER_DEG))))/dlon - rsw

    ! ps
    ELSE IF (map_proj.EQ.2) THEN

      reflon = stdlon + 90.d0

      ! compute numerator term of map scale factor
      scale_top = 1.d0 + hemi*SIN(truelat1*RAD_PER_DEG)

      ! compute radius to lower-left (sw) corner
      ala1 = lat1*RAD_PER_DEG
      rsw = rebydx*COS(ala1)*scale_top/(1.d0+hemi*SIN(ala1))

      ! find the pole point
      alo1 = (lon1-reflon)*RAD_PER_DEG
      polei = knowni - rsw*COS(alo1)
      polej = knownj - hemi*rsw*SIN(alo1)

      ! find radius to desired point
      ala = lat*RAD_PER_DEG
      rm = rebydx*COS(ala)*scale_top/ (1.d0+hemi*SIN(ala))
      alo = (lon-reflon)*RAD_PER_DEG
      i = polei + rm*COS(alo)
      j = polej + hemi*rm*SIN(alo)

    ! lambert
    ELSE IF (map_proj.EQ.1) THEN

      IF (ABS(truelat2).GT.90.d0) THEN
          truelat2 = truelat1
      END IF

      IF (ABS(truelat1-truelat2).GT.0.1d0) THEN
          cone = (DLOG(COS(truelat1*RAD_PER_DEG))-DLOG(COS(truelat2*RAD_PER_DEG)))/&
                 (DLOG(TAN((90.d0-ABS(truelat1))*RAD_PER_DEG*0.5d0))-&
                 DLOG(TAN((90.d0-ABS(truelat2))*RAD_PER_DEG*0.5d0)))
      ELSE
          cone = SIN(ABS(truelat1)*RAD_PER_DEG)
      END IF

      ! compute longitude differences and ensure we stay
      ! out of the forbidden "cut zone"
      deltalon1 = lon1 - stdlon
      IF (deltalon1.GT.+180.d0) deltalon1 = deltalon1 - 360.d0
      IF (deltalon1.LT.-180.d0) deltalon1 = deltalon1 + 360.d0

      ! convert truelat1 to radian and compute cos for later use
      tl1r = truelat1*RAD_PER_DEG
      ctl1r = COS(tl1r)

      ! compute the radius to our known lower-left (sw) corner
      rsw = rebydx*ctl1r/cone*(TAN((90.d0*hemi-lat1)*RAD_PER_DEG/2.d0)/&
            TAN((90.d0*hemi-truelat1)*RAD_PER_DEG/2.d0))**cone

      ! find pole point
      arg = cone* (deltalon1*RAD_PER_DEG)
      polei = hemi*knowni - hemi*rsw*SIN(arg)
      polej = hemi*knownj + rsw*COS(arg)

      ! compute deltalon between known longitude and standard
      ! lon and ensure it is not in the cut zone
      deltalon = lon - stdlon
      IF (deltalon.GT.+180.d0) deltalon = deltalon - 360.d0
      IF (deltalon.LT.-180.d0) deltalon = deltalon + 360.d0

      ! radius to desired point
      rm = rebydx*ctl1r/cone*(TAN((90.d0*hemi-lat)*RAD_PER_DEG/2.d0)/&
                  TAN((90.d0*hemi-truelat1)*RAD_PER_DEG/2.d0))**cone

      arg = cone*(deltalon*RAD_PER_DEG)
      i = polei + hemi*rm*SIN(arg)
      j = polej - rm*COS(arg)

      ! finally, if we are in the southern hemisphere, flip the
      ! i/j values to a coordinate system where (1,1) is the sw
      ! corner (what we assume) which is different than the
      ! original ncep algorithms which used the ne corner as
      ! the origin in the southern hemisphere (left-hand vs.
      ! right-hand coordinate?)
      i = hemi*i
      j = hemi*j

    ! lat-lon
    ELSE IF (map_proj.EQ.6) THEN

      IF (pole_lat.NE.90.d0) THEN
          CALL rotatecoords(lat,lon,olat,olon,pole_lat,pole_lon,stdlon,-1)
          lat = olat
          lon = olon + stdlon
      END IF

      ! make sure center lat/lon is good
      IF (pole_lat.NE.90.d0) THEN
          CALL rotatecoords(lat1,lon1,olat,olon,pole_lat,pole_lon,stdlon,-1)
          lat1n = olat
          lon1n = olon + stdlon
          deltalat = lat - lat1n
          deltalon = lon - lon1n
      ELSE
          deltalat = lat - lat1
          deltalon = lon - lon1
      END IF

      ! compute i/j
      i = deltalon/loninc
      j = deltalat/latinc

      i = i + knowni
      j = j + knownj

    ELSE

      CALL throw_exception('Do not know map projection ', map_proj)
      ! TODO throw exception

    END IF

    loc(1) = j
    loc(2) = i

    RETURN

END SUBROUTINE f_lltoij

SUBROUTINE f_ijtoll(map_proj,truelat1,truelat2,stdlon,lat1,lon1,&
                   pole_lat,pole_lon,knowni,knownj,dx,latinc,&
                   loninc,ai,aj,throw_exception,loc)

    ! converts input lat/lon values to the cartesian (i,j) value
    ! for the given projection.
    IMPLICIT NONE

    EXTERNAL throw_exception
    INTEGER,INTENT(IN) :: map_proj
    REAL(KIND=8),INTENT(IN) :: stdlon
    REAL(KIND=8),INTENT(IN) :: lat1,lon1,pole_lat,pole_lon,knowni,knownj
    REAL(KIND=8),INTENT(IN) :: dx,latinc,loninc,ai,aj
    REAL(KIND=8),INTENT(INOUT) :: truelat1,truelat2
    REAL(KIND=8),DIMENSION(2),INTENT(OUT) :: loc

    REAL(KIND=8) :: gi2
    REAL(KIND=8) :: arccos
    REAL(KIND=8) :: deltalon1
    REAL(KIND=8) :: tl1r
    REAL(KIND=8) :: clain,dlon,rsw,deltalon,deltalat
    REAL(KIND=8) :: reflon,scale_top,ala1,alo1,polei,polej
    ! earth radius divided by dx
    REAL(KIND=8) :: rebydx
    REAL(KIND=8) :: ctl1r,cone,hemi

    REAL(KIND=8),PARAMETER :: PI = 3.141592653589793d0
    REAL(KIND=8),PARAMETER :: RAD_PER_DEG = PI/180.d0
    REAL(KIND=8),PARAMETER :: DEG_PER_RAD = 180.d0/PI
    REAL(KIND=8),PARAMETER :: RE_M = 6370000.d0 ! radius of sperical earth

    REAL(KIND=8) :: inew,jnew,r,r2
    REAL(KIND=8) :: chi,chi1,chi2
    REAL(KIND=8) :: xx,yy,lat,lon

    REAL(KIND=8) :: olat,olon,lat1n,lon1n

    !     lat1     ! sw latitude (1,1) in degrees (-90->90n)
    !     lon1     ! sw longitude (1,1) in degrees (-180->180e)
    !     dx       ! grid spacing in meters at truelats
    !     dlat     ! lat increment for lat/lon grids
    !     dlon     ! lon increment for lat/lon grids
    !     stdlon   ! longitude parallel to y-axis (-180->180e)
    !     truelat1 ! first true latitude (all projections)
    !     truelat2 ! second true lat (lc only)
    !     hemi     ! 1 for nh, -1 for sh
    !     cone     ! cone factor for lc projections
    !     polei    ! computed i-location of pole point
    !     polej    ! computed j-location of pole point
    !     rsw      ! computed radius to sw corner
    !     knowni   ! x-location of known lat/lon
    !     knownj   ! y-location of known lat/lon
    !     re_m     ! radius of spherical earth, meters
    !     rebydx   ! earth radius divided by dx

    rebydx = RE_M/dx

    hemi = 1.0d0
    IF (truelat1.LT.0.0d0) THEN
      hemi = -1.0d0
    END IF

    ! mercator
    IF (map_proj.EQ.3) THEN

      ! preliminary variables
      clain = COS(RAD_PER_DEG*truelat1)
      dlon = dx/(RE_M*clain)

      ! compute distance from equator to origin, and store in
      ! the rsw tag.
      rsw = 0.d0
      IF (lat1.NE.0.d0) THEN
          rsw = (DLOG(TAN(0.5d0*((lat1+90.d0)*RAD_PER_DEG))))/dlon
      END IF

      lat = 2.0d0*ATAN(EXP(dlon*(rsw+aj-knownj)))*DEG_PER_RAD - 90.d0
      lon = (ai-knowni)*dlon*DEG_PER_RAD + lon1
      IF (lon.GT.180.d0) lon = lon - 360.d0
      IF (lon.LT.-180.d0) lon = lon + 360.d0

    ! ps
    ELSE IF (map_proj.EQ.2) THEN

      ! compute the reference longitude by rotating 90 degrees to
      ! the east to find the longitude line parallel to the
      ! positive x-axis.
      reflon = stdlon + 90.d0

      ! compute numerator term of map scale factor
      scale_top = 1.d0 + hemi*SIN(truelat1*RAD_PER_DEG)

      ! compute radius to known point
      ala1 = lat1*RAD_PER_DEG
      rsw = rebydx*COS(ala1)*scale_top/(1.d0+hemi*SIN(ala1))

      ! find the pole point
      alo1 = (lon1-reflon)*RAD_PER_DEG
      polei = knowni - rsw*COS(alo1)
      polej = knownj - hemi*rsw*SIN(alo1)

      ! compute radius to point of interest
      xx = ai - polei
      yy = (aj-polej)*hemi
      r2 = xx**2 + yy**2

      ! now the magic code
      IF (r2.EQ.0.d0) THEN
          lat = hemi*90.d0
          lon = reflon
      ELSE
          gi2 = (rebydx*scale_top)**2.d0
          lat = DEG_PER_RAD*hemi*ASIN((gi2-r2)/ (gi2+r2))
          arccos = ACOS(xx/SQRT(r2))
          IF (yy.GT.0) THEN
              lon = reflon + DEG_PER_RAD*arccos
          ELSE
              lon = reflon - DEG_PER_RAD*arccos
          END IF
      END IF

      ! convert to a -180 -> 180 east convention
      IF (lon.GT.180.d0) lon = lon - 360.d0
      IF (lon.LT.-180.d0) lon = lon + 360.d0

    !     !lambert
    ELSE IF (map_proj.EQ.1) THEN

      IF (ABS(truelat2).GT.90.d0) THEN
          truelat2 = truelat1
      END IF

      IF (ABS(truelat1-truelat2).GT.0.1d0) THEN
          cone = (DLOG(COS(truelat1*RAD_PER_DEG))-DLOG(COS(truelat2*RAD_PER_DEG)))/&
                 (DLOG(TAN((90.d0-ABS(truelat1))*RAD_PER_DEG*0.5d0))-&
                  DLOG(TAN((90.d0-ABS(truelat2))*RAD_PER_DEG*0.5d0)))
      ELSE
          cone = SIN(ABS(truelat1)*RAD_PER_DEG)
      END IF

      ! compute longitude differences and ensure we stay out of the
      ! forbidden "cut zone"
      deltalon1 = lon1 - stdlon
      IF (deltalon1.GT.+180.d0) deltalon1 = deltalon1 - 360.d0
      IF (deltalon1.LT.-180.d0) deltalon1 = deltalon1 + 360.d0

      ! convert truelat1 to radian and compute cos for later use
      tl1r = truelat1*RAD_PER_DEG
      ctl1r = COS(tl1r)

      ! compute the radius to our known point
      rsw = rebydx*ctl1r/cone*(TAN((90.d0*hemi-lat1)*RAD_PER_DEG/2.d0)/&
                         TAN((90.d0*hemi-truelat1)*RAD_PER_DEG/2.d0))**cone

      ! find pole point
      alo1 = cone* (deltalon1*RAD_PER_DEG)
      polei = hemi*knowni - hemi*rsw*SIN(alo1)
      polej = hemi*knownj + rsw*COS(alo1)

      chi1 = (90.d0-hemi*truelat1)*RAD_PER_DEG
      chi2 = (90.d0-hemi*truelat2)*RAD_PER_DEG

      ! see if we are in the southern hemispere and flip the
      ! indices if we are.
      inew = hemi*ai
      jnew = hemi*aj

      ! compute radius**2 to i/j location
      reflon = stdlon + 90.d0
      xx = inew - polei
      yy = polej - jnew
      r2 = (xx*xx+yy*yy)
      r = sqrt(r2)/rebydx

      ! convert to lat/lon
      IF (r2.EQ.0.d0) THEN
          lat = hemi*90.d0
          lon = stdlon
      ELSE
          lon = stdlon + DEG_PER_RAD*ATAN2(hemi*xx,yy)/cone
          lon = dmod(lon+360.d0,360.d0)
          IF (chi1.EQ.chi2) THEN
              chi = 2.0d0*ATAN((r/TAN(chi1))** (1.d0/cone)*TAN(chi1*0.5d0))
          ELSE
              chi = 2.0d0*ATAN((r*cone/SIN(chi1))** (1.d0/cone)*TAN(chi1*0.5d0))
          END IF
          lat = (90.0d0-chi*DEG_PER_RAD)*hemi
      END IF

      IF (lon.GT.+180.d0) lon = lon - 360.d0
      IF (lon.LT.-180.d0) lon = lon + 360.d0

    !     !lat-lon
    ELSE IF (map_proj.EQ.6) THEN

      inew = ai - knowni
      jnew = aj - knownj

      IF (inew.LT.0.d0) inew = inew + 360.d0/loninc
      IF (inew.GE.360.d0/dx) inew = inew - 360.d0/loninc

      ! compute deltalat and deltalon
      deltalat = jnew*latinc
      deltalon = inew*loninc

      IF (pole_lat.NE.90.d0) THEN
          CALL rotatecoords(lat1,lon1,olat,olon,pole_lat,pole_lon,stdlon,-1)
          lat1n = olat
          lon1n = olon + stdlon
          lat = deltalat + lat1n
          lon = deltalon + lon1n
      ELSE
          lat = deltalat + lat1
          lon = deltalon + lon1
      END IF

      IF (pole_lat.NE.90.d0) THEN
          lon = lon - stdlon
          CALL rotatecoords(lat,lon,olat,olon,pole_lat,pole_lon,stdlon,1)
          lat = olat
          lon = olon
      END IF

      IF (lon.LT.-180.d0) lon = lon + 360.d0
      IF (lon.GT.180.d0) lon = lon - 360.d0

    ELSE

      CALL throw_exception('Do not know map projection ',map_proj)

    END IF

    loc(1) = lat
    loc(2) = lon

    RETURN

END SUBROUTINE f_ijtoll

! Eta = (p - ptop) / (psfc - ptop)
! Potential temperature:
! theta = T * (Po/P)^(R/CP)
! Hypsometric equation:
! h = z2-z1 = R*Tbar/G * ln(p1/p2)
! where z1, p1 are the surface
SUBROUTINE f_converteta(full_t, znu, psfc, ptop, pcalc, mean_t, temp_t,&
                        z, nx,ny,nz)

    IMPLICIT NONE

    REAL(KIND=8),DIMENSION(nx,ny,nz),INTENT(IN) :: full_t
    REAL(KIND=8),DIMENSION(nz),INTENT(IN) :: znu
    REAL(KIND=8),DIMENSION(nx,ny),INTENT(IN) :: psfc
    REAL(KIND=8),INTENT(IN) :: ptop
    REAL(KIND=8),DIMENSION(nx,ny,nz),INTENT(INOUT) :: pcalc
    REAL(KIND=8),DIMENSION(nx,ny,nz),INTENT(INOUT) :: mean_t
    REAL(KIND=8),DIMENSION(nx,ny,nz),INTENT(INOUT) :: temp_t
    REAL(KIND=8),DIMENSION(nx,ny,nz),INTENT(OUT) :: z
    INTEGER,INTENT(IN) :: nx,ny,nz

    REAL(KIND=8) :: s, cnt, avg
    REAL(KIND=8),PARAMETER :: R=287.06, G=9.81, CP=1005.0, P0=100000.0
    INTEGER i,j,k,kk

    DO k=1,nz
        DO j=1,ny
            DO i=1,nx
                pcalc(i,j,k) = (znu(k) * (psfc(i,j) - ptop)) + ptop
            END DO
        END DO
    END DO

    DO k=1,nz
        DO j=1,ny
            DO i=1,nx
                temp_t(i,j,k) = (full_t(i,j,k)) / ((P0 / (pcalc(i,j,k)))**(R/CP))
            END DO
        END DO
    END DO

    DO k=1,nz
        DO j = 1, ny
            DO i = 1, nx
                s = 0
                cnt = 0
                DO kk=1,k
                    s = s + temp_t(i,j,kk)
                    cnt = cnt + 1
                END DO
                avg = s / cnt
                mean_t(i,j,k) = avg
            END DO
        END DO
    END DO

    DO k=1,nz
        DO j=1,ny
          DO i=1,nx
            z(i,j,k) = ((R*mean_t(i,j,k))/G) * LOG(psfc(i,j)/pcalc(i,j,k))
          END DO
        END DO
    END DO

    RETURN

END SUBROUTINE f_converteta

SUBROUTINE f_computectt(prs,tk,qci,qcw,qvp,ght,ter,haveqci,ctt,ew,ns,nz)

    IMPLICIT NONE

    REAL(KIND=8),DIMENSION(ew,ns,nz), INTENT(IN) :: ght, prs, tk, qci, qcw, qvp
    REAL(KIND=8),DIMENSION(ew,ns), INTENT(IN) :: ter
    REAL(KIND=8),DIMENSION(ew,ns), INTENT(OUT) :: ctt
    INTEGER, INTENT(IN) :: nz,ns,ew,haveqci
    !     REAL(KIND=8) ::     znfac(nz)

    ! LOCAL VARIABLES
    INTEGER i,j,k,ripk
    !INTEGER :: mjx,miy,mkzh
    REAL(KIND=8) :: vt,opdepthu,opdepthd,dp
    REAL(KIND=8) :: ratmix,arg1,arg2,agl_hgt
    REAL(KIND=8) :: fac,prsctt
    !REAL(KIND=8) :: eps,ussalr,rgas,grav,abscoefi,abscoef,celkel,wrfout
    !REAL(KIND=8) ::    ght(ew,ns,nz),stuff(ew,ns)
    !REAL(KIND=8), DIMENSION(ew,ns,nz) ::     pf(ns,ew,nz),p1,p2
    REAL(KIND=8), DIMENSION(ew,ns,nz) :: pf
    REAL(KIND=8) :: p1, p2

    REAL(KIND=8), PARAMETER :: EPS = 0.622d0
    REAL(KIND=8), PARAMETER :: USSALR = .0065d0      ! deg C per m
    REAL(KIND=8), PARAMETER :: RGAS = 287.04d0     !J/K/kg
    REAL(KIND=8), PARAMETER :: GRAV = 9.81d0
    REAL(KIND=8), PARAMETER :: ABSCOEFI = .272d0  ! cloud ice absorption coefficient in m^2/g
    REAL(KIND=8), PARAMETER :: ABSCOEF =.145d0   ! cloud water absorption coefficient in m^2/g
    REAL(KIND=8), PARAMETER :: CELKEL = 273.15d0
    REAL(KIND=8), PARAMETER :: WRFOUT = 1

    !mjx = ew
    !miy = ns
    !mkzh = nz

    prsctt = 0 ! removes the warning

! Calculate the surface pressure
    DO j=1,ns
        DO i=1,ew
           ratmix     = .001d0*qvp(i,j,1)
           arg1       = EPS + ratmix
           arg2       = EPS*(1.+ratmix)
           vt         = tk(i,j,1) * arg1/arg2 !Virtual temperature
           agl_hgt    = ght(i,j,nz) - ter(i,j)
           arg1       = -GRAV/(RGAS*USSALR)
           pf(i,j,nz) = prs(i,j,1)*(vt/(vt+USSALR*(agl_hgt)))**(arg1)
        END DO
    END DO

    DO k=1,nz-1
        DO j=1,ns
          DO i=1,ew
            ripk = nz-k+1
            pf(i,j,k)=.5d0*(prs(i,j,ripk)+prs(i,j,ripk-1))
          END DO
        END DO
    END DO

    DO j=1,ns
        DO i=1,ew
            opdepthd=0.d0
            k=0

!      Integrate downward from model top, calculating path at full
!      model vertical levels.

!20          opdepthu=opdepthd

            DO k=1, nz
                opdepthu=opdepthd
                !k=k+1
                ripk = nz-k+1

                IF (k.EQ.1) THEN
                    dp=200.d0*(pf(i,j,1)-prs(i,j,nz))  ! should be in Pa
                ELSE
                    dp=100.d0*(pf(i,j,k)-pf(i,j,k-1))  ! should be in Pa
                END IF

                IF (haveqci .EQ. 0) then
                    IF (tk(i,j,k) .LT. CELKEL) then
                        ! Note: abscoefi is m**2/g, qcw is g/kg, so no convrsion needed
                        opdepthd=opdepthu+ABSCOEFI*qcw(i,j,k)*dp/GRAV
                    ELSE
                        opdepthd=opdepthu+ABSCOEF*qcw(i,j,k)*dp/GRAV
                    END IF
                ELSE
                    opdepthd=opdepthd+(ABSCOEF*qcw(i,j,ripk)+ABSCOEFI*qci(i,j,ripk))*dp/GRAV
                END IF

                IF (opdepthd.LT.1. .AND. k.LT.nz) THEN
                    !GOTO 20
                    CYCLE

                ELSE IF (opdepthd.LT.1. .AND. k.EQ.nz) THEN
                    prsctt=prs(i,j,1)
                    EXIT
                ELSE
                    fac=(1.-opdepthu)/(opdepthd-opdepthu)
                    prsctt=pf(i,j,k-1)+fac*(pf(i,j,k)-pf(i,j,k-1))
                    prsctt=min(prs(i,j,1),max(prs(i,j,nz),prsctt))
                    EXIT
                END IF
            END DO

            DO k=2,nz
                ripk = nz-k+1
                p1 = prs(i,j,ripk+1)
                p2 = prs(i,j,ripk)
                IF (prsctt .GE. p1 .AND. prsctt .LE. p2) THEN
                    fac=(prsctt-p1)/(p2-p1)
                    arg1 = fac*(tk(i,j,ripk) - tk(i,j,ripk+1)) - CELKEL
                    ctt(i,j) = tk(i,j,ripk+1) + arg1
                    !GOTO 40
                    EXIT
                END IF
            END DO
        END DO
    END DO
!   30    CONTINUE
!   40    CONTINUE
! 190  CONTINUE
    RETURN

END SUBROUTINE f_computectt

SUBROUTINE f_filter2d(a, b, missing, it, nx, ny)

    IMPLICIT NONE

    INTEGER, INTENT(IN) :: nx, ny, it
    REAL(KIND=8), DIMENSION(nx, ny), INTENT(INOUT) :: a
    REAL(KIND=8), INTENT(IN) :: missing
    REAL(KIND=8), DIMENSION(nx, ny), INTENT(INOUT) :: b

    REAL(KIND=8), PARAMETER :: COEF=0.25D0

    INTEGER :: i, j, iter

    DO iter=1,it
        DO j=1,ny
            DO i = 1,nx
                b(i,j) = a(i,j)
            END DO
        END DO

        DO j=2,ny-1
            DO i=1,nx
                IF (b(i,j-1) .EQ. missing .OR. b(i,j) .EQ. missing .OR. &
                    b(i,j+1) .EQ. missing) THEN
                    a(i,j) = a(i,j)
                ELSE
                    a(i,j) = a(i,j) + COEF*(b(i,j-1)-2*b(i,j) + b(i,j+1))
                END IF
            END DO
        END DO

        DO j=1,ny
            DO i=2,nx-1
                IF (b(i-1,j) .EQ. missing .OR. b(i,j) .EQ. missing .OR. &
                    b(i+1,j) .EQ. missing) THEN
                    a(i,j) = a(i,j)
                ELSE
                    a(i,j) = a(i,j) + COEF*(b(i-1,j)-2*b(i,j)+b(i+1,j))
                END IF
            END DO
        END DO
    !        do j=1,ny
    !        do i=1,nx
    !          b(i,j) = a(i,j)
    !        enddo
    !        enddo
    !        do j=2,ny-1
    !        do i=1,nx
    !          a(i,j) = a(i,j) - .99*coef*(b(i,j-1)-2*b(i,j)+b(i,j+1))
    !        enddo
    !        enddo
    !        do j=1,ny
    !        do i=2,nx-1
    !          a(i,j) = a(i,j) - .99*coef*(b(i-1,j)-2*b(i,j)+b(i+1,j))
    !        enddo
    !        enddo
    END DO

    RETURN

END SUBROUTINE f_filter2d

SUBROUTINE f_monotonic(out,in,lvprs,cor,idir,delta,ew,ns,nz,icorsw)

    IMPLICIT NONE

    INTEGER, INTENT(IN) :: idir,ew,ns,nz,icorsw
    REAL(KIND=8), INTENT(IN) :: delta
    REAL(KIND=8), DIMENSION(ew,ns,nz), INTENT(INOUT) :: in
    REAL(KIND=8), DIMENSION(ew,ns,nz), INTENT(OUT) :: out
    REAL(KIND=8), DIMENSION(ew,ns,nz) :: lvprs
    REAL(KIND=8), DIMENSION(ew,ns) :: cor

    INTEGER :: i,j,k,ripk,k300

    k300 = 0 ! removes the warning

    DO j=1,ns
        DO i=1,ew
            IF (icorsw .EQ. 1 .AND. cor(i,j) .LT. 0.) THEN
                DO k=1,nz
                    in(i,j,k) = -in(i,j,k)
                END DO
            END IF

            ! First find k index that is at or below (height-wise)
            ! the 300 hPa level.
            DO k = 1,nz
                ripk = nz-k+1
                IF (lvprs(i,j,k) .LE. 300.d0) THEN
                    k300 = k
                    EXIT
                END IF
            END DO

            DO k = k300, 1,-1
                IF (idir .EQ. 1) THEN
                    out(i,j,k) = MIN(in(i,j,k), in(i,j,k+1)+delta)
                ELSE IF (idir .EQ. -1) THEN
                    out(i,j,k) = MAX(in(i,j,k), in(i,j,k+1)-delta)
                END IF
            END DO

            DO k = k300+1, nz
                IF (idir .EQ. 1) THEN
                    out(i,j,k) = MAX(in(i,j,k), in(i,j,k-1)-delta)
                ELSE IF (idir .EQ. -1) THEN
                    out(i,j,k) = MIN(in(i,j,k), in(i,j,k-1)+delta)
                END IF
            END DO
        END DO
    END DO

    RETURN

END SUBROUTINE f_monotonic

FUNCTION f_intrpvalue (wvalp0,wvalp1,vlev,vcp0,vcp1,icase)

    IMPLICIT NONE

    INTEGER, INTENT(IN) :: icase
    REAL(KIND=8), INTENT(IN) :: wvalp0,wvalp1,vlev,vcp0,vcp1
    REAL(KIND=8) :: f_intrpvalue

    REAL(KIND=8) :: valp0,valp1,rvalue
    REAL(KIND=8) :: chkdiff

    REAL(KIND=8), PARAMETER :: RGAS=287.04d0
    REAL(KIND=8), PARAMETER :: USSALR=0.0065d0
    REAL(KIND=8), PARAMETER :: SCLHT=RGAS*256.d0/9.81d0

    valp0 = wvalp0
    valp1 = wvalp1
    IF ( icase .EQ. 2) THEN  !GHT
       valp0=EXP(-wvalp0/SCLHT)
       valp1=EXP(-wvalp1/SCLHT)
    END IF

    ! TODO:  Remove this STOP
    chkdiff = vcp1 - vcp0
    IF(chkdiff .EQ. 0) THEN
        PRINT *,"bad difference in vcp's"
        STOP
    END IF

    rvalue = (vlev-vcp0)*(valp1-valp0)/(vcp1-vcp0)+valp0
    IF (icase .EQ. 2) THEN  !GHT
        f_intrpvalue = -SCLHT*LOG(rvalue)
    ELSE
        f_intrpvalue = rvalue
    END IF

    RETURN

END FUNCTION f_intrpvalue

! NOTES:
! vcarray is the array holding the values for the vertical coordinate.
! It will always come in with the dimensions of the staggered U and V grid.

SUBROUTINE  f_vintrp(datain,dataout,pres,tk,qvp,ght,terrain,&
                       sfp,smsfp,vcarray,interp_levels,numlevels,&
                       icase,ew,ns,nz,extrap,vcor,logp,rmsg)

    IMPLICIT NONE

    INTEGER, INTENT(IN) :: ew,ns,nz,icase,extrap
    INTEGER, INTENT(IN) :: vcor,numlevels,logp
    REAL(KIND=8), DIMENSION(ew,ns,nz), INTENT(IN) :: datain,pres,tk,qvp
    REAL(KIND=8), DIMENSION(ew,ns,nz), INTENT(IN) :: ght
    REAL(KIND=8), DIMENSION(ew,ns), INTENT(IN) :: terrain,sfp,smsfp
    REAL(KIND=8), DIMENSION(ew,ns,numlevels), INTENT(OUT) :: dataout
    REAL(KIND=8), DIMENSION(ew,ns,nz), INTENT(IN) :: vcarray
    REAL(KIND=8), DIMENSION(numlevels), INTENT(IN) :: interp_levels
    REAL(KIND=8), INTENT(IN) :: rmsg

    INTEGER :: nreqlvs,ripk !njx,niy
    INTEGER :: i,j,k,kupper !itriv
    INTEGER :: ifound,isign !miy,mjx
    REAL(KIND=8), DIMENSION(ew,ns) :: tempout
    REAL(KIND=8) :: rlevel,vlev,diff
    REAL(KIND=8) :: tmpvlev
    REAL(KIND=8) :: vcp1,vcp0,valp0,valp1
!    REAL(KIND=8) :: cvc
    REAL(KIND=8) :: vclhsl,vctophsl !qvlhsl,ttlhsl
    REAL(KIND=8) :: f_intrpvalue
    REAL(KIND=8) :: plhsl,zlhsl,ezlhsl,tlhsl,psurf,pratio,tlev
    REAL(KIND=8) :: ezsurf,psurfsm,zsurf,qvapor,vt
    REAL(KIND=8) :: ezlev,plev,zlev,ptarget,dpmin,dp
    REAL(KIND=8) :: pbot,zbot,tbotextrap,e
    REAL(KIND=8) :: tlcl,gammam
    CHARACTER :: cvcord*1

    REAL(KIND=8), PARAMETER :: RGAS    = 287.04d0     !J/K/kg
    REAL(KIND=8), PARAMETER :: RGASMD  = .608d0
    REAL(KIND=8), PARAMETER :: USSALR  = .0065d0      ! deg C per m
    REAL(KIND=8), PARAMETER :: SCLHT   = RGAS*256.d0/9.81d0
    REAL(KIND=8), PARAMETER :: EPS     = 0.622d0
    REAL(KIND=8), PARAMETER :: RCONST  = -9.81d0/(RGAS * USSALR)
    REAL(KIND=8), PARAMETER :: EXPON   =  RGAS*USSALR/9.81d0
    REAL(KIND=8), PARAMETER :: EXPONI  =  1./EXPON
    REAL(KIND=8), PARAMETER :: TLCLC1   = 2840.d0
    REAL(KIND=8), PARAMETER :: TLCLC2   = 3.5d0
    REAL(KIND=8), PARAMETER :: TLCLC3   = 4.805d0
    REAL(KIND=8), PARAMETER :: TLCLC4   = 55.d0
    REAL(KIND=8), PARAMETER :: THTECON1 = 3376.d0 ! K
    REAL(KIND=8), PARAMETER :: THTECON2 = 2.54d0
    REAL(KIND=8), PARAMETER :: THTECON3 = 0.81d0
    REAL(KIND=8), PARAMETER :: CP       = 1004.d0
    REAL(KIND=8), PARAMETER :: CPMD     = 0.887d0
    REAL(KIND=8), PARAMETER :: GAMMA    = RGAS/CP
    REAL(KIND=8), PARAMETER :: GAMMAMD  = RGASMD-CPMD
    REAL(KIND=8), PARAMETER :: CELKEL   = 273.16d0

    ! Removes the warnings for uninitialized variables
    cvcord = ''
    plev = 0
    zlev = 0
    vlev = 0

    IF (vcor .EQ. 1) THEN
        cvcord = 'p'
    ELSE IF ((vcor .EQ. 2) .OR. (vcor .EQ. 3)) THEN
        cvcord = 'z'
    ELSE IF ((vcor .EQ. 4) .OR. (vcor .EQ. 5)) THEN
        cvcord = 't'
    END IF

    !miy = ns
    !mjx = ew
    !njx = ew
    !niy = ns

    DO j = 1,ns
        DO i = 1,ew
            tempout(i,j) = rmsg
        END DO
    END DO

    DO nreqlvs = 1,numlevels
        IF (cvcord .EQ. 'z') THEN
            ! Convert rlevel to meters from km
            rlevel = interp_levels(nreqlvs) * 1000.d0
            vlev = EXP(-rlevel/SCLHT)
        ELSE IF (cvcord .EQ. 'p') THEN
            vlev = interp_levels(nreqlvs)
        ELSE IF (cvcord .EQ. 't') THEN
            vlev = interp_levels(nreqlvs)
        END IF

        DO j=1,ns
            DO i=1,ew
                ! Get the interpolated value that is within the model domain
                ifound = 0
                DO k = 1,nz-1
                    ripk = nz-k+1
                    vcp1 = vcarray(i,j,ripk-1)
                    vcp0 = vcarray(i,j,ripk)
                    valp0 = datain(i,j,ripk)
                    valp1 = datain(i,j,ripk-1)

                    IF ((vlev .GE. vcp0 .AND. vlev .LE. vcp1) .OR. &
                        (vlev .LE. vcp0 .AND. vlev .GE. vcp1)) THEN
                        ! print *,i,j,valp0,valp1
                        IF ((valp0 .EQ. rmsg) .OR. (valp1 .EQ. rmsg)) THEN
                            tempout(i,j) = rmsg
                            ifound = 1
                        ELSE
                            IF (logp .EQ. 1) THEN
                                vcp1 = LOG(vcp1)
                                vcp0 = LOG(vcp0)
                                IF (vlev .EQ. 0.0d0) THEN
                                    PRINT *,"Pressure value = 0"
                                    PRINT *,"Unable to take log of 0"
                                    STOP
                                END IF
                                tmpvlev = LOG(vlev)
                            ELSE
                                tmpvlev = vlev
                            END IF
                            tempout(i,j) = f_intrpvalue(valp0,valp1,tmpvlev,vcp0,vcp1,icase)

                            ! print *,"one ",i,j,tempout(i,j)
                            ifound = 1
                        END IF
                        !GOTO 115 ! EXIT
                        EXIT
                    END IF
                END DO !end for the k loop
 !115  CONTINUE

                IF (ifound .EQ. 1) THEN !Grid point is in the model domain
                    !GOTO 333 ! CYCLE
                    CYCLE
                END IF

                !If the user has requested no extrapolatin then just assign
                !all values above or below the model level to rmsg.
                IF (extrap .EQ. 0) THEN
                    tempout(i,j) = rmsg
                    !GOTO 333 ! CYCLE
                    CYCLE
                END IF

                ! The grid point is either above or below the model domain
                ! First we will check to see if the grid point is above the
                ! model domain.
                vclhsl = vcarray(i,j,1)  !lowest model level
                vctophsl = vcarray(i,j,nz) !highest model level
                diff = vctophsl - vclhsl
                isign = NINT(diff/ABS(diff))

                IF (isign*vlev .GE. isign*vctophsl) THEN
                    ! Assign the highest model level to the out array
                    tempout(i,j) = datain(i,j,nz)
                    ! print *,"at warn",i,j,tempout(i,j)
                    !GOTO 333 ! CYCLE
                    CYCLE
                END IF

                ! Only remaining possibility is that the specified level is below
                ! lowest model level.  If lowest model level value is missing,
                ! set interpolated value to missing.

                IF (datain(i,j,1) .EQ. rmsg) THEN
                    tempout(i,j) = rmsg
                    !GOTO 333 ! CYCLE
                    CYCLE
                END IF

                ! If the field comming in is not a pressure,temperature or height
                ! field we can set the output array to the value at the lowest
                ! model level.

                tempout(i,j) = datain(i,j,1)

                ! For the special cases of pressure on height levels or height on
                ! pressure levels, or temperature-related variables on pressure or
                ! height levels, perform a special extrapolation based on
                ! US Standard Atmosphere.  Here we calcualate the surface pressure
                ! with the altimeter equation.  This is how RIP calculates the
                ! surface pressure.
                IF (icase .GT. 0) THEN
                    plhsl = pres(i,j,1) * 0.01d0  !pressure at lowest model level
                    zlhsl = ght(i,j,1)            !grid point height a lowest model level
                    ezlhsl = EXP(-zlhsl/SCLHT)
                    tlhsl = tk(i,j,1)             !temperature in K at lowest model level
                    zsurf = terrain(i,j)
                    qvapor = MAX((qvp(i,j,1)*.001d0),1.e-15)
                    ! virtual temperature
                    ! vt     = tlhsl * (eps + qvapor)/(eps*(1.0 + qvapor))
                    ! psurf  = plhsl * (vt/(vt+USSALR * (zlhsl-zsurf)))**rconst
                    psurf = sfp(i,j)
                    psurfsm = smsfp(i,j)
                    ezsurf = EXP(-zsurf/SCLHT)

                    ! The if for checking above ground
                    IF ((cvcord .EQ. 'z' .AND. vlev .LT. ezsurf) .OR. &
                        (cvcord .EQ. 'p' .AND. vlev .LT. psurf)) THEN

                    ! We are below the lowest data level but above the ground.
                    ! Use linear interpolation (linear in prs and exp-height).

                        IF (cvcord .EQ. 'p') THEN
                            plev = vlev
                            ezlev = ((plev-plhsl)*&
                                    ezsurf+(psurf-plev)*ezlhsl)/(psurf-plhsl)
                            zlev = -sclht*LOG(ezlev)
                            IF (icase .EQ. 2) THEN
                                tempout(i,j) = zlev
                                !GOTO 333 ! CYCLE
                                CYCLE
                            END IF

                        ELSE IF (cvcord .EQ. 'z') THEN
                            ezlev = vlev
                            zlev = -sclht*LOG(ezlev)
                            plev = ((ezlev-ezlhsl)*&
                                   psurf+(ezsurf-ezlev)*plhsl)/(ezsurf-ezlhsl)
                            IF (icase .EQ. 1) THEN
                                tempout(i,j) = plev
                                !GOTO 333 ! CYCLE
                                CYCLE
                            END IF
                        END IF

                    ELSE   !else for checking above ground
                        ptarget = psurfsm - 150.d0
                        dpmin = 1.e4
                        DO k=1,nz
                            ripk = nz-k+1
                            dp = ABS((pres(i,j,ripk) * 0.01d0) - ptarget)
                            IF (dp .GT. dpmin) THEN
                                !GOTO 334 ! EXIT
                                EXIT
                            END IF
                            dpmin = MIN(dpmin,dp)
                        END DO
         !334
                        kupper = k-1

                        ripk = nz - kupper + 1
                        pbot = MAX(plhsl,psurf)
                        zbot = MIN(zlhsl,zsurf)
                        pratio = pbot/(pres(i,j,ripk) * 0.01d0)
                        tbotextrap = tk(i,j,ripk)*(pratio)**EXPON
                        ! virtual temperature
                        vt = tbotextrap * (EPS + qvapor)/(EPS*(1.0d0 + qvapor))
                        IF (cvcord .EQ. 'p') THEN
                            plev = vlev
                            zlev = zbot + vt/USSALR*(1. - (vlev/pbot)**EXPON)
                            IF (icase .EQ. 2) THEN
                                tempout(i,j) = zlev
                                !GOTO 333 ! CYCLE
                                CYCLE
                            END IF
                        ELSE IF (cvcord .EQ. 'z') THEN
                            zlev = -sclht*LOG(vlev)
                            plev = pbot*(1. + USSALR/vt*(zbot-zlev))**EXPONI
                            IF (icase .EQ. 1) THEN
                                tempout(i,j) = plev
                                !GOTO 333 ! CYCLE
                                CYCLE
                            END IF
                        END IF
                    END IF !end if for checking above ground
                END IF !for icase gt 0

                IF (icase .GT. 2) THEN !extrapolation for temperature
                    tlev = tlhsl + (zlhsl - zlev)*USSALR
                    qvapor = MAX(qvp(i,j,1),1.e-15)
                    gammam = GAMMA*(1. + GAMMAMD*qvapor)
                    IF (icase .EQ. 3) THEN
                        tempout(i,j) = tlev - CELKEL
                    ELSE IF (icase .EQ. 4) THEN
                        tempout(i,j) = tlev
                    ! Potential temperature - theta
                    ELSE IF (icase .EQ. 5) THEN
                        tempout(i,j) = tlev*(1000.d0/plev)**gammam
                    ! extraolation for equivalent potential temperature
                    ELSE IF (icase .EQ. 6) THEN
                        e = qvapor*plev/(EPS + qvapor)
                        tlcl = TLCLC1/(LOG(tlev**TLCLC2/e) - TLCLC3) + TLCLC4
                        tempout(i,j)=tlev*(1000.d0/plev)**(gammam)*&
                                     EXP((THTECON1/tlcl - THTECON2)*&
                                     qvapor*(1. + THTECON3*qvapor))
                    END IF
                END IF

 !333  CONTINUE

            END DO
        END DO

        ! print *,"----done----",interp_levels(nreqlvs)
        DO j = 1,ns
            DO i = 1,ew
                dataout(i,j,nreqlvs) = tempout(i,j)
            END DO
        END DO

    END DO !end for the nreqlvs

    RETURN

END SUBROUTINE f_vintrp


C**********************************************************************
C
C     Copyright (C) 1992  Roland W. Freund and Noel M. Nachtigal
C     All rights reserved.
C
C     This code is part of a copyrighted package.  For details, see the
C     file "cpyrit.doc" in the top-level directory.
C
C     *****************************************************************
C     ANY USE OF  THIS CODE CONSTITUTES ACCEPTANCE OF  THE TERMS OF THE
C                             COPYRIGHT NOTICE
C     *****************************************************************
C
C**********************************************************************
C
C     This file contains the routine for the TFQMR algorithm.
C
C**********************************************************************
C
      SUBROUTINE DUTFX (NDIM,NLEN,NLIM,VECS,TOL,INFO)
      USE stel_kinds, ONLY: rprec
      IMPLICIT NONE
C
C     Purpose:
C     This subroutine uses the TFQMR (Transpose Free, QMR) algorithm to
C     solve linear systems.
C     It runs the  algorithm to convergence  or until  a user-specified
C     limit on the number of iterations is reached.
C
C     The  code is  set up  to solve  the system  A x = b  with initial
C     guess x_0 = 0.  Here  A x = b  denotes the preconditioned system,
C     and  it  is  connected with the  original system as follows.  Let
C     B y = c be the original unpreconditioned system to be solved, and
C     let y_0 be an arbitrary initial guess for its solution.  Then:
C          A x = b, where  A = M_1^{-1} B M_2^{-1},
C                          x = M_2 (y - y_0), b = M_1^{-1} (c - B y_0).
C     Here M = M_1 M_2 is the preconditioner.
C
C     To recover the final iterate y_n for the original system B y = c
C     from the final iterate x_n for the preconditioned system A x = b,
C     set
C               y_n = y_0 + M_2^{-1} x_n.
C
C     The algorithm was first described in the RIACS Technical Report
C     91.18, `A Transpose-Free  Quasi-Minimal  Residual Algorithm  for
C     Non-Hermitian Linear Systems`, by Roland Freund, September 1991,
C     which subsequently appeared in  SIAM J. Sci. Comput., 14 (1993),
C     pp. 470--482.
C
C     Parameters:
C     For a description of the parameters, see the file "dutfx.doc" in
C     the current directory.
C
C     External routines used:
C     double precision dlamch(ch)
C        LAPACK routine, computes machine-related constants.
C     double precision dnrm2(n,x,incx)
C        BLAS-1 routine, computes the 2-norm of x.
C     subroutine daxpby(n,z,a,x,b,y)
C        Library routine, computes z = a * x + b * y.
C     double precision ddot(n,x,incx,y,incy)
C        BLAS-1 routine, computes y^H * x.
C     subroutine drandn(n,x,seed)
C        Library routine, fills x with random numbers.
C
C     Noel M. Nachtigal
C     April 13, 1993
C
C**********************************************************************
C
      EXTERNAL DLAMCH, DAXPBY, DRANDN, DNRM2, DDOT
      REAL(rprec)  :: DLAMCH, DNRM2, DDOT
C
      INTEGER      :: INFO(4), NDIM, NLEN, NLIM
      REAL(rprec)  :: VECS(NDIM,9)
      REAL(rprec)  :: TOL
C
C     Miscellaneous parameters.
C
      REAL(rprec) DHUN, DONE, DTEN, DZERO
      PARAMETER (DHUN = 1.0D2,DONE = 1.0D0,DTEN = 1.0D1,DZERO = 0.0D0)
C
C     Local variables, permanent.
C
      INTEGER     :: IERR, N, RETLBL=0, TF, TRES, VF
      SAVE        :: IERR, N, RETLBL, TF, TRES, VF
      REAL(rprec) :: ALPHA, BETA, ETA, RHO
      SAVE        :: ALPHA, BETA, ETA, RHO
      REAL(rprec) :: COS1, VAR, R0, RESN, TAU, UCHK, UNRM
      SAVE        :: COS1, VAR, R0, RESN, TAU, UCHK, UNRM
C
C     Local variables, transient.
C
      INTEGER INIT, REVCOM
      REAL(rprec) DTMP
C
C     Initialize some of the permanent variables.
C
C      DATA RETLBL /0/
C
C     Check the reverse communication flag to see where to branch.
C        REVCOM   RETLBL      Comment
C           0        0    first call, go to label 10
C           1       30    returning from AXB, go to label 30
C           1       40    returning from AXB, go to label 40
C           1       60    returning from AXB, go to label 60
C           1       70    returning from AXB, go to label 70
C
      REVCOM  = INFO(2)
      INFO(2) = 0
      IF (REVCOM.EQ.0) THEN
         N = 0
         IF (RETLBL.EQ.0) GO TO 10
      ELSE IF (REVCOM.EQ.1) THEN
         IF (RETLBL.EQ.30) THEN
            GO TO 30
         ELSE IF (RETLBL.EQ.40) THEN
            GO TO 40
         ELSE IF (RETLBL.EQ.60) THEN
            GO TO 60
         ELSE IF (RETLBL.EQ.70) THEN
            GO TO 70
         END IF
      END IF
      IERR = 1
      GO TO 90
C
C     Check whether the inputs are valid.
C
 10   IERR = 0
      IF (NDIM.LT.1)    IERR = 2
      IF (NLEN.LT.1)    IERR = 2
      IF (NLIM.LT.1)    IERR = 2
      IF (NLEN.GT.NDIM) IERR = 2
      IF (IERR.NE.0) GO TO 90
C
C     Extract from INFO the output units TF and VF, the true residual
C     flag TRES, and the left starting vector flag INIT.
C
      VF   = MAX(INFO(1),0)
      INIT = VF / 100000
      VF   = VF - INIT * 100000
      TRES = VF / 10000
      VF   = VF - TRES * 10000
      TF   = VF / 100
      VF   = VF - TF * 100
C
C     Check the convergence tolerance.
C
      IF (TOL.LE.DZERO) TOL = SQRT(DLAMCH('E'))
C
C     Start the trace messages and convergence history.
C
      IF (VF.NE.0) THEN
         WRITE (VF, *) '      N    2N-1     UNRM       RESN'
         WRITE (VF,'(2I8,1P,2E11.4)') 0, 0, DONE, DONE
      ENDIF
      IF (TF.NE.0) THEN
         WRITE (VF, *) '      N    2N-1     UNRM       RESN'
         WRITE (TF,'(2I8,1P,2E11.4)') 0, 0, DONE, DONE
      ENDIF
C
C     Set x_0 = 0 and compute the norm of the initial residual.
C
      CALL DAXPBY (NLEN,VECS(1,5),DONE,VECS(1,2),DZERO,VECS(1,5))
      CALL DAXPBY (NLEN,VECS(1,1),DZERO,VECS(1,1),DZERO,VECS(1,1))
      R0 = DNRM2(NLEN,VECS(1,5),1)
      IF ((TOL.GE.DONE).OR.(R0.EQ.DZERO)) GO TO 90
C
C     Check whether the auxiliary vector must be supplied.
C
      IF (INIT.EQ.0) CALL DRANDN (NLEN,VECS(1,3),1)
C
C     Initialize the variables.
C
      N    = 1
      RESN = DONE
      RHO  = DONE
      VAR  = DZERO
      ETA  = DZERO
      TAU  = R0 * R0
      IERR = 8
      CALL DAXPBY (NLEN,VECS(1,8),DZERO,VECS(1,8),DZERO,VECS(1,8))
      CALL DAXPBY (NLEN,VECS(1,4),DZERO,VECS(1,4),DZERO,VECS(1,4))
      CALL DAXPBY (NLEN,VECS(1,6),DZERO,VECS(1,6),DZERO,VECS(1,6))
C
C     This is one step of the TFQMR algorithm.
C     Compute \beta_{n-1} and \rho_{n-1}.
C
 20   DTMP = DDOT(NLEN,VECS(1,3),1,VECS(1,5),1)
      BETA = DTMP / RHO
      RHO  = DTMP
C
C     Compute y_{2n-1}, v_{n-1}, and A y_{2n-1}.
C
      CALL DAXPBY (NLEN,VECS(1,4),BETA,VECS(1,4),DONE,VECS(1,8))
      CALL DAXPBY (NLEN,VECS(1,6),DONE,VECS(1,5),BETA,VECS(1,6))
C
C     Have the caller carry out AXB, then return here.
C        CALL AXB (VECS(1,6),VECS(1,9))
C
      INFO(2) = 1
      INFO(3) = 6
      INFO(4) = 9
      RETLBL  = 30
      RETURN
 30   CALL DAXPBY (NLEN,VECS(1,4),BETA,VECS(1,4),DONE,VECS(1,9))
C
C     Compute \sigma{n-1} and check for breakdowns.
C
      DTMP = DDOT(NLEN,VECS(1,3),1,VECS(1,4),1)
      IF ((DTMP.EQ.DZERO).OR.(RHO.EQ.DZERO)) THEN
         IERR = 8
         GO TO 90
      END IF
C
C     Compute \alpha_{n-1}, d_{2n-1} and w_{2n}.
C
      ALPHA = RHO / DTMP
      DTMP  = VAR * ETA / ALPHA
      CALL DAXPBY (NLEN,VECS(1,7),DONE,VECS(1,6),DTMP,VECS(1,7))
      CALL DAXPBY (NLEN,VECS(1,5),DONE,VECS(1,5),-ALPHA,VECS(1,9))
C
C     Compute \varepsilon_{2n-1}^2, \eta_{2n-1}^2, c_{2n-1}^2, and
C     \tau_{2n-1}^2.
C
      DTMP = DNRM2(NLEN,VECS(1,5),1)
      DTMP = DTMP * DTMP
      VAR  = DTMP / TAU
      COS1  = DONE / ( DONE + VAR )
      TAU  = DTMP * COS1
      ETA  = ALPHA * COS1
C
C     Compute x_{2n-1} and the upper bound for its residual norm.
C
      CALL DAXPBY (NLEN,VECS(1,1),DONE,VECS(1,1),ETA,VECS(1,7))
C
C     Compute the residual norm upper bound.
C     If the scaled upper bound is within one order of magnitude of the
C     target convergence norm, compute the true residual norm.
C
      UNRM = SQRT((2*N) * TAU) / R0
      UCHK = UNRM
      IF ((TRES.EQ.0).AND.(UNRM/TOL.GT.DTEN)) GO TO 50
C
C     Have the caller carry out AXB, then return here.
C        CALL AXB (VECS(1,1),VECS(1,9))
C
      INFO(2) = 1
      INFO(3) = 1
      INFO(4) = 9
      RETLBL  = 40
      RETURN
 40   CALL DAXPBY (NLEN,VECS(1,9),DONE,VECS(1,2),-DONE,VECS(1,9))
      RESN = DNRM2(NLEN,VECS(1,9),1) / R0
      UCHK = RESN
C
C     Output the trace messages and convergence history.
C
 50   IF (VF.NE.0) WRITE (VF,'(2I8,2E11.4)') N, 2*N-1, UNRM, RESN
      IF (TF.NE.0) WRITE (TF,'(2I8,2E11.4)') N, 2*N-1, UNRM, RESN
C
C     Check for convergence or termination.  Stop if:
C         1. algorithm converged;
C         2. the residual norm upper bound is smaller than the computed
C     residual norm by a factor of at least 100.
C
      IF (RESN.LE.TOL) THEN
         IERR = 0
         GO TO 90
      ELSE IF (UNRM.LT.UCHK/DHUN) THEN
         IERR = 4
         GO TO 90
      END IF
C
C     Compute y_{2n}, A y_{2n}, d_{2n}, and w_{2n+1}.
C
      CALL DAXPBY (NLEN,VECS(1,6),DONE,VECS(1,6),-ALPHA,VECS(1,4))
      DTMP = VAR * COS1
      CALL DAXPBY (NLEN,VECS(1,7),DONE,VECS(1,6),DTMP,VECS(1,7))
C
C     Have the caller carry out AXB, then return here.
C        CALL AXB (VECS(1,6),VECS(1,8))
C
      INFO(2) = 1
      INFO(3) = 6
      INFO(4) = 8
      RETLBL  = 60
      RETURN
 60   CALL DAXPBY (NLEN,VECS(1,5),DONE,VECS(1,5),-ALPHA,VECS(1,8))
C
C     Compute \varepsilon_{2n}^2, \eta_{2n}^2, c_{2n}^2, and
C     \tau_{2n}^2.
C
      DTMP = dnrm2(NLEN,VECS(1,5),1)
      DTMP = DTMP * DTMP
      VAR  = DTMP / TAU
      COS1 = DONE / ( DONE + VAR )
      TAU  = DTMP * COS1
      ETA  = ALPHA * COS1
C
C     Compute x_{2n}.
C
      CALL DAXPBY (NLEN,VECS(1,1),DONE,VECS(1,1),ETA,VECS(1,7))
C
C     Compute the residual norm upper bound.
C     If the scaled upper bound is within one order of magnitude of the
C     target convergence norm, compute the true residual norm.
C
      UNRM = SQRT((2*N+1) * TAU) / R0
      UCHK = UNRM
      IF ((TRES.EQ.0).AND.(UNRM/TOL.GT.DTEN).AND.(N.LT.NLIM)) GO TO 80
C
C     Have the caller carry out AXB, then return here.
C        CALL AXB (VECS(1,1),VECS(1,9))
C
      INFO(2) = 1
      INFO(3) = 1
      INFO(4) = 9
      RETLBL  = 70
      RETURN
 70   CALL DAXPBY (NLEN,VECS(1,9),DONE,VECS(1,2),-DONE,VECS(1,9))
      RESN = DNRM2(NLEN,VECS(1,9),1) / R0
      UCHK = UNRM
C
C     Output the trace messages and convergence history.
C
 80   IF (VF.NE.0) WRITE (VF,'(2I8,2E11.4)') N, 2*N, UNRM, RESN
      IF (TF.NE.0) WRITE (TF,'(2I8,2E11.4)') N, 2*N, UNRM, RESN
C
C     Check for convergence or termination.  Stop if:
C         1. algorithm converged;
C         2. the residual norm upper bound is smaller than the computed
C     residual norm by a factor of at least 100;
C         3. algorithm exceeded the iterations limit.
C
      IF (RESN.LE.TOL) THEN
         IERR = 0
         GO TO 90
      ELSE IF (UNRM.LT.UCHK/DHUN) THEN
         IERR = 4
         GO TO 90
      ELSE IF (N.GE.NLIM) THEN
         IERR = 4
         GO TO 90
      END IF
C
C     Update the running counter.
C
      N = N + 1
      GO TO 20
C
C     Done.
C
 90   NLIM    = N
      RETLBL  = 0
      INFO(1) = IERR
C
      RETURN
      END
C
C**********************************************************************