!###################################################################################
!
! CPMlib - Computational space Partitioning Management library
!
! Copyright (c) 2012-2014 Institute of Industrial Science (IIS), The University of Tokyo.
! All rights reserved.
!
! Copyright (c) 2014-2016 Advanced Institute for Computational Science (AICS), RIKEN.
! All rights reserved.
!
! Copyright (c) 2016-2017 Research Institute for Information Technology (RIIT), Kyushu University.
! All rights reserved.
!
!###################################################################################

!   *********************************************************
!   ***      Sample code of porting
!   ***      2010 keno@VCAD, RIKEN
!
!   *********************************************************
    module array_def
    real, dimension(:,:,:), allocatable, save :: p, q, w
    end module array_def

!   *********************************************************
    program diffusion

    use array_def
    implicit none
    integer       :: nx, ny, nz
    integer       :: n, scheme, itrMax, stp, stpMax
    real          :: dx, dy, dz
    real          :: eps, er, omg, dt, cf

!   Initialize
    write (*,*) 'Dimension size'
    write (*,*) 'Input dimension x size ='
    read  (*,*)  nx
    write (*,*) 'Input dimension y size ='
    read  (*,*)  ny
    write (*,*) 'Input dimension z size ='
    read  (*,*)  nz

    write (*,*) 'SELECT time integration method'
    write (*,*) '        1 --- Euler Explicit'
    write (*,*) '        2 --- Euler Implicit'
    read  (*,*) scheme

    write (*,*) 'Time step max='
    read  (*,*) stpMax

    write (*,*) 'Time increment='
    read  (*,*) dt

    write (*,*) 'Coef. of diffusion='
    read  (*,*) cf

    if ( scheme == 2 ) then
      write (*,*) 'Iteration max='
      read  (*,*) itrMax
      write (*,*) 'Epsilon ='
      read  (*,*) eps
      write (*,*) 'Relazation coef. ='
      read  (*,*) omg
    end if

    dx = 1.0/real(nx)
    dy = 1.0/real(ny)
    dz = 1.0/real(nz)

    write (*,*) 'nx, ny, nz = ', nx, ny, nz
    write (*,*) 'dx, dy, dz = ', dx, dy, dz
    write (*,*) 'dt         = ', dt
    if ( scheme == 1 ) then
      write(*,*) 'Euler Explicit ftcs'
    else
      write(*,*) 'Euler Implicit jacobi'
    end if

    call allocate_array (nx, ny, nz)
    call pbc (nx, ny, nz, p, dx, dy, dz)

!   time step loop
    do stp=1, stpMax
      if ( scheme == 1 ) then
        call ftcs (nx, ny, nz, p, q, cf, dx, dy, dz, dt, er)
        call pbc (nx, ny, nz, p, dx, dy, dz)
        write (*,*) stp, er
      else
        er = 0.0
        w(0:nx+1, 0:ny+1, 0:nz+1) = p(0:nx+1, 0:ny+1, 0:nz+1)
        ! iteration
        do n=1, itrMax
          call jacobi (nx, ny, nz, p, q, w, cf, dx, dy, dz, dt, omg, er)
          call pbc (nx, ny, nz, p, dx, dy, dz)
          if (er<eps) exit
        end do
        write (*,*) stp, n, er
      end if
    end do

!   Post
    call fileout (nx, ny, nz, p, w, dx, dy, dz)

    stop
    end program diffusion

!   ******************************
    subroutine allocate_array (nx, ny, nz)
    use array_def
    implicit none
    integer :: status
    integer :: nx, ny, nz

    allocate ( p(0:nx+1, 0:ny+1, 0:nz+1) , stat=status )
    allocate ( w(0:nx+1, 0:ny+1, 0:nz+1) , stat=status )
    allocate ( q(0:nx+1, 0:ny+1, 0:nz+1) , stat=status )
    p(0:nx+1, 0:ny+1, 0:nz+1) = 0.d0

    return
    end subroutine allocate_array

!   ****************************************************
    subroutine jacobi (nx, ny, nz, p, q, w, cf, dx, dy, dz, dt, omg, er)
    implicit none
    integer                                 :: nx, ny, nz
    real, dimension (0:nx+1,0:ny+1,0:nz+1)  :: p, q, w
    real                                    :: cf, dx, dy, dz, dt, omg, er

    integer                                 :: i, j, k
    real                                    :: ddx, ddy, ddz, cpd
    real                                    :: s0, ss, sx, sy, sz

    er = 0.0
    ddx = cf*dt/(dx*dx)
    ddy = cf*dt/(dy*dy)
    ddz = cf*dt/(dz*dz)
    cpd=1.0/(1.0+2.0*ddx+2.0*ddy+2.0*ddz)

    do k=1,nz
    do j=1,ny
    do i=1,nx
      sx= p(i+1,j  ,k  ) + p(i-1,j  ,k  )
      sy= p(i  ,j+1,k  ) + p(i  ,j-1,k  )
      sz= p(i  ,j  ,k+1) + p(i  ,j  ,k-1)
      s0=ddx*sx+ddy*sy+ddz*sz
      ss=(cpd*(s0+w(i,j,k))-p(i,j,k))*omg
      q(i,j,k)=p(i,j,k)+ss
      er = er + ss*ss
    end do
    end do
    end do

    p(1:nx, 1:ny, 1:nz) = q(1:nx, 1:ny, 1:nz)
    er = sqrt(er)

    return
    end subroutine jacobi

!   ***************************************
    subroutine ftcs (nx, ny, nz, p, q, cf, dx, dy, dz, dt, er)
    implicit none

    integer                                 :: nx, ny, nz
    real, dimension (0:nx+1,0:ny+1,0:nz+1)  :: p, q
    real                                    :: cf, dx, dy, dz, dt, er

    integer                                 :: i, j, k
    real                                    :: ddx, ddy, ddz
    real                                    :: ss, sx, sy, sz

    er = 0.0
    ddx=cf*dt/(dx*dx)
    ddy=cf*dt/(dy*dy)
    ddz=cf*dt/(dz*dz)

    do k=1,nz
    do j=1,ny
    do i=1,nx
      sx= p(i+1,j  ,k  ) + p(i-1,j  ,k  ) &
        - p(i  ,j  ,k  )*2.0
      sy= p(i  ,j+1,k  ) + p(i  ,j-1,k  ) &
        - p(i  ,j  ,k  )*2.0
      sz= p(i  ,j  ,k+1) + p(i  ,j  ,k-1) &
        - p(i  ,j  ,k  )*2.0
      ss=ddx*sx+ddy*sy+ddz*sz
      q(i,j,k)=p(i,j,k)+ss
      er = er + ss*ss
    end do
    end do
    end do

    p(1:nx, 1:ny, 1:nz) = q(1:nx, 1:ny, 1:nz)

    er = sqrt(er)

    return
    end subroutine ftcs

!   **************************
    subroutine pbc (nx, ny, nz, p, dx, dy, dz)
    implicit none
    integer                               :: nx, ny, nz
    real, dimension(0:nx+1,0:ny+1,0:nz+1) :: p
    real                                  :: dx, dy, dz

    integer                               :: i, j, k
    real                                  :: pi, x, y

    pi = 2.0*asin(1.0)

    do j=1,ny
    do i=1,nx
      x= dx*(i-1)+dx*0.5
      y= dy*(j-1)+dy*0.5
      p(i,j,0)   =2.0*sin(pi*x)*sin(pi*y)-p(i,j,1)
      p(i,j,nz+1)=2.0*sin(pi*x)*sin(pi*y)-p(i,j,nz)
    end do
    end do

    do k=1,nz
    do j=1,ny
      p(0,   j,k) = p(1, j,k)
      p(nx+1,j,k) = p(nx,j,k)
    end do
    end do

    do k=1,nz
    do i=1,nx
      p(i,0,   k) = p(i,1, k)
      p(i,ny+1,k) = p(i,ny,k)
    end do
    end do

    return
    end subroutine pbc

!   ******************************
    subroutine fileout (nx, ny, nz, p, w, dx, dy, dz)
    implicit none
    integer                                 :: nx, ny, nz
    real  , dimension(0:nx+1,0:ny+1,0:nz+1) :: p
    real*4, dimension(0:nx+1,0:ny+1,0:nz+1) :: w
    real                                    :: dx, dy, dz

    integer                                 :: i,j,k
    integer                                 :: step
    real*4                                  :: org(3), pch(3), time
    character*256                           :: ename

!kero left lower coner of cell(1,1,1) is defined as an original point O(0.0, 0.0, 0.0)
!kero the original point is modified according to the above defined point

    ename='e.sph'

    step = 0
    time = 0.0
    pch(1) = real(dx)
    pch(2) = real(dy)
    pch(3) = real(dz)
    org    = -pch
    do k=0,nz+1
    do j=0,ny+1
    do i=0,nx+1
      w(i,j,k) = real(p(i,j,k))
    enddo
    enddo
    enddo

    open (unit=22,file=ename,form='unformatted')
    write (22) 1, 1
    write (22) nx+2,ny+2,nz+2
    write (22) org
    write (22) pch
    write (22) step, time
    write (22) w
    close (unit=22)

    return
    end subroutine fileout


      subroutine set_invarients(nfinal,ninvar)
c***************************************************************************
c     Calculates all of the invarients for a 2->n process
c***************************************************************************
      implicit none
c
c     Constants
c
      include 'genps.inc'
c
c     Arguments
c
      integer nfinal,ninvar
c
c     Local
c
      integer ip1,ip2,ipstart,ipstop,np,i
      integer ncycle
      character*10 buff
c
c     Global
c
      integer              imom(maxinvar),ninvarients
      common/to_invarients/imom          ,ninvarients
c-----
c  Begin Code
c-----

      do i=1,nfinal
         imom(i)=i
      enddo
      ipstart=1
      ipstop =nfinal
      np     =nfinal
c
c     First do all the s-channel
c
      do ncycle=2,nfinal-1
         do ip1 = ipstart,ipstop-1
            do ip2=int((real(imom(ip1))/10.-imom(ip1)/10)*10+.1)+1,
     $           nfinal
               np=np+1
               if (np .gt. maxinvar) then
                  print*,'Sorry too many invarients',np,ip1,ip2,ncycle
                  stop
               endif
               imom(np)=imom(ip1)*10+imom(ip2)
               if (imom(np) .lt. 10) then
                  write(buff,'(a2,i1)') 'S?',imom(np)
               elseif (imom(np) .lt. 100) then
                  write(buff,'(a2,i2)') 'S?',imom(np)
               elseif (imom(np) .lt. 1000) then
                  write(buff,'(a2,i3)') 'S?',imom(np)
               elseif (imom(np) .lt. 10000) then
                  write(buff,'(a2,i4)') 'S?',imom(np)
               elseif (imom(np) .lt. 100000) then
                  write(buff,'(a2,i5)') 'S?',imom(np)
               else
                  write(buff,'(a2,i6)') 'S?',imom(ip1)
               endif
c               call hbook1(100+np-nfinal,buff,100,0.,1.,0.)
c               write(*,'(i4,i6)') np-nfinal,imom(np)
               write(*,'(i4,a1,a6)') np-nfinal,'=',buff
               if ((np-nfinal)/7 .eq. real(np-nfinal)/7.) write(*,*)' '
            enddo
         enddo
         ipstart=ipstop+1
         ipstop = np
      enddo
c
c     Now do the t-channel
c
      ipstop = np
      do ip1 = 1,ipstop
c         write(*,'(i4,a2,i6)') np-nfinal+ip1,'a-',imom(ip1)
         if (imom(ip1) .lt. 10) then
            write(buff,'(a2,i1)') 'T?',imom(ip1)
         elseif (imom(ip1) .lt. 100) then
            write(buff,'(a2,i2)') 'T?',imom(ip1)
         elseif (imom(ip1) .lt. 1000) then
            write(buff,'(a2,i3)') 'T?',imom(ip1)
         elseif (imom(ip1) .lt. 10000) then
            write(buff,'(a2,i4)') 'T?',imom(ip1)
         elseif (imom(ip1) .lt. 100000) then
            write(buff,'(a2,i5)') 'T?',imom(ip1)
         else
            write(buff,'(a2,i6)') 'T?',imom(ip1)
         endif
c         call hbook1(100+np-nfinal+ip1,buff,100,0.,1.,0.)
c         write(*,*) np-nfinal+ip1,buff
         write(*,'(i4,a1,a6)') np-nfinal+ip1,'=',buff
         if ((np-nfinal+ip1)/7 .eq. real(np-nfinal+ip1)/7.) write(*,*)
      enddo
      write(*,*)
      print*,'Particles, Invarients',nfinal,np-nfinal+np
      ninvarients=np-nfinal+np
      ninvar=ninvarients
      if (ninvarients .gt. maxinvar) then
         print*,'Error too many invarients to map'
c         stop
      endif
      end

      subroutine fill_invarients(nfinal,p1,s,xx)
c***************************************************************************
c     Calculates all of the invarients for a 2->n process
c***************************************************************************
      implicit none
c
c     Constants
c
      include 'genps.inc'
c
c     Arguments
c
      integer nfinal
      double precision p1(0:3,nfinal+2),s,xx(55)
c
c     Local
c
      integer ip1,ip2,ipstart,ipstop,np,i,j
      integer imom(maxinvar)
      integer ncycle
      character*10 buff
      double precision p(0:3,maxinvar),ptemp(0:3)
c
c     External
c
      double precision dot
      external         dot
c-----
c  Begin Code
c-----

      do i=1,nfinal
         imom(i) = i
         do j=0,3
            p(j,i)=p1(j,i+2)
         enddo
c         write(*,'(i3,4f17.8)') i,(p(j,i),j=0,3)
      enddo
      ipstart=1
      ipstop =nfinal
      np     =nfinal
c
c     First do all the s-channel
c
      do ncycle=2,nfinal-1
         do ip1 = ipstart,ipstop-1
            do ip2=int((real(imom(ip1))/10.-imom(ip1)/10)*10+.1)+1
     $           ,nfinal
               np=np+1
               if (np .gt. maxinvar) then
                  print*,'Sorry too many invarients',np,ip1,ip2,ncycle
                  stop
               endif
               imom(np)=imom(ip1)*10+imom(ip2)
               do j=0,3
                  p(j,np) = p(j,ip1)+p(j,ip2)
               enddo
               xx(np-nfinal) = dot(p(0,np),p(0,np))/s
c               call hfill(100+np-nfinal,
c     &              real(dot(p(0,np),p(0,np))/s),0.,wgt)
c               write(*,'(i4,3f20.8)') np-nfinal,
c     &              real(dot(p(0,np),p(0,np))/s)
            enddo
         enddo
         ipstart=ipstop+1
         ipstop = np
      enddo
c
c     Now do the t-channel
c
      ipstop = np
      do ip1 = 1,ipstop
         do j = 0,3
            ptemp(j)=p1(j,1)-p(j,ip1)
         enddo
         xx(np-nfinal+ip1)= .5d0*(dot(ptemp,ptemp)/s+1d0)
c         call hfill(100+np-nfinal+ip1,real(-dot(ptemp,ptemp)/s),0.,wgt)
c         write(*,'(i4,3f20.8)') np-nfinal+ip1,
c     &         real(-dot(ptemp,ptemp)/s)
      enddo
      end

      subroutine map_invarients(Minvar,nconfigs,ninvar,mincfig,maxcfig,nexternal,nincoming,nb_tchannel)
c****************************************************************************
c     Determines mappings for each structure of invarients onto integration
c     variables.  Input: Ninvar, iforest.  Output: Minvar, ninvar, nb_tchannel
c****************************************************************************
      implicit none
c
c     Constants
c
      include 'genps.inc'
      include 'maxconfigs.inc'
c
c     Arguments
c
      integer Minvar(maxdim,lmaxconfigs),nconfigs,ninvar,nexternal,nincoming
      integer mincfig,maxcfig
      integer nb_tchannel
c
c     Local
c
      integer iconfig, jgrid,j, nbranch
      logical found,tchannel
      integer ns_channel
c
c     Global
c
      integer              imom(maxinvar),ninvarients
      common/to_invarients/imom          ,ninvarients
      integer iforest(2,-max_branch:-1,lmaxconfigs)
      common/to_forest/ iforest

c-----
c  Begin Code
c----

      nbranch = nexternal-2
      jgrid=0
c
c
c     Try simple mapping if nconfigs = 1
c
      nb_tchannel = 0
      if (nconfigs .eq. 1) then
c         do j=1,3*nbranch-4+2
         do j=1,maxdim
            minvar(j,mincfig)=j
         enddo
         jgrid=j-1

         write(*,*) 'Determine nb_t'
         ns_channel=1
         do while((iforest(1,-ns_channel,mincfig) .ne. 1.and.iforest(1,-ns_channel,mincfig) .ne. 2).and.ns_channel.lt.nbranch)
            ns_channel=ns_channel+1
         enddo
         ns_channel=ns_channel - 1
         nb_tchannel=nbranch-ns_channel-1
         write(*,*) 'T-channel found: ',nb_tchannel

      else
c      if (ep) jgrid=1
c      if (pp) jgrid=2
      do iconfig=mincfig,maxcfig
         tchannel = .false.
         do j=1,nbranch-1
            if (iforest(1,-j,iconfig) .eq. 1.or.(nincoming.eq.2.and.iforest(1,-j,iconfig) .eq. 2)) then
               tchannel=.true.
            endif
            jgrid=jgrid+1
            minvar(j,iconfig) = jgrid
            if (tchannel .and. j .lt. nbranch-1) then
               jgrid=jgrid+1
               minvar(nbranch-1+2*j,iconfig)=jgrid
            endif
         enddo             !Each Branch
         if (.not. tchannel .and. nincoming.eq.2) then          !Don't need last s-channel
            jgrid=jgrid-1
            minvar(nbranch-1,iconfig)=0
         endif
c         if (pp) then
c            jgrid=jgrid+1
c            minvar(3*nbranch-3,iconfig)=jgrid
c            jgrid=jgrid+1
c            minvar(3*nbranch-2,iconfig)=jgrid
c         elseif (ep) then
c            jgrid=jgrid+1
c            minvar(3*nbranch-3,iconfig)=jgrid
c         endif
      enddo  !Each configurations
      endif
      ninvar = jgrid
      end

      subroutine sortint(n,ra)
      integer ra(n)
      l=n/2+1
      ir=n
10    continue
        if(l.gt.1)then
          l=l-1
          rra=ra(l)
        else
          rra=ra(ir)
          ra(ir)=ra(1)
          ir=ir-1
          if(ir.eq.1)then
            ra(1)=rra
            return
          endif
        endif
        i=l
        j=l+l
20      if(j.le.ir)then
          if(j.lt.ir)then
            if(ra(j).lt.ra(j+1))j=j+1
          endif
          if(rra.lt.ra(j))then
            ra(i)=ra(j)
            i=j
            j=j+j
          else
            j=ir+1
          endif
        go to 20
        endif
        ra(i)=rra
      go to 10
      end


program variableTesting
    implicit none

    integer :: total
    real :: avg
    complex :: cx
    logical :: done
    character(len=80) :: message

    total=20000
    avg=166.67
    done=.true.
    message="Hello"
    cx=(3.0,5.0)
    !intrinsic function to assign values to complex variable
    cx=cmplx(1.0/2.0,-7.0)

    print *,total,avg,done,message,cx

end program


module queen_attack
  implicit none
contains

  logical function isValid(pos)
    integer, dimension(2) :: pos
    ! check if valid
    isValid = all(pos(:) > 0) .and. all(pos(:) < 9)
  end function

  logical function canAttack(white_pos, black_pos)
    integer, dimension(2) :: white_pos, black_pos, dx
    canAttack = .false.
    if (isValid(white_pos) .and. isValid(black_pos)) then
      dx = abs(white_pos(:) - black_pos(:))
      canAttack = dx(1)==0 & ! same row
        & .or. dx(2)==0 & ! same column
        & .or. dx(1)==dx(2) ! on diagonal
    endif
  end function

end module


      SUBROUTINE sfp2fp( ibuf, n, obuf )
!     UTIG short FP, NOT IEEE
!     sfp2fp converts "short floating point" data to internal floating
!  point (REAL).  Short floating point is a 16 bit word, the sign bit,
!  followed by 11 bits of 2's complement mantissa, followed by 4 bits
!  of exponent expressed as 2**(15-exp).
!     This format was first brought to my attention by UTIG.
!
!  ARGUMENTS:
!  ibuf - the input array of 16 bit "floating point" words.
!  n    - The number of data samples to convert.
!  obuf - The output REAL array.
!
! COPYRIGHT (C) Paul Henkart, Seismic Reflection Processors, 22 Mar 1990
!  ALL RIGHTS RESERVED.
!  mod 14 Aug 07 - g95 IAND args must be same size.
!
      INTEGER n, rshift
      INTEGER*2 ibuf(n), ib, i15
      REAL obuf(n)
      INTEGER itemp
      REAL gain(0:15)
      DATA i15/15/
      DATA gain/ 32768, 16384, 8192, 4096, 2048, 1024, 512, 256,
     &           128, 64, 32, 16, 8, 4, 2, 1 /
!
      DO 100 i = 1, n
         ib = ibuf(i)
         jsign = 0
         IF( ib .LT. 0 ) jsign = 1                                      ! the sign bit
!         mant = IAND( ib, 32752 )   ! the 11 bit mantissa - 32752 = 7FF0
         jexp = IAND( ib, i15 )      ! the 4 bit exponent
	 mant = ib
         itemp1 = RSHIFT(mant,4)
         itemp = IAND( itemp1, 2047 )  ! 2047 = 7FF
         IF( jsign .EQ. 1 ) THEN       ! 1 means a negative
	   itemp = IOR( itemp, NOT(2047) )
         ENDIF
         obuf(i) = FLOAT(itemp) * gain(jexp)
  100 CONTINUE
      RETURN
      END


      subroutine quf(n, alpha1, alpha2, x)

      integer i
      integer n
      double precision x(n)
      double precision alpha1, alpha2

      external rndstart, rndend
      double precision myrbeta
      external myrbeta

      call rndstart()
      do 10 i = 1, n
          x(i) = myrbeta(alpha1, alpha2)
   10 continue
      call rndend()

      end


\ Tools -- Formatted unsigned single hex number output, not using BASE
\ an-17jan2022

decimal
: .1HX ( x -- )     \ Print last digit of x in hex
    15 and                  \ lowest nibble
    9 over < 7 and +        \ for A..F
    [char] 0 +   emit ;

: .NHX ( x n -- )   \ Print last n digits of x in hex
    1 max 16 min >r                 \ x r: n
    r@ 1 ?do dup 4 rshift loop      \ collect on data stack
    r> 0 do .1hx loop space ;
\ ----- end of code -----

(*
Examples
decimal
19150 2 .nhx     \ CE
19150 3 .nhx     \ ACE
19150 4 .nhx     \ 4ACE
19150 8 .nhx     \ 00004ACE

\ .NHX version without DO-LOOP
: .NHX ( x n -- )   \ Print last n digits of x in hex
    swap >r   1 max 16 min dup          \ n n r: x
    begin 1- dup while r@ 4 rshift >r   \ collect on return stack
    repeat drop
    begin r> .1hx   1- dup 0= until drop space ;
*)
\ <><>


program int_example
    implicit none

    integer,parameter :: nmax = 1000000
    integer :: npts, nerr
    real*4 :: data(nmax)
    real*4 :: beg, dt

    integer sac_compare

    ! Read in the data file
    call rsac1('raw.sac', data, npts, beg, dt, nmax, nerr)

    call int_trap(data, npts, dble(dt))

    ! write the seismogram with trend removed back to disk
    call wsac0('int.sac', data, data, nerr)

    if(sac_compare('int_sac.sac', data, npts-1, beg + 0.5 * dt, dt) .ne. 1) then
       write(*,*)'data does not match file'
    endif

end program int_example


program t
  integer :: i, j

  L1: do i = 1, 10
    L2: do j = 1, 10
      if (i + j < 10 ) cycle L1
      print *, i, j
    end do L2
  end do L1

end program t


      DOUBLE PRECISION FUNCTION devlpl(a,n,x)
C**********************************************************************
C
C     DOUBLE PRECISION FUNCTION DEVLPL(A,N,X)
C              Double precision EVALuate a PoLynomial at X
C
C
C                              Function
C
C
C     returns
C          A(1) + A(2)*X + ... + A(N)*X**(N-1)
C
C
C                              Arguments
C
C
C     A --> Array of coefficients of the polynomial.
C                                        A is DOUBLE PRECISION(N)
C
C     N --> Length of A, also degree of polynomial - 1.
C                                        N is INTEGER
C
C     X --> Point at which the polynomial is to be evaluated.
C                                        X is DOUBLE PRECISION
C
C**********************************************************************
C
C     .. Scalar Arguments ..
      DOUBLE PRECISION x
      INTEGER n
C     ..
C     .. Array Arguments ..
      DOUBLE PRECISION a(n)
C     ..
C     .. Local Scalars ..
      DOUBLE PRECISION term
      INTEGER i
C     ..
C     .. Executable Statements ..
      term = a(n)
      DO 10,i = n - 1,1,-1
          term = a(i) + term*x
   10 CONTINUE
      devlpl = term
      RETURN

      END


!-------------------------------------------------------------------------------
!   This is a Fortran translation of the 64-bit version of
!   the Mersenne Twister pseudorandom number generator
!
!   Before using, initialize the state by using
!       call init_genrand64(seed)
!   or
!       call init_by_array64(init_key)
!
!   Translated from C-program for MT19937-64 (2004/9/29 version)
!   originally coded by Takuji Nishimura and Makoto Matsumoto
!   http://www.math.sci.hiroshima-u.ac.jp/~m-mat/MT/emt64.html
!
!   Fortran translation by Rémi Piatek
!   The University of Copenhagen
!   Department of Economics
!   email: {first}.{last}@econ.ku.dk
!
!-------------------------------------------------------------------------------
!   A C-program for MT19937-64 (2004/9/29 version).
!   Coded by Takuji Nishimura and Makoto Matsumoto.
!
!   This is a 64-bit version of Mersenne Twister pseudorandom number
!   generator.
!
!   Before using, initialize the state by using init_genrand64(seed)
!   or init_by_array64(init_key, key_length).
!
!   Copyright (C) 2004, Makoto Matsumoto and Takuji Nishimura,
!   All rights reserved.
!
!   Redistribution and use in source and binary forms, with or without
!   modification, are permitted provided that the following conditions
!   are met:
!
!     1. Redistributions of source code must retain the above copyright
!        notice, this list of conditions and the following disclaimer.
!
!     2. Redistributions in binary form must reproduce the above copyright
!        notice, this list of conditions and the following disclaimer in the
!        documentation and/or other materials provided with the distribution.
!
!     3. The names of its contributors may not be used to endorse or promote
!        products derived from this software without specific prior written
!        permission.
!
!   THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
!   "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
!   LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
!   A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER
!   OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
!   EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
!   PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
!   PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
!   LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
!   NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
!   SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
!
!   References:
!   T. Nishimura, ``Tables of 64-bit Mersenne Twisters''
!     ACM Transactions on Modeling and
!     Computer Simulation 10. (2000) 348--357.
!   M. Matsumoto and T. Nishimura,
!     ``Mersenne Twister: a 623-dimensionally equidistributed
!       uniform pseudorandom number generator''
!     ACM Transactions on Modeling and
!     Computer Simulation 8. (Jan. 1998) 3--30.
!
!   Any feedback is very welcome.
!   http://www.math.hiroshima-u.ac.jp/~m-mat/MT/emt.html
!   email: m-mat @ math.sci.hiroshima-u.ac.jp (remove spaces)
!-------------------------------------------------------------------------------

module mt_mod

  use, intrinsic :: iso_fortran_env
  implicit none

  private
  public :: init_genrand64
  public :: init_by_array64
  public :: genrand64_real1
  public :: genrand64_real2
  public :: genrand64_real3

! NOTE: genrand64_int64 is kept private, as it generates different numbers
!       compared to the original C code. This is because the original C code
!       uses unsigned integers, while Fortran relies on signed integers.
!       This, however, has no impact on the generation of real numbers
!       (they are identical to those produced by the original C code).
! public :: genrand64_int64

  integer, parameter :: r8 = real64
  integer, parameter :: i8 = int64

  integer(i8), parameter :: nn       = 312_i8
  integer(i8), parameter :: mm       = 156_i8
  integer(i8), parameter :: seed_def = 5489_i8
  integer(i8), parameter :: matrix_a = -5403634167711393303_i8
  integer(i8), parameter :: um       = -2147483648_i8 ! most significant 33 bits
  integer(i8), parameter :: lm       =  2147483647_i8 ! least significant 31 bits

  real(r8),    parameter :: pi253_1  = 1._r8/(2._r8**53 - 1._r8)
  real(r8),    parameter :: pi253    = 1._r8/(2._r8**53)
  real(r8),    parameter :: pi252    = 1._r8/(2._r8**52)

  integer(i8) :: mt(nn)       ! array for the state vector
  integer     :: mti = nn+1   ! mti==nn+1 means mt(nn) is not initialized

contains

  !-----------------------------------------------------------------------------
  ! Initializes mt(nn) with a seed

  subroutine init_genrand64(seed)
    implicit none
    integer(i8), intent(in) :: seed
    integer :: i

    mt(1) = seed
    do i = 1, nn-1
      mt(i+1) = 6364136223846793005_i8 * ieor(mt(i), ishft(mt(i), -62)) + i
    end do

    mti = nn

  end subroutine init_genrand64

  !-----------------------------------------------------------------------------
  ! Initializes by an array with array-length
  !   init_key is the array for initializing keys

  subroutine init_by_array64(init_key)
    implicit none
    integer(i8), intent(in) :: init_key(:)
    integer(i8), parameter  :: c1 = 3935559000370003845_i8
    integer(i8), parameter  :: c2 = 2862933555777941757_i8
    integer(i8) :: i, j, k, kk, key_length

    call init_genrand64(19650218_i8)
    key_length = size(init_key)
    i = 1_i8; j = 0_i8
    k = max(nn, key_length)

    do kk = 1, k
      mt(i+1) = ieor(mt(i+1), c1 * ieor(mt(i), ishft(mt(i), -62))) &
                  + init_key(j+1) + j
      i = i+1; j = j+1
      if(i >= nn) then
        mt(1) = mt(nn)
        i = 1
      end if
      if(j >= key_length) j = 0
    end do

    do kk = 1, nn-1
      mt(i+1) = ieor(mt(i+1), c2 * ieor(mt(i), ishft(mt(i), -62))) - i
      i = i+1
      if(i >= nn) then
        mt(1) = mt(nn)
        i = 1
      end if
    end do

    mt(1) = ishft(1_i8, 63)  ! MSB is 1; assuring non-zero initial array

  end subroutine init_by_array64

  !-----------------------------------------------------------------------------
  ! Generates a random number on [-2^63, 2^63-1]-interval

  integer(r8) function genrand64_int64()
    implicit none
    integer(i8) :: mag01(0:1) = (/0_i8, matrix_a/)
    integer(i8) :: x
    integer     :: i

    if(mti >= nn) then ! generate nn words at one time

      ! if init_genrand64() has not been called, a default initial seed is used
      if(mti == nn+1) call init_genrand64(seed_def)

      do i = 1, nn-mm
        x = ior(iand(mt(i),um), iand(mt(i+1), lm))
        mt(i) = ieor(ieor(mt(i+mm), ishft(x, -1)), mag01(iand(x, 1_i8)))
      end do

      do i = nn-mm+1, nn-1
        x = ior(iand(mt(i), um), iand(mt(i+1), lm))
        mt(i) = ieor(ieor(mt(i+mm-nn), ishft(x, -1)), mag01(iand(x, 1_i8)))
      end do

      x = ior(iand(mt(nn), um), iand(mt(1), lm))
      mt(nn) = ieor(ieor(mt(mm), ishft(x, -1)), mag01(iand(x, 1_i8)))

      mti = 0

    end if

    mti = mti + 1
    x = mt(mti)

    x = ieor(x, iand(ishft(x,-29), 6148914691236517205_i8))
    x = ieor(x, iand(ishft(x, 17), 8202884508482404352_i8))
    x = ieor(x, iand(ishft(x, 37),   -2270628950310912_i8))
    x = ieor(x, ishft(x, -43))

    genrand64_int64 = x

  end function genrand64_int64

  !-----------------------------------------------------------------------------
  ! Generates a random number on [0,1]-real-interval

  real(r8) function genrand64_real1()
    implicit none

    genrand64_real1 = real(ishft(genrand64_int64(), -11), kind=r8) * pi253_1

  end function genrand64_real1

  !-----------------------------------------------------------------------------
  ! Generates a random number on [0,1)-real-interval

  real(r8) function genrand64_real2()
    implicit none

    genrand64_real2 = real(ishft(genrand64_int64(), -11), kind=r8) * pi253

  end function genrand64_real2

  !-----------------------------------------------------------------------------
  ! Generates a random number on (0,1)-real-interval

  real(r8) function genrand64_real3()
    implicit none

    genrand64_real3 = real(ishft(genrand64_int64(), -12), kind=r8)
    genrand64_real3 = (genrand64_real3 + 0.5_r8) * pi252

  end function genrand64_real3

end module mt_mod


module advance_module

  use multifab_module
  use ml_layout_module
  use define_bc_module
  use bc_module
  use multifab_physbc_module
  use multifab_fill_ghost_module
  use ml_cc_restriction_module
  use bndry_reg_module
  use compute_flux_module
  use update_phi_module

  implicit none

  private

  public :: advance

contains

  subroutine advance(mla,phi_old,phi_new,bndry_flx,dx,dt,the_bc_tower,do_subcycling,num_substeps)

    type(ml_layout), intent(in   ) :: mla
    type(multifab) , intent(inout) :: phi_old(:)
    type(multifab) , intent(inout) :: phi_new(:)
    type(bndry_reg), intent(inout) :: bndry_flx(2:)
    real(kind=dp_t), intent(in   ) :: dx(:)
    real(kind=dp_t), intent(in   ) :: dt(:)
    type(bc_tower) , intent(in   ) :: the_bc_tower
    logical        , intent(in   ) :: do_subcycling
    integer        , intent(in   ) :: num_substeps

    ! local variables
    integer   :: i,istep,dm,n,nlevs,ng_p
    ! Array of edge-based multifabs; one for each direction
    type(multifab) :: flux(mla%dim,mla%nlevel)

    dm    = mla%dim
    nlevs = mla%nlevel
    ng_p = phi_new(1)%ng

    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!
    ! Explicit time advancement
    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!

    if (do_subcycling) then

          !!!!!!!!!!!!!!!!!!!!!!!!!!!!!
          ! subcycling in time
          !!!!!!!!!!!!!!!!!!!!!!!!!!!!!

          n = 1
          istep = 1
          ! note that update_level is recursive
          call update_level(n,mla,phi_old,phi_new,bndry_flx,&
               dx,dt,the_bc_tower,istep,num_substeps)

    else

          !!!!!!!!!!!!!!!!!!!!!!!!!!!!!
          ! no subcycling in time
          !!!!!!!!!!!!!!!!!!!!!!!!!!!!!

          ! flux(i,n) has one component, zero ghost cells, and is nodal in direction i,
          !    i.e. it lives on the i-edges.
          do n = 1,nlevs
             do i = 1, dm
                call multifab_build_edge(flux(i,n),mla%la(n),1,0,i)
             end do
          end do

          ! Copy phi_new from the previous time step into phi_old for this time step
          do n = 1, nlevs
             call multifab_copy(mdst=phi_old(n),msrc=phi_new(n),ng=ng_p)
          end do

          ! Compute the face-centered gradients in each direction
          call compute_flux(mla,phi_old,flux,dx,dt,the_bc_tower)

          ! update phi using forward Euler discretization
          call update_phi(mla,phi_old,phi_new,flux,dx,dt,the_bc_tower)

          do n = 1,nlevs
             do i = 1, dm
                call multifab_destroy(flux(i,n))
             end do
          end do

    end if

  end subroutine advance

  recursive subroutine update_level(n,mla,phi_old,phi_new,bndry_flx,&
                                    dx,dt,the_bc_tower,step,num_substeps)

    type(ml_layout), intent(in   ) :: mla
    type(multifab) , intent(inout) :: phi_old(:)
    type(multifab) , intent(inout) :: phi_new(:)
    type(bndry_reg), intent(inout) :: bndry_flx(2:)
    real(kind=dp_t), intent(in   ) :: dx(:)
    real(kind=dp_t), intent(in   ) :: dt(:)
    type(bc_tower) , intent(in   ) :: the_bc_tower
    integer        , intent(in   ) :: n,step
    integer        , intent(in   ) :: num_substeps

    real(kind=dp_t) :: alpha, scale
    integer         :: istep, i, dm, ng_p
    ! Array of edge-based multifabs; one for each direction
    type(multifab) :: flux(mla%dim)

    dm = mla%dim
    ng_p = phi_new(n)%ng

    ! We only want one processor to write to screen
    if ( parallel_IOProcessor() ) &
       print*,'   Advancing level: ',n,' with dt = ',dt(n)

    ! Copy phi_new from the previous time step into phi_old for this time step
    call multifab_copy(mdst=phi_old(n),msrc=phi_new(n),ng=ng_p)

    if (n .eq. 1) then

        ! Fill ghost cells for two adjacent grids at the same level
        ! this includes periodic domain boundary ghost cells
        call multifab_fill_boundary(phi_old(n))

        ! Fill non-periodic domain boundary ghost cells
        call multifab_physbc(phi_old(n),1,1,1,the_bc_tower%bc_tower_array(n))

     else if (step .eq. 1) then
        ! First update boundary conditions
        ! Fill level n ghost cells using interpolation from level n-1 data
        ! Note that multifab_fill_boundary and multifab_physbc are called for
        ! both levels n-1 and n
        ! The coarsest level
        call multifab_fill_ghost_cells(phi_old(n),phi_old(n-1),ng_p,&
                                       mla%mba%rr(n-1,:), &
                                       the_bc_tower%bc_tower_array(n-1), &
                                       the_bc_tower%bc_tower_array(n), &
                                       1,1,1)
    else
        !
        ! This version of multifab_fill_ghost_cells takes both a crse_old and a crse_new
        !     and does interpolation in time as well as in space.  The coefficient alpha
        !     is used to define:   fine = interp (alpha*crse_old + (1-alpha)*crse_new )
        !
        ! If num_substeps = 2, then at step = 1, alpha = 1.0
        !                           at step = 2, alpha = 0.5
        ! If num_substeps = 4, then at step = 1, alpha = 1.0
        !                           at step = 2, alpha = 0.75
        !                           at step = 3, alpha = 0.5
        !                           at step = 4, alpha = 0.25
        !
        alpha = 1.d0 - dble(step-1)/dble(num_substeps)
        call multifab_fill_ghost_cells_t(phi_old(n),phi_old(n-1),phi_new(n-1),alpha,&
                                         ng_p,mla%mba%rr(n-1,:), &
                                         the_bc_tower%bc_tower_array(n-1), &
                                         the_bc_tower%bc_tower_array(n), &
                                         1,1,1)
    end if

    do i = 1, dm
       call multifab_build_edge(flux(i),mla%la(n),1,0,i)
    end do

    ! Compute fluxes at level n.
    call compute_flux_single_level(mla,phi_old(n),flux,dx(n),dt(n),the_bc_tower%bc_tower_array(n))

    ! Update solution at level n.
    call update_phi_single_level(mla,phi_old(n),phi_new(n),flux,dx(n),dt(n))

    if (n .gt. 1) then
       ! Copy fine fluxes from cell boundaries into boundary registers for use in refluxing.
       scale = dt(n)*dx(n)**(dm-1) ! dt*area
       call flux_reg_fine_add(bndry_flx(n),flux,scale)
    end if

    if (n .eq. mla%nlevel) then ! finest level

       do i = 1, dm
          call multifab_destroy(flux(i))
       end do

    else  ! Now recursively update the next finer level

       scale = -dt(n)*dx(n)**(dm-1) ! -dt*area
       call flux_reg_crse_init(bndry_flx(n+1), flux, scale)

       do i = 1, dm
          call multifab_destroy(flux(i))
       end do

       do istep = 1, num_substeps
          call update_level(n+1,mla,phi_old,phi_new,bndry_flx,&
               dx,dt,the_bc_tower,istep,num_substeps)
       end do

       if ( parallel_IOProcessor() ) &
            print*,'   Refluxing level: ',n

       ! note that bndry_flx contains sum_{fine}{flux*dt*area} - {flux*dt*area}_crse
       scale = 1.d0/dx(n)**dm ! 1/volume
       call reflux(phi_new(n),bndry_flx(n+1),scale)

       ! Average the level (n+1) phi down onto level n. This overwrites all
       !     previous values of phi at level n under level (n+1) grids.
       call ml_cc_restriction_c(phi_new(n),1,phi_new(n+1),1,mla%mba%rr(n,:),1)
    end if

  end subroutine update_level

end module advance_module


!
! ++++++++++++++++++++++++++++++++++++++++++++++++++++
! copied from selfe2netcdf interpolatez subroutine
! Please keep in sync!
! ++++++++++++++++++++++++++++++++++++++++++++++++++++
!
!Generate wrapper by calling
!f2py -m interpz -h interpz.pyf interpz.f90
!Generate library
!f2py  -c interpz.pyf  interpz.f90

subroutine interpz1d(varin, zin, zout, np, nzin, nzout, kz, null_value, varout)

    integer                     , intent(in)        :: np, nzin, nzout, kz
    real(8)                     , intent(in)        :: null_value
    real(8), dimension(np,nzin) , intent(in)        :: zin , varin
    real(8), dimension(nzout)   , intent(in)        :: zout
    real(8), dimension(np,nzout), intent(out)       :: varout
    ! Locals
    integer                                         :: i,k,kout,k0
    real(8)                                         :: rat

    real, parameter     :: almost_zero = 1.e-6

    ! zout and zin should be negative

    !zin(kz:nzin)
    ! k=kz (bottom)  (=1 if only sigma, no zlevels below)
    ! k=nzin (top)

    !zout(1:nzout)
    ! k=1 (top)
    ! k=nzout (bottom)

    ! for a given time instant, if a requested level is above water varout == surface
    ! if below, varout is interpolated.

    !varout=null_value  !PROBLEM: if dry, varout will be null_value instead of 0.0
    ! problem because we need velocities to be zero when dry?

    varout=null_value

    do i=1,np

      if (abs(zin(i,kz)) <= almost_zero .and. abs(zin(i,nzin)) <= almost_zero) cycle ! dry nodes have all zins =0.

      do kout=1,nzout

        ! interpolate z
        if (zout(kout) < zin(i,kz)) then ! zout below bathymetry
          varout(i,kout) =-99999! do nothing
        elseif (zout(kout) >= zin(i,nzin)) then
          !if (debug .and. i==debug_node) write(*,*) 'getting surface!'
          write(*,*) 'getting surface!'
          varout(i,kout) = varin(i,nzin)
        else

          ! interp1d
          k0=-1! layer below
          do k=kz,nzin-1
            if (zin(i,k) <= zout(kout) .and. zout(kout) < zin(i,k+1)) then
              k0=k
              exit
            endif
          enddo !k

          if (k0<0) then
            ! should never enter here because below and above zin cases were comtemplated before
            write(*,*) "couldn't find any layers for zlevel ", zout(kout), 'at node ', i
            write(*,*) "zin = ", zin(i,:)
            stop 'interpolatez - selfe2netcdf - ERR02'
          endif

          rat = (zout(kout)-zin(i,k0)) / (zin(i,k0+1)-zin(i,k0))
          varout(i,kout) = varin(i,k0)*(1.-rat)+varin(i,k0+1)*rat

        endif

        !if (debug .and. i==debug_node) then
        ! write(*,*) 'kout, zout(kout), k0, zin(i,k0), zin(i,k0+1), varin(i,k0), varin(i,k0+1), varout(i,kout) = ', &
        !           kout, zout(kout), k0, zin(i,k0), zin(i,k0+1), varin(i,k0), varin(i,k0+1), varout(i,kout)
        !endif

      enddo !kout

    enddo !i=1,np

  end subroutine


      MODULE UTMS_DATA
      CHARACTER*1  :: YN,DATNUM,DATUM
      REAL*8       :: RAD,ER,RF,ESQ,PI, F,L, LS,F4,F2,ETS,EN,COSFI,C5,C3,C1,A7,A6,A5,A4,A3,A2,A1, OMO
      LOGICAL      :: FILFLAG,FILPRT,FIL81FL
      CHARACTER*1  :: EORW
      CHARACTER*30 :: NAME,GPPFIL,GPFIL,PCFIL,FIL81
      CHARACTER*80 :: CARDR
      CHARACTER*1  :: NORS
      CHARACTER*11 :: CLAT
      CHARACTER*12 :: CLON
      CHARACTER*8  :: TITLE,GNUM
      CHARACTER*4  :: ZONE
      INTEGER*4    :: LD,LM,LOD,LOM,FOUND,J,IZ,ISEC,IMIN,IDEG,ICM,I,JSEC
       REAL*8      :: SLAT,SLON,FI,LAM,LCM,UCM,LOD1,CONV,SF,OR,EPS,R,A,B,C,U,V,W,SO,CM,FE,FN
       REAL*8      :: KP,GRIDAZ,TD,TM,ND,NM,NORTH,EAST,TOL,GEOD,CSEC, TN,TS,SINFI,S,RN,PR,OM

      CHARACTER*5  :: XGD,GDVAL(1001)

      CHARACTER*1 PM,ESGN,GSGN
      CHARACTER*1 ELEVT
      CHARACTER*2 ORDER
      CHARACTER*2 ELXX
      CHARACTER*6 GD
      INTEGER*4	STANUM, ISN, IPRT, I3, I4, I2, ICON,GDNUM(1001)
      CHARACTER*4 ELEV
      CHARACTER*11 REST
      CHARACTER*7 ELNUM

      CHARACTER*11 ANORTH
      CHARACTER*10 AEAST
      CHARACTER*1  BUFF(20)

      REAL*8 SEC,RHOSEC
      DATA RHOSEC/2.062648062471D05/
      DATA DATNUM /'2'/    ! 1=NAD27, 2=NAD83, 3=INT24, 4=WGS72

      END MODULE UTMS_DATA
      SUBROUTINE UTMS
!     THIS PROGRAM CONVERTS GPS	TO UNIVERSIAL TRANSVERSE MERACTOR COORDINATES
!     AND VICE VERSA FOR THE NAD27 AND NAD83 DATUM.
!     THIS PROGRAM WAS WRITTEN BY E. CARLSON
!     SUBROUTINES TMGRID, TCONST, TMGEOD, TCONPC,
!     WERE WRITTEN BY T. VINCENTY, NGS,	IN JULY	1984 .
!     THE ORGINAL PROGRAM WAS WRITTEN IN SEPTEMBER OF 1988.
!
!     THIS PROGRAM WAS UPDATED ON FEBUARY 16, 1989.  THE UPDATE	WAS
!     HAVING THE OPTION	OF SAVING AND *81* RECORD FILE.
!
!
!     THIS PROGRAM WAS UPDATED ON APRIL	3, 1990.  THE FOLLOWING	UPDATE
!     WERE MADE:
!      1. CHANGE FROM JUST A CHOICE OF NAD27 OF	NAD83 REFERENCE
!	  ELLIPSOIDS TO; CLARKE	1866, GRS80/WGS84, INTERNATIONAL, AND
!	  ALLOW	FOR USER DEFINED OTHER.
!      2. ALLOW	USE OF LATITUDES IN SOUTHERN HEMISPHERE	AND LONGITUDES
!	  UP TO	360 DEGREES WEST.
!
!     THIS PROGRAM WAS UPDATED ON DECEMBER 1, 1993. THE	FOLLOWING UPDATE
!     WAS MADE:
!      1. THE NORTHINGS	WOULD COMPUTE THE RIGHT	LATITUDE IN THE	SOUTHERN
!	  HEMISHPERE.
!      2. THE COMPUTED LATITUDE	ON LONGIDUTES WOULD BE EITHER  IN E OR W.
!
!****************************************************************     *
!		   DISCLAIMER					      *
!								      *
!   THIS PROGRAM AND SUPPORTING	INFORMATION IS FURNISHED BY THE	      *
! GOVERNMENT OF	THE UNITED STATES OF AMERICA, AND IS ACCEPTED AND     *
! USED BY THE RECIPIENT	WITH THE UNDERSTANDING THAT THE	UNITED STATES *
! GOVERNMENT MAKES NO WARRANTIES, EXPRESS OR IMPLIED, CONCERNING THE  *
! ACCURACY, COMPLETENESS, RELIABILITY, OR SUITABILITY OF THIS	      *
! PROGRAM, OF ITS CONSTITUENT PARTS, OR	OF ANY SUPPORTING DATA.	      *
!								      *
!   THE	GOVERNMENT OF THE UNITED STATES	OF AMERICA SHALL BE UNDER NO  *
! LIABILITY WHATSOEVER RESULTING FROM ANY USE OF THIS PROGRAM.	THIS  *
! PROGRAM SHOULD NOT BE	RELIED UPON AS THE SOLE	BASIS FOR SOLVING A   *
! PROBLEM WHOSE	INCORRECT SOLUTION COULD RESULT	IN INJURY TO PERSON   *
! OR PROPERTY.							      *
!								      *
!   THIS PROGRAM IS PROPERTY OF	THE GOVERNMENT OF THE UNITED STATES   *
! OF AMERICA.  THEREFORE, THE RECIPIENT	FURTHER	AGREES NOT TO ASSERT  *
! PROPRIETARY RIGHTS THEREIN AND NOT TO	REPRESENT THIS PROGRAM TO     *
! ANYONE AS BEING OTHER	THAN A GOVERNMENT PROGRAM.		      *
!								      *
!**********************************************************************
      USE UTMS_DATA

      IMPLICIT NONE
      PI=4.D0*DATAN(1.D0)
      RAD=180.D0/PI

	  CALL DATUMM
 	  CALL IUTGP    ! INTERACTIVE

      RETURN
      END
!*****************************************************
      SUBROUTINE HDUTGP
!****************************************************
    USE UTMS_DATA
    IMPLICIT NONE

	IF(IPRT.EQ.1) THEN
	   WRITE(3,5) GNUM
    5	   FORMAT('1',/,T50,'PRELIMINARY COORDINATE LISTING ',/	,T59,'FOR ',A8,//)
	ELSEIF(IPRT.EQ.2) THEN
	   WRITE(3,6) GNUM
    6	   FORMAT('1',/,T54,'FINAL COORDINATE LISTING ',/,T60,'FOR ',A8,//)
	ELSE
	   WRITE(3,7)
    7	   FORMAT('1',//////)
	ENDIF
	 IF(DATNUM.EQ.'1') THEN
      WRITE(3,10)
   10 FORMAT(T54,'NATIONAL GEODETIC SURVEY',/,  &
     	     T58,'GP TO	UTMs PROGRAM',T118,'VERSION 2.1',/,T55,  &
     	     'CLARKE 1866 ELLIPSOID',//,  &
     	      1X,' STATION NAME',T34,'LATITUDE',  &
     	     T50,'LONGITUDE',T68,'NORTHING(Y)',T80,'EASTING(X)',  &
     	     T92,'ZONE',T97,'CONVERGENCE',T110,'SCALE',T121,'ELEV',  &
     	     T129,'GEOID',/,T68,'METER',  &
     	     T80,'METER',T97,'D',T100,'M',T104,'S',  &
     	     T110,'FACTOR',T121,'(M)',T129,'HT(M)',//)
	 ENDIF
	 IF(DATNUM.EQ.'2') THEN
      WRITE(3,12)
   12 FORMAT(T54,'NATIONAL GEODETIC SURVEY',/,  &
     	     T58,'GP TO	UTMs PROGRAM',T118,'VERSION 2.1',/,T56,  &
     	     'GRS80/WGS84 ELLIPSOID',//,  &
     	      1X,' STATION NAME',T34,'LATITUDE',  &
     	     T50,'LONGITUDE',T68,'NORTHING(Y)',T80,'EASTING(X)',  &
     	     T92,'ZONE',T97,'CONVERGENCE',T110,'SCALE',T121,'ELEV',  &
     	     T129,'GEOID',/,T68,'METER',  &
     	     T80,'METER',T97,'D',T100,'M',T104,'S',  &
     	     T110,'FACTOR',T121,'(M)',T129,'HT(M)',//)
	 ENDIF
	 IF(DATNUM.EQ.'3') THEN
      WRITE(3,13)
   13 FORMAT(T54,'NATIONAL GEODETIC SURVEY',/,  &
     	     T58,'GP TO	UTMs PROGRAM',T118,'VERSION 2.1',/,T53,  &
     	     'INTERNATIONAL 1910 ELLIPSOID',//,  &
     	      1X,' STATION NAME',T34,'LATITUDE',  &
     	     T50,'LONGITUDE',T68,'NORTHING(Y)',T80,'EASTING(X)',  &
     	     T92,'ZONE',T97,'CONVERGENCE',T110,'SCALE',T121,'ELEV',  &
     	     T129,'GEOID',/,T68,'METER',  &
     	     T80,'METER',T97,'D',T100,'M',T104,'S',  &
     	     T110,'FACTOR',T121,'(M)',T129,'HT(M)',//)
	 ENDIF
	 IF(DATNUM.EQ.'4') THEN
      WRITE(3,14)
   14 FORMAT(T54,'NATIONAL GEODETIC SURVEY',/,  &
     	     T58,'GP TO	UTMs PROGRAM',T118,'VERSION 2.1',/,T59,  &
     	     'WGS72 ELLIPSOID',//,  &
     	      1X,' STATION NAME',T34,'LATITUDE',  &
     	     T50,'LONGITUDE',T68,'NORTHING(Y)',T80,'EASTING(X)',  &
     	     T92,'ZONE',T97,'CONVERGENCE',T110,'SCALE',T121,'ELEV',  &
     	     T129,'GEOID',/,T68,'METER',  &
     	     T80,'METER',T97,'D',T100,'M',T104,'S',  &
     	     T110,'FACTOR',T121,'(M)',T129,'HT(M)',//)
	 ENDIF
	 IF(DATNUM.EQ.'5') THEN
      WRITE(3,15)
   15 FORMAT(T54,'NATIONAL GEODETIC SURVEY',/,  &
     	     T58,'GP TO	UTMs PROGRAM',T118,'VERSION 2.1',/,T59,  &
     	     'OTHER ELLIPSOID',//,       &
     	      1X,' STATION NAME',T34,'LATITUDE', &
     	     T50,'LONGITUDE',T68,'NORTHING(Y)',T80,'EASTING(X)', &
     	     T92,'ZONE',T97,'CONVERGENCE',T110,'SCALE',T121,'ELEV', &
     	     T129,'GEOID',/,T68,'METER', &
     	     T80,'METER',T97,'D',T100,'M',T104,'S', &
     	     T110,'FACTOR',T121,'(M)',T129,'HT(M)',//)
	 ENDIF
      RETURN
      END
!******************************************************************
       SUBROUTINE IUTGP
!******************************************************************
      USE UTMS_DATA
      USE GRID
      IMPLICIT NONE

      FILFLAG=.FALSE.
      FIL81FL=.FALSE.

	OPEN(3,STATUS='UNKNOWN',FILE='test_out_utm.txt',ERR=900)
	FILFLAG=.TRUE.
    IPRT=1
	CALL HDUTGP
    GO TO 901
900   WRITE(*,*)'Test_out_utm.txt file creation error'
901   CONTINUE
      DO J=1,NWB
	  NAME='          '

      LD=INT(LAT(J))
      LM=INT((LAT(J)-FLOAT(LD))*60.)
      SLAT=(((LAT(J)-FLOAT(LD))*60.)-FLOAT(LM))*60.
      NORS='N'               ! CHARACTER*1 N OR S
      LOD=INT(LONG(J))
      LOM=INT((LONG(J)-FLOAT(LOD))*60.)
      SLON=(((LONG(J)-FLOAT(LOD))*60.)-FLOAT(LOM))*60.
      EORW='W'               ! CHARACTER*1 DIRECTION OF LONGITUDE - E OR	W

      !LD=45                 ! INTEGER LATITUDE:DEGREES DD
      !LM=10               ! INTEGER MINUTES MM
      !SLAT=25.5               ! REAL SECONDS SS.SSSSS
      !NORS='N'               ! CHARACTER*1 N OR S
      !LOD=118                ! INTEGER LONGITUDE: DEGREES DDD
      !LOM=10                ! INTEGER MINUTES MM
      !SLON=45.5               ! REAL SECONDS SS.SSSSS
      !EORW='E'               ! CHARACTER*1 DIRECTION OF LONGITUDE - E OR	W

      ISEC = SLAT * 1.0D5 + 0.5D0
      JSEC = SLON * 1.0D5 + 0.5D0

      CALL DRGPUT
      UTMZONE(J)=IZ
      YNORTHING(J)=NORTH
      XEASTING(J)=EAST

      END DO

      RETURN
      END
!***********************************************************************
       SUBROUTINE DRGPUT
!*********************************************************************
!
!
!      THIS IS THE DRIVER TO COMPUTE UTM NORTHINGS AND EASTINGS
!      FOR EACH	PRIMARY	ZONE AND THE AJACENT ZONE IF THE LONGITUDE
!      IS WITH 5 MINUTES OF THE	ZONE BOUNDARIES
!
!      THE OUTPUT IS FOR THE DATA SHEET	PROGRAM
!
!      VARIABLES
!      CARDR = A MODIFIED 80 RECORD CARD WITH A	LENGTH OF 211 COLS
!      ER = EQUATORIAL RADIUS OF THE ELLIPSOID (SEMI-MAJOR AXIS)
!      RF = RECIPROCAL OF FLATTING OF THE ELLIPSOD
!      ESQ= E SQUARED
!      RAD = RADIAN CONVERSION FACTOR
!      CM = CENTRAL MERIDIAN ( COMPUTED	USEING THE LONGITUDE)
!      SF = SCALE FACTOR OF CENTRAL MERIDIAN ( ALWAYS .9996 FOR	UTM)
!      OR = SOUTHERNMOST PARALLEL OF LATITUDE (	ALWAYS ZERO FOR	UTM)
!      R, A, B,	C, U, V, W = ELLIPSOID CONSTANTS USED FOR COMPUTING
!			     MERIDIONAL	DISTANCE FROM LATITUDE
!      SO = MERIDIONAL DISTANCE	(MULTIPLIED BY SCALE FACTOR )
!	    FROM THE EQUATOR TO	THE SOUTHERNMOST PARALLEL OF LATITUDE
!	    ( ALWAYS ZERO FOR UTM)
!
       USE UTMS_DATA
       IMPLICIT NONE

!      CONVERT THE LATITUDE AND	LONGITUDE TO PI	AND LAM
       TD=DBLE(FLOAT(LD))
       TM=DBLE(FLOAT(LM))
       FI=(TD+(TM+SLAT/60.D0)/60.D0)/RAD
       ND=DBLE(FLOAT(LOD))
       NM=DBLE(FLOAT(LOM))
       IF((EORW.EQ.'E').OR.(EORW.EQ.'e')) THEN
	 LAM=(360.D0-(ND+(NM+SLON/60.D0)/60.D0))/RAD
	 LOD1=(360.D0-(ND+(NM+SLON/60.D0)/60.D0))
	 LOD=DINT(LOD1)
       ENDIF
       IF((EORW.EQ.'W').OR.(EORW.EQ.'w')) THEN
	 LAM=(ND+(NM+SLON/60.D0)/60.D0)/RAD
	 LOD=LOD
       ENDIF
!      FIND THE	ZONE FOR LONGITUDE LESS	THAN 180 DEGREES
	IF(LOD.LT.180) THEN
	   IZ=LOD/6
	   IZ= 30 -IZ
	   ICM=(183-(6*IZ))
	   CM=DBLE(FLOAT(ICM))/RAD
	   UCM=(ICM+3)/RAD
	   LCM=(ICM-3)/RAD
	ENDIF
!	FIND THE ZONE FOR LONGITUDE GREATER THAN 180 DEGREES
	 IF(LOD.GE.180)	THEN
	    IZ=(LOD)/6
	    IZ=	90 - IZ
	    ICM=(543 - (6*IZ))
	    CM=	DBLE(FLOAT(ICM))/RAD
	    UCM=(ICM+3)/RAD
	    LCM=(ICM-3)/RAD
	 ENDIF
       TOL=(5.0D0/60.0D0)/RAD
       FN = 0.D0
       IF((NORS.EQ.'S').OR.(NORS.EQ.'s')) THEN
	  FN = 10000000.D0
       ENDIF
       IF((NORS.EQ.'N').OR.(NORS.EQ.'n')) THEN
	  FN = 0.D0
       ENDIF
       FE=500000.0D0
       SF=0.9996D0
       OR=0.0D0
       FOUND=0
       CALL TCONST
!      COMPUTE THE NORTH AND EASTINGS
 200  CALL TMGRID
!      WRITE THE ZONE NUMBER
       IF (IZ.GT.9) THEN
	 WRITE(ZONE,600) IZ
 600	 FORMAT(1X,I2)
       ELSE
	 WRITE(ZONE,605) IZ
 605	 FORMAT(1X,I2.2)
       ENDIF
!      WRITE THE OUTPUT	TO THE PLANE FILE FOR THE DATA SHEET
!      PROGRAM
      CALL DATAUT
!      DO THE TEST TO SEE IF THE LONGITUDE IS WITHIN 5 MINUTES
!      OF THE BOUNDARIES FOR THE ZONE AND IF SO	COMPUTE	THE
!      NORHT AND EASTING FOR THE ADJACENT ZONE
       IF(FOUND.NE.0) THEN
	  RETURN
       ENDIF
       IF(DABS(UCM-LAM).LE.TOL)	THEN
	  CM=DBLE(FLOAT(ICM+6))/RAD
	  IZ=IZ-1
	  IF(IZ.EQ.0) IZ=60
	  FOUND=FOUND+1
	  GO TO	200
       ENDIF
       IF(DABS(LCM-LAM).LE.TOL)	THEN
	  CM=DBLE(FLOAT(ICM-6))/RAD
	  IZ=IZ+1
	  IF(IZ.EQ.61) IZ=1
	  FOUND=FOUND+1
	  GO TO	200
       ENDIF
       RETURN
       END
!********************************************************************
      SUBROUTINE DATAUT
!*******************************************************************
      USE UTMS_DATA
      IMPLICIT NONE

      IF (CONV.LT.0) THEN
	PM='-'
      ELSE
	PM=' '
      ENDIF
      CALL TODMS(DABS(CONV),IDEG,IMIN,CSEC)
       IF(FILFLAG) THEN
		  IF(ICON.GE.48) THEN
              IPRT=2
		     CALL HDUTGP
		     ICON = 0
		  ENDIF
	  IF((ORDER(1:1).EQ.'4').AND.(ELEVT.EQ.' ')) THEN
	       ELNUM='	     '
	  ELSEIF((ORDER(1:1).EQ.' ').AND.(ELEVT.EQ.' ')) THEN
	       ELNUM='	     '
	  ELSEIF((ELEVT.EQ.'B').OR.(ELEVT.EQ.'L')) THEN
	       WRITE(ELNUM,200)	ELEV,ELXX
  200	       FORMAT(A4,'.',A2)
	  ELSEIF((ELEVT.EQ.'R').OR.(ELEVT.EQ.'T')) THEN
	       WRITE(ELNUM,205)	ELEV,ELXX(1:1)
  205	       FORMAT(A4,'.',A1,' ')
	  ELSEIF((ELEVT.EQ.'P').OR.(ELEVT.EQ.'E').OR.(ELEVT.EQ.'V')) THEN
	       WRITE(ELNUM,210)	ELEV
  210	       FORMAT(A4,'.  ')
	  ELSE
	       WRITE(ELNUM,215)	ELEV
  215	       FORMAT(A4,' SC')
	  ENDIF
!** DO THE DO LOOP TO FIND THE GEOD HT
	    GD='      '
	    XGD='     '
	 DO 60 I=1,ISN
	    IF(GDNUM(I).EQ.STANUM) THEN
	       XGD=GDVAL(I)
	    ENDIF
   60	  CONTINUE
	     IF(XGD.NE.'     ')	THEN
		READ(XGD,FMT='(F5.1)') GEOD
		 GSGN='	'
	      IF(GEOD.LE.0.0D0)	THEN
		 GSGN='-'
	      ENDIF
		  GEOD=DABS(GEOD)
		  WRITE(GD,FMT='(F6.2)') GEOD
		  GD(1:1)=GSGN
	     ENDIF
	IF(J.EQ.0) THEN
	  WRITE(3,10) NAME,LD,LM,SLAT,NORS,LOD,LOM,SLON,EORW,  &
     		   NORTH,EAST,ZONE,PM,IDEG,IMIN,CSEC,KP,ELNUM,GD
 10	  FORMAT(1X,A30,T34,I2,1X,I2,1X,F8.5,A1,T50,I3.3,1X,I2.2,1X, &
     	   F8.5,A1,T67,F12.3,T80,F11.3,T92,A4,T97,A1,I1,1X,I2,1X,F5.2, &
     	   T109,F10.8,T120,A7,T128,A6)
		ICON= ICON + 1
	ELSE
	  WRITE(3,20) NORTH,EAST,ZONE,PM,IDEG,IMIN,CSEC,KP
  20	  FORMAT(T67,F12.3,T80,F11.3,T92,A4,T97,A1,I1,1X,I2,1X, &
     		 F5.2,T109,F10.8)
	       ICON = ICON + 1
	ENDIF
      ELSE
	 IF(DATNUM.EQ.'1') THEN
	   PRINT *, ' UTMS FOR THE CLARK 1866 ELLIPSOID	(NAD27 DATUM) '
	   PRINT *,'		 '
	 ENDIF
	 IF(DATNUM.EQ.'2') THEN
	    PRINT *,'  UTMS FOR	THE GRS80/WGS84	ELLIP (NAD83 DATUM) '
	    PRINT *,'				'
	 ENDIF
	 IF(DATNUM.EQ.'3') THEN
	    PRINT *,'  UTMS FOR	THE INTERNATIONAL ELLIP	(INT24 DATUM) '
	    PRINT *,'				'
	 ENDIF
	 IF(DATNUM.EQ.'4') THEN
	    PRINT *,'  UTMS FOR	THE WGS72 ELLIPSOID '
	    PRINT *,'				'
	 ENDIF
	 IF(DATNUM.EQ.'5') THEN
	    PRINT *,'  UTMS FOR	THE OTHER ELLIPSOID '
	    PRINT *,'				'
	 ENDIF
	WRITE(*,30)
   30	FORMAT('   NORTH(Y)	 EAST(X)   ZONE	  ',  &
     	       ' CONVERGENCE  SCALE')
	WRITE(*,40)NORTH,EAST,ZONE,PM,IDEG,IMIN,CSEC,KP
   40	FORMAT(1X,F12.3,1X,F11.3,2X,A4,2X,A1,I1,1X,I2,1X,  &
     	       F5.2,3X,F10.8)
      ENDIF
      IF(FIL81FL) THEN
	CALL CHGDEC(11,3,EAST,BUFF)
	  AEAST(1:1)  =	BUFF(1)
	  AEAST(2:2)  =	BUFF(2)
	  AEAST(3:3)  =	BUFF(3)
	  AEAST(4:4)  =	BUFF(4)
	  AEAST(5:5)  =	BUFF(5)
	  AEAST(6:6)  =	BUFF(6)
	  AEAST(7:7)  =	BUFF(7)
	  AEAST(8:8)  =	BUFF(9)
	  AEAST(9:9)  =	BUFF(10)
	  AEAST(10:10) = BUFF(11)
	CALL CHGDEC(12,3,NORTH,BUFF)
	  ANORTH(1:1)  = BUFF(1)
	  ANORTH(2:2)  = BUFF(2)
	  ANORTH(3:3)  = BUFF(3)
	  ANORTH(4:4)  = BUFF(4)
	  ANORTH(5:5)  = BUFF(5)
	  ANORTH(6:6)  = BUFF(6)
	  ANORTH(7:7)  = BUFF(7)
	  ANORTH(8:8)  = BUFF(8)
	  ANORTH(9:9)  = BUFF(10)
	  ANORTH(10:10)	= BUFF(11)
	  ANORTH(11:11)	= BUFF(12)
       READ(CARDR,300) STANUM,NAME,REST
  300  FORMAT(T11,I3,T15,A30,T70,A11)
	IF(DATNUM.EQ.'1') THEN
	WRITE(4,310) STANUM,NAME,AEAST,ANORTH,ZONE(2:3),REST
  310	FORMAT(T7,'*81*',T11,I3,T15,A30,T45,A10,T55,A11,   &
     	       T66,'00',A2,T70,A11)
	ENDIF
	IF(DATNUM.EQ.'2') THEN
	WRITE(4,320) STANUM,NAME,ANORTH,AEAST,ZONE(2:3),REST
  320	FORMAT(T7,'*81*',T11,I3,T15,A30,T45,A11,T56,A10,   &
     	       T66,'00',A2,T70,A11)
	ENDIF
	IF(DATNUM.EQ.'3') THEN
	WRITE(4,310) STANUM,NAME,AEAST,ANORTH,ZONE(2:3),REST
	ENDIF
       IF(DATNUM.EQ.'4') THEN
	WRITE(4,310) STANUM,NAME,AEAST,ANORTH,ZONE(2:3),REST
	ENDIF
       IF(DATNUM.EQ.'4') THEN
	WRITE(4,310) STANUM,NAME,AEAST,ANORTH,ZONE(2:3),REST
	ENDIF
       IF(DATNUM.EQ.'5') THEN
	WRITE(4,310) STANUM,NAME,AEAST,ANORTH,ZONE(2:3),REST
	ENDIF
      ENDIF
      RETURN
      END
!*********************************************************************
      SUBROUTINE TODMS(RAD,IDG,MIN,SEC)
!*********************************************************************
!     RADIANS TO DEGREES,MINUTES AND SECONDS
      USE UTMS_DATA, ONLY: RHOSEC
      IMPLICIT NONE
      REAL*8    :: RAD,SEC
      INTEGER*4 :: IDG,MIN

      SEC=RAD*RHOSEC
      IDG=SEC/3600.D0
      SEC=SEC-DBLE(IDG*3600)
      MIN=SEC/60.D0
      SEC=SEC-DBLE(MIN*60)
      IF((60.D0-DABS(SEC)).GT.5.D-6) GO	TO 100
      SEC=SEC-DSIGN(60.D0,SEC)
      MIN=MIN+ISIGN(1,MIN)
  100 IF(IABS(MIN).LT.60) GO TO	101
      MIN=MIN-ISIGN(60,MIN)
      IDG=IDG+ISIGN(1,IDG)
  101 MIN=IABS(MIN)
      SEC=DABS(SEC)
      IF(RAD.GE.0.D0) GO TO 102
      IF(IDG.EQ.0) MIN=-MIN
      IF(IDG.EQ.0.AND.MIN.EQ.0)SEC=-SEC
  102 RETURN
      END
!*********************************************************************
      SUBROUTINE CHGDEC (NNN,MMM,SS,CHAR)
!     -----------------------------------------------------
      CHARACTER*1  DASH,ZERO,DOL,BLK1,CHAR(*),IB(20),TT
      CHARACTER*20 JB
      INTEGER*4   IDG,MIN
      REAL*8      S,SS,DEC,W,SEC,TEN,TOL
!
      EQUIVALENCE (IB,JB)
!
      DATA BLK1,DOL,ZERO,DASH/' ','$','0','-'/,TEN/10.0D0/
!
!        CHAR      1-16      LENGTH OF CHARACTER ARRAY FIELD
!        NR        1-13      LENGTH OF FIELD TO BE USED FROM LEFT
!        NP        7-13      LOCATION OF DECIMAL POINT FROM RIGHT
!        NEG       CHAR(1)   PUT THE MINUS SIGN HERE
!        EXAMPLE:            RANGE NR=14 AND WITH A POINT NP=6
!                            W=  -3600.376541
!
! CHAR FIELD     1  2  3  4  5  6  7  8  9 10 11 12 13 14 15 16
! BLANK FILLED   B  B  B  B  B  B  B  B  B  B  B  B  B  B  B  B BLANK
! NR ADDED      |B  B  B  B  B  B  B  B  B  B  B  B  B  B| B  B LIMIT
! NP ADDED      |B  B  B  B  B  B  B  .  B  B  B  B  B  B| B  B POINT
! W ENTERED     |B  B  -  3  6  0  0  .  3  7  6  5  4  1| 8  4
! DOL (SIGN)    |B  B  -  3  6  0  0  .  3  7  6  5  4  1| $  4
! NEG (SIGN)    |B  B  -  3  6  0  0  .  3  7  6  5  4  1| $  4
!
!  -------------------------------
!     SETUP OUTSIDE CONSTANTS

      NR=NNN
      NP=MMM
      DEC=SS
!
!     CHECK TO SEE IF NR AND NF ARE WITHIN LIMITS
!
      NNP=IABS(NP)
      KTST=0
      M=IABS(NR)
!
!     IF NR IS GREATER THAN ZERO -- DECIMAL NUMBER
!
      IF(NR.GT.0)GOTO 1
! -------------------------------------
!     THIS IS A DEG-MIN-SEC FORMAT
!
      IF(NNP.GT.5)NNP=5
!
!     ENTRY IS DDD-MM-SS.SS
!           OR  HH-MM-SS.SS
!
      DEC=DABS(DEC)
      SEC=DEC*3600.0D0
      IDG=SEC/3600.0D0
      SEC=SEC-DBLE(FLOAT(IDG))*3600.0D0
      MIN=SEC/60.0D0
      SEC=SEC-DBLE(FLOAT(MIN))*60.0D0
      DEC=DBLE(FLOAT(IDG))*1000000.0D0+DBLE(FLOAT(MIN))*1000.0D0+SEC

      KTST=1
      M=15

!     ROUND THE DECIMAL NUMBER

    1 IP=-1*(NNP+1)
      TOL=5.0D0*(TEN**IP)
      W=(DABS(DEC) + TOL)
      IF(DEC.LT.0.0D0) W=-W
      DEC=W

      N=NNP
      IF(M.GT.15)M=15
      IF(M.LT.4)M=4
      IF(N.GE.M)N=M-1
      W=DEC

!     CONVERT THE DECIMAL NUMBER

      WRITE(JB,100) W
  100 FORMAT(F20.10)

!     BLANK FILL THE ARRAY

      DO 5 IQ=1,16
    5 CHAR(IQ)=BLK1

!     LOOK FOR THE FIRST NON-BLANK CHARACTER

      DO 6 I=1,10
      TT=IB(I)
    6 IF(TT.NE.BLK1)GOTO 7

!     COMPUTE THE PROPER NUMBER LENGTH WITH THE PROPER DECIMALS

    7 K=11-I
      K=K+N
      IF(K.GT.M)M=K
      L=10-(M-N)
      IF(L.LE.0)L=0

      MM=M+1
      J=0
      IDEC=0
      DO 30 I=1,MM
      K=I+L
      IF(K.GT.20)K=20
      J=J+1
      CHAR(J)=IB(K)
   30 IF(CHAR(J).EQ.'.') IDEC=J
      N=IDEC+NNP+1

      IF(KTST.EQ.0)GOTO 40

!     FILL-OUT THE DEG-MIN-SEC FIELD

      CHAR(4)=DASH
      CHAR(7)=DASH

!     ZERO-OUT ALL BLANK CHARACTERS

      DO 10 I=1,9
   10 IF(CHAR(I).EQ.BLK1)CHAR(I)=ZERO

   40 CHAR(N)=DOL

      RETURN
      END
!***********************************************************
      SUBROUTINE DATUMM
      USE UTMS_DATA
      IMPLICIT NONE

!     FIND THE	RIGHT SEMI MAJOR AXIS AND FLATTING

	 IF(DATNUM.EQ.'1')	THEN
!	FOR THE	NAD 27 DATUM

		ER=6378206.4D0
		RF=294.978698D0
		F=1.D0/RF
		ESQ=(F+F-F*F)
	ELSEIF (DATNUM.EQ.'2') THEN
!     FOR THE NAD83 DATUM

		ER=6378137.D0
		RF=298.257222101D0
		F=1.D0/RF
		ESQ=(F+F-F*F)
	ELSEIF (DATNUM.EQ.'3') THEN
!     FOR THE INT24 DATUM

		ER=6378388.D0
		RF=297.0D0
		F=1.D0/RF
		ESQ=(F+F-F*F)
	ELSEIF (DATNUM.EQ.'4') THEN
!     FOR THE WGS72

		ER=6378135.D0
		RF=298.26D0
		F=1.D0/RF
		ESQ=(F+F-F*F)
    ELSE
        WRITE(*,*)'ERROR: WRONG DATNUM SPECIFIED'
        STOP
     ENDIF
	 RETURN
END
      SUBROUTINE TMGRID
      USE UTMS_DATA
      IMPLICIT NONE
!
!****	TRANSVERSE MERCATOR PROJECTION
!	CONVERSION OF GEODETIC COORDINATES TO GRID COORDINATES
!****	Programmed by T. Vincenty, NGS,	in July	1984.
!****************  SYMBOLS AND	DEFINITIONS *************************
!   Latitude positive north, longitude positive	west.  All angles are
!     in radian	measure.
!   N, E are northing and easting coordinates respectively.
!   LAT, LON are latitude and longitude	respectively.
!   CONV is convergence.
!   KP is point	scale factor.
!   ER is equatorial radius of the ellipsoid (=	major semiaxis).
!   ESQ	is the square of first eccentricity of the ellipsoid.
!   EPS	is the square of second	eccentricity of	the ellipsoid.
!   CM is the central meridian of the projection zone.
!   FE is false	easting	value at the central meridian.
!   FN is "false northing" at the southernmost latitude, usually zero.
!   SF is scale	factor at the central meridian.
!   SO is meridional distance (multiplied by the scale factor) from
!     the equator to the southernmost parallel of latitude for the zone.
!   R is the radius of the rectifying sphere (used for computing
!     meridional distance from latitude	and vice versa).
!   A, B, C, U,	V, W are other precomputed constants for determination
!     of meridional distance from latitude and vice versa.
!
!   The	formula	used in	this subroutine	gives geodetic accuracy	within
!   zones of 7 degrees in east-west extent.  Within State transverse
!   Mercator projection	zones, several minor terms of the equations
!   may	be omitted (see	a separate NGS publication).  If programmed
!   in full, the subroutine can	be used	for computations in surveys
!   extending over two zones.
!
!********************************************************************
      OM=FI + A*SIN(2.*FI) + B*SIN(4.*FI) + C*SIN(6.*FI)
      S=R*OM*SF
      SINFI=SIN(FI)
      COSFI=COS(FI)
      TN=SINFI/COSFI
      TS=TN**2
      ETS=EPS*COSFI**2
      L=(LAM-CM)*COSFI
      LS=L*L
      RN=SF*ER/SQRT(1.-ESQ*SINFI**2)

      A2=RN*TN/2.
      A4=(5.-TS+ETS*(9.+4.*ETS))/12.
      A6=(61.+TS*(TS-58.)+ETS*(270.-330.*TS))/360.
      A1=-RN
      A3=(1.-TS+ETS)/6.
      A5=(5.+TS*(TS-18.)+ETS*(14.-58.*TS))/120.
      A7=(61.-479.*TS+179.*TS**2-TS**3)/5040.
      NORTH=S-SO + A2*LS*(1.+LS*(A4+A6*LS)) - FN
      EAST=FE +	A1*L*(1.+ LS*(A3+LS*(A5+A7*LS)))

      IF(NORTH.LT.0.0) THEN
       NORTH = NORTH * (-1.0D0)
      ENDIF

!** CONVERGENCE
      C1=-TN
      C3=(1.+3.*ETS+2.*ETS**2)/3.
      C5=(2.-TS)/15.
      CONV=C1*L*(1.+LS*(C3+C5*LS))

!** POINT SCALE FACTOR
      F2=(1.+ETS)/2.
      F4=(5.-4.*TS+ETS*( 9.-24.*TS))/12.
      KP=SF*(1.+F2*LS*(1.+F4*LS))

      RETURN
      END
!********************************************************************
      SUBROUTINE TCONST
      USE UTMS_DATA
      IMPLICIT NONE
!
!**** TRANSVERSE MERCATOR PROJECTION
!      PRECOMPUTATION OF CONSTANTS
!**** Programmed by T.	Vincenty, NGS, in July 1984.
!******************* SYMBOLS AND DEFINITIONS  **********************
!   ER is equatorial radius of the ellipsoid (=	major semiaxis).
!   RF is reciprocal of	flattening of the ellipsoid.
!   SF is scale	factor of the central meridian.
!   OR is southernmost parallel	of latitude (in	radians) for which
!     the northing coordinate is zero at the central meridian.
!   R, A, B, C,	U, V, W	are ellipsoid constants	used for computing
!     meridional distance from latitude	and vice versa.
!   SO is meridional distance (multiplied by the scale factor) from
!     the equator to the southernmost parallel of latitude.
!*****************************************************************
!
      F=1.D0/RF
      ESQ=(F+F-F**2)
      EPS=ESQ/(1.-ESQ)
      PR=(1.-F)*ER
      EN=(ER-PR)/(ER+PR)
      A=-1.5D0*EN + (9./16.)*EN**3
      B= 0.9375D0*EN**2	- (15./32.)*EN**4
      C=-(35./48.)*EN**3
      U=1.5D0*EN - (27./32.)*EN**3
      V=1.3125D0*EN**2 - (55./32.)*EN**4
      W=(151./96.)*EN**3
      R=ER*(1.-EN)*(1.-EN**2)*(1.+2.25D0*EN**2+(225./64.)*EN**4)
      OMO=OR + A*SIN(2.*OR) + B*SIN(4.*OR) + C*SIN(6.*OR)
      SO=SF*R*OMO
      RETURN
      END


      COMPLEX*16 FUNCTION B0D(Q2,MU2,M12,M22)
*     ---------------------------------------
* general B0D (subtracted functions); CalcPHEP group
*
      IMPLICIT NONE
      REAL*8 MU2,Q2,RBB,RTB,LNRBB,LNRTB,DREAL,DLOG,DRM12,DRM22
      COMPLEX*16 M12,M22,B0F,B0P,B0D1,B0D2,B0DP,B0DW,DCMPLX
      RETURN
*
      ENTRY B0D1(Q2,MU2,M12,M22)
*     --------------------------
      RTB=-Q2/DREAL(M22)
      IF(RTB.LE.1D-3) THEN
       LNRTB=DLOG(RTB)
       B0D=DCMPLX(LNRTB+1D0/2+RTB*(2D0*LNRTB+5D0/3)
     &            +RTB**2*(5D0*LNRTB+59D0/12)
     &            +RTB**3*(14D0*LNRTB+449D0/30)
     &            +RTB**4*(42D0*LNRTB+1417D0/30)
     &            +RTB**5*(132D0*LNRTB+16127D0/105),0D0)
      ELSE
       B0D=1D0/RTB*(B0F(Q2,MU2,M12,M22)+DLOG(DREAL(M22)/MU2)-1D0)
      ENDIF
      RETURN
*
      ENTRY B0D2(Q2,MU2,M12,M22)
*     --------------------------
      RTB=-Q2/DREAL(M22)
      IF(RTB.LE.1D-3) THEN
       LNRTB=DLOG(RTB)
       B0D=DCMPLX(2D0*LNRTB+5D0/3+RTB*(5D0*LNRTB+59D0/12)
     &            +RTB**2*(14D0*LNRTB+449D0/30)
     &            +RTB**3*(42D0*LNRTB+1417D0/30)
     &            +RTB**4*(132D0*LNRTB+16127D0/105)
     &            +RTB**5*(429D0*LNRTB+429697D0/840),0D0)
      ELSE
       B0D=1D0/RTB**2*(B0F(Q2,MU2,M12,M22)+DLOG(DREAL(M22)/MU2)-1D0
     &                 -RTB*(DLOG(DREAL(M12)/DREAL(M22))+1D0/2))
      ENDIF
      RETURN
*
      ENTRY B0DP(Q2,MU2,M12,M22)
*     --------------------------
      RTB=-Q2/DREAL(M22)
      IF(RTB.LE.1D-3) THEN
       LNRTB=DLOG(RTB)
       B0D=DCMPLX(-LNRTB-17D0/6-RTB*(7D0*LNRTB+133D0/12)
     &            -RTB**2*(31D0*LNRTB+2657D0/60)
     &            -RTB**3*(126D0*LNRTB+5231D0/30)
     &            -RTB**4*(498D0*LNRTB+142991D0/210)
     &            -RTB**5*(1947D0*LNRTB+2225231D0/840),0D0)
      ELSE
       B0D=1D0/RTB*((1D0+2D0*RTB)*DREAL(M22)*B0P(Q2,M12,M22)+1D0/2)
      ENDIF
      RETURN
*
      ENTRY B0DW(Q2,MU2,M12,M22)
*     --------------------------
      DRM12=DREAL(M12)
      DRM22=DREAL(M22)
      RTB=-Q2/DRM22
      RBB=DRM12/DRM22
      IF(RTB.LT.1D-3) THEN
       IF(RBB.NE.0D0.AND.RBB.LT.1D-3) THEN
        LNRBB=DLOG(RBB)
        B0D=DCMPLX(1D0/2+RBB+RBB**2+RBB**3+RBB**4
     &            +LNRBB*RBB*(1D0+2D0*RBB+3D0*RBB**2+4D0*RBB**3)
     &  +RTB*(1D0/6+13D0/6*RBB+37D0/6*RBB**2+73D0/6*RBB**3
     &            +LNRBB*RBB*(1D0+5D0*RBB+14D0*RBB**2))
     &  +RTB**2*(1D0/12+17D0/6*RBB+63D0/4*RBB**2
     &            +LNRBB*RBB*(1D0+9D0*RBB))
     &  +RTB**3*(1D0/20+199D0/60*RBB+LNRBB*RBB)
     &  +RTB**4*1D0/30,0D0)
       ELSEIF(RBB.EQ.0D0) THEN
        B0D=DCMPLX(1D0/2+1D0/6*RTB+1D0/12*RTB**2+1D0/20*RTB**3
     &                                          +1D0/30*RTB**4,0D0)
       ELSEIF(DRM12.GE.1D0) THEN
        B0D=1D0/RTB*(B0F(Q2,MU2,M12,M22)+DLOG(DREAL(M22)/MU2)-1D0)
       ELSE
        PRINT *,'RTB,BB=',RTB,RBB
        PRINT *,'1) Non-forseen situation with B0DW'
         STOP
       ENDIF
      ELSE
       IF(RBB.NE.0D0) THEN
        B0D=1D0/RTB*((1D0-RBB)*(B0F(Q2,MU2,M12,M22)
     &      +DLOG(DREAL(M22)/MU2)-1D0)-RBB*DLOG(DREAL(M12)/DREAL(M22)))
       ELSEIF(RBB.EQ.0D0) THEN
        B0D=1D0/RTB*(B0F(Q2,MU2,M12,M22)+DLOG(DREAL(M22)/MU2)-1D0)
       ELSE
        PRINT *,'RTB,BB=',RTB,RBB
        PRINT *,'2) Non-forseen situation with B0DW'
         STOP
       ENDIF
      ENDIF
      RETURN
*
      END


PROGRAM test_TP
!
      USE def_constants, ONLY: pr, T_cr,T_tri,P_cr,P_tri
!      USE def_variables
!      USE non_linear_solvers
      USE properties, ONLY: satprop
!      USE grid_functions
!      USE Grid
!      USE Interp_table
      USE saturation, ONLY: saturation_curve, sat_curve
      IMPLICIT NONE
!
      INTEGER :: i,j,NN
      REAL(pr), DIMENSION(600) :: p_tab
      REAL(pr) :: Terr,xerr
      REAL(pr) :: delta, Tsat, vvsat, vlsat, uvsat, ulsat
      REAL(pr) :: Tsat5, vvsat5, vlsat5, uvsat5, ulsat5
!
        CALL saturation_curve()
        CALL sat_curve()
!
      NN = 600
      delta = (P_cr - P_tri)/ (NN)
      p_tab = p_tri + (/(i*delta,i=0,NN-1)/)

      DO i = 1,600
           CALL satprop(3, p_tab(i), Tsat, vvsat, vlsat, uvsat, ulsat)
           CALL satprop(5, p_tab(i), Tsat5, vvsat5, vlsat5, uvsat5, ulsat5)
          IF ( (abs(Tsat-Tsat5)  > 1e-12_pr).OR.&
&              (abs(vvsat-vvsat5)> 1e-12_pr).OR.&
&              (abs(vlsat-vlsat5)> 1e-12_pr).OR.&
&              (abs(uvsat-uvsat5)> 1e-12_pr).OR.&
&              (abs(ulsat-ulsat5)> 1e-12_pr) ) THEN
           print*, 'i',i,'p', p_tab(i)
           print*, 'T', Tsat,Tsat5, abs(Tsat-Tsat5)
           print*, 'v-vapor', vvsat,vvsat5, abs(vvsat-vvsat5)
           print*, 'v-liquid', vlsat,vlsat5, abs(vlsat-vlsat5)
           print*, 'u-vapor', uvsat,uvsat5, abs(uvsat-uvsat5)
           print*, 'u-liquid', ulsat,ulsat5, abs(ulsat-ulsat5)
          ENDIF
!
      ENDDO
END PROGRAM test_TP


!>  Module containing general constants that can be used consistently
!!  throughout the program.
!!
!!  @author Nathan A. Wukie
!!  @date   2/1/2016
!!
!!  These include:
!!      - Mathematical constants (pi, e, etc.)
!!      - Floating-point values for numbers and fractions
!!          (to ensure the correct floating point precision is used consistently)
!!      - Integers for consistent indexing
!!
!-----------------------------------------------------------------------------------------
module mod_constants
    use mod_kinds, only: rk,ik,ishort
    implicit none

    !
    ! Floating-point mathematical constants
    !
    real(rk), parameter     :: PI       = 3.14159265358979323846_rk     !< Mathematical constant pi

    !
    ! Floating-point numbers
    !
    real(rk), parameter     :: ZERO     = 0._rk
    real(rk), parameter     :: ONE      = 1._rk
    real(rk), parameter     :: TWO      = 2._rk
    real(rk), parameter     :: THREE    = 3._rk
    real(rk), parameter     :: FOUR     = 4._rk
    real(rk), parameter     :: FIVE     = 5._rk
    real(rk), parameter     :: SIX      = 6._rk
    real(rk), parameter     :: SEVEN    = 7._rk
    real(rk), parameter     :: EIGHT    = 8._rk
    real(rk), parameter     :: NINE     = 9._rk
    real(rk), parameter     :: TEN      = 10._rk

    !
    ! Floating-point fractions
    !
    real(rk), parameter     :: HALF     = 0.5_rk
    real(rk), parameter     :: THIRD    = 1._rk/3._rk
    real(rk), parameter     :: FOURTH   = 0.25_rk
    real(rk), parameter     :: FIFTH    = 1._rk/5._rk
    real(rk), parameter     :: SIXTH    = 1._rk/6._rk
    real(rk), parameter     :: SEVENTH  = 1._rk/7._rk
    real(rk), parameter     :: EIGHTH   = 0.125_rk
    real(rk), parameter     :: NINTH    = 1._rk/9._rk
    real(rk), parameter     :: TENTH    = 0.1_rk

    real(rk), parameter     :: TWO_THR  = 2._rk/3._rk
    real(rk), parameter     :: THR_FIV  = 3._rk/5._rk

    !
    ! Constants for spatial definition
    !
    integer(ik), parameter :: ONE_DIM   = 1
    integer(ik), parameter :: TWO_DIM   = 2
    integer(ik), parameter :: THREE_DIM = 3
    integer(ik), parameter :: NFACES    = 6

    !
    ! Spatial direction
    !
    integer(ik), parameter :: DIR_1     = 1
    integer(ik), parameter :: DIR_2     = 2
    integer(ik), parameter :: DIR_3     = 3
    integer(ik), parameter :: DIR_X     = 1
    integer(ik), parameter :: DIR_Y     = 2
    integer(ik), parameter :: DIR_R     = 1
    integer(ik), parameter :: DIR_THETA = 2
    integer(ik), parameter :: DIR_Z     = 3

    integer(ik), parameter :: XI_DIR    = 1
    integer(ik), parameter :: ETA_DIR   = 2
    integer(ik), parameter :: ZETA_DIR  = 3

    !
    ! Indexing for faces directions and jacobian blocks
    !
    integer(ik), parameter :: NO_FACE   = 0
    integer(ik), parameter :: XI_MIN    = 1
    integer(ik), parameter :: XI_MAX    = 2
    integer(ik), parameter :: ETA_MIN   = 3
    integer(ik), parameter :: ETA_MAX   = 4
    integer(ik), parameter :: ZETA_MIN  = 5
    integer(ik), parameter :: ZETA_MAX  = 6
    integer(ik), parameter :: DIAG      = 7
    integer(ik), parameter :: NBLK      = 7     !< 6 neighbors, 1 self

    integer(ik), parameter :: BC_BLK    = -1

    !
    ! Coordinate systems
    !
    integer(ik), parameter :: CARTESIAN   = 1
    integer(ik), parameter :: CYLINDRICAL = 2

    !
    ! Face types. These should be distinct from the above 'face directions'
    ! Correspond to face_t%face_type
    !
    integer(ik), parameter :: INTERIOR   =  0     ! interior face
    integer(ik), parameter :: BOUNDARY   = -1     ! boundary condition type
    integer(ik), parameter :: CHIMERA    = -2     ! Chimera face
    integer(ik), parameter :: ORPHAN     = -3     ! orphan face - has no identity. Every face needs an identity.
    integer(ik), parameter :: NOT_A_FACE = -4     ! if chidg_worker is returning a face type without a face iface, could return NOT_A_FACE

    !
    ! Function types.
    !
    integer(ik), parameter :: BOUNDARY_ADVECTIVE_FLUX = 1
    integer(ik), parameter :: BOUNDARY_DIFFUSIVE_FLUX = 2
    integer(ik), parameter :: VOLUME_ADVECTIVE_FLUX   = 3
    integer(ik), parameter :: VOLUME_DIFFUSIVE_FLUX   = 4
    integer(ik), parameter :: VOLUME_ADVECTIVE_SOURCE = 5
    integer(ik), parameter :: VOLUME_DIFFUSIVE_SOURCE = 6
    integer(ik), parameter :: BC_FLUX = 7
    integer(ik), parameter :: NFUNCTION_TYPES = 6

    !
    ! NEIGHBOR STATUS
    !
    integer(ik), parameter :: NO_NEIGHBOR_FOUND    = 0
    integer(ik), parameter :: NEIGHBOR_FOUND       = 1
    integer(ik), parameter :: NO_INTERIOR_NEIGHBOR = 0       ! Face does not have an interior neighbor

    !
    ! Interpolation source
    !
    integer(ik), parameter :: ME       = 0          ! Interpolate from current element
    integer(ik), parameter :: NEIGHBOR = 1          ! Interpolate from neighbor element
    integer(ik), parameter :: BC       = 2          ! Interpolate from exterior BC state

    !
    ! Communication type
    !
    integer(ik), parameter :: LOCAL  = 2
    integer(ik), parameter :: REMOTE = 3

    !
    ! Boundary condition parameters
    !
    character(len=8),   parameter   :: REQUIRED = 'required'
    character(len=8),   parameter   :: OPTIONAL = 'optional'

    !
    ! point_t status
    !
    integer(ik), parameter :: VALID_POINT   = 0
    integer(ik), parameter :: INVALID_POINT = 1

    !
    ! QUADRATURE CONSTANTS: specify number of quadrature orders to initialize
    !
    integer(ik), parameter :: NGQ = 1

    !
    ! MPI and ID constants
    !
    integer(ik),    parameter   :: NO_PARTITION = -1
    integer(ik),    parameter   :: NO_PROC      = -2
    integer(ik),    parameter   :: NO_ID        = -1

    !
    ! IO constants
    !
    integer(ik),   parameter    :: MAXBLOCKS        = 200
    character(6)                :: IO_DESTINATION   = 'both'
    integer(ik)                 :: OUTPUT_RES       = 5

    !
    ! Cache Parameters
    !
    integer(ik),    parameter   :: CACHE_FACE_INTERIOR = 1
    integer(ik),    parameter   :: CACHE_FACE_EXTERIOR = 2

    !
    !
    !
    real(rk),   parameter :: RKTOL = 20._rk * epsilon(1._rk)    ! Real-Kind Tolerance. Floating-point tolerance, one order of magnitude larger than machine precision.

    integer(ik),    parameter   :: NO_EQUATION_SET = 0

    !
    !   Prescribed mesh Motion
    !

    integer(ik), parameter         :: NO_PMM_ASSIGNED = -1
end module mod_constants


************************************************************************
*                           COEFF.FOR                                  *
*                                                                      *
*  PROGRAM: SIMRAND I                                                  *
*  MODULE:  1.4                                                        *
*  DATE:    12/05/84                                                   *
*                                                                      *
*  THIS IS THE SUBROUTINE COEFF.  IT CALCULATES THE CDF COEFFICENTS,   *
*  THE UTILITY FUNCTION COEFFICIENTS, AND THE CERTAINTY EQUIVALENT     *
*  COEFFICIENTS FROM THE INPUT DATA.                                   *
*                                                                      *
*----------------------------------------------------------------------*
*                          CONFIGURATION CHANGES                       *
*                                                                      *
*    DATE                       CHANGE                                 *
*                                                                      *
*  12/05/85  * ORIGINAL.                                               *
*                                                                      *
************************************************************************

$TITLE:'COEFF.LST'
$DEBUG
$NOFLOATCALLS
$STORAGE:2

************************************************************************

      SUBROUTINE COEFF

************************************************************************

***** INITIALIZE.  {MODULE 1}

$INCLUDE:'INITIAL.FOR'

      IF (JDIAG .NE. 0) THEN
         WRITE (*,100)
100      FORMAT (/1X,'ENTER SUBROUTINE COEFF')
      ENDIF

***   {END MODULE 1}

****C CALCULATE TASK VARIABLE COEFFICIENTS TCOEF(IT,IC).  {MODULE 2}

*     CALCULATE TCOEF(IT,IC) & TCOEF(IT,IC+1)
*     FOR VARMTX(IA,IX) = TCOEF(IT,IC)*RANMTX(IA,IX) + TCOEF(IT,IC+1)

      NICC = NIC - 1
      DO 130 IT=1,NIT
         DO 130 IC=1,NICC,2

            V1 = TDATA(IT,IC+2)
            V2 = TDATA(IT,IC+4)
            F1 = TDATA(IT,IC+3)
            F2 = TDATA(IT,IC+5)

            IF (F2 .EQ. F1) THEN
               TCOEF(IT,IC)   = 0.0
               TCOEF(IT,IC+1) = 0.0
            ELSE
               TCOEF(IT,IC)   = (V2-V1)/(F2-F1)
               TCOEF(IT,IC+1) = V1 - F1*TCOEF(IT,IC)
            ENDIF

130   CONTINUE

***   {END MODULE 2}

***** START (II,IC) DO LOOP TO CALCULATE UTILITY FUNCTION AND
***** CERTAINTY EQUIVALENT COEFFICIENTS.  {MODULE 3}

      NIUU = NIU - 2
      DO 170 II=1,NII
         DO 170 IC=1,NIUU,2

*****       CALCULATE UTILITY FUNCTION COEFFICIENTS.  {MODULE 4}

*           CALCULATE UCOEF(II,IC) & UCOEF(II,IC+1)
*           FOR UTIL(II) = UCOEF(II,IC)*PMIN(NIP) + UCOEF(II,IC+1)

            V1 = UDATA(II,IC)
            V2 = UDATA(II,IC+2)
            F1 = UDATA(II,IC+1)
            F2 = UDATA(II,IC+3)

            IF (V1 .EQ. V2) THEN
               UCOEF(II,IC)   = 0.0
               UCOEF(II,IC+1) = 0.0
            ELSE
               UCOEF(II,IC)   = (F2 - F1)/(V2 - V1)
               UCOEF(II,IC+1) = F1 - V1*UCOEF(II,IC)
            ENDIF

***         {END MODULE 4}

*****       CALCULATE CERTAINTY EQUIVALENT COEFFICIENTS.  {MODULE 5}

*           CALCULATE CECOEF(II,IC) & CECOEF(II,IC+1)
*           FOR CERTEQ(II) = CECOEF(II,IC)*RUTIL(II) + CECOEF(II,IC+1)

            IF (UCOEF(II,IC) .EQ. 0.0) THEN
               CECOEF(II,IC)   = 0.0
               CECOEF(II,IC+1) = 0.0
            ELSE
               CECOEF(II,IC)   =               1/UCOEF(II,IC)
               CECOEF(II,IC+1) = -UCOEF(II,IC+1)/UCOEF(II,IC)
            ENDIF

***         {END MODULE 5}

170   CONTINUE

***   {END MODULE 3}

***** WRITE TASK VARIABLE COEFFICIENTS TCOEF(IT,IC).  {MODULE 6}

      IF (JDIAG .EQ. 2) THEN

         WRITE (*,*)  'TASK VARIABLE COEFFICIENTS TCOEF(IT,IC)'

         DO 200 IT=1,NIT

            IF (NIC .EQ. 4) THEN
               WRITE  (*,180) IT,(TCOEF(IT,IC),IC=1,NIC)
            ELSE
               WRITE  (*,180) IT,(TCOEF(IT,IC),IC=1,4)
               WRITE  (*,190)    (TCOEF(IT,IC),IC=5,NIC)
            ENDIF

180         FORMAT (1X,I5,3X,1P4E14.4)
190         FORMAT (1X,   8X,1P4E14.4)

200      CONTINUE

      ENDIF

***   {END MODULE 6}

***** WRITE UTILITY FUNCTION COEFFICENTS UCOEF(II,IC).  {MODULE 7}

      IF (JDIAG .EQ. 2) THEN

         WRITE  (*,*) 'UTILITY FUNCTION COEFFICIENTS UCOEF(II,IC)'

         DO 210 II=1,NII

            IF (NIC .EQ. 4) THEN
               WRITE  (*,180) II,(UCOEF(II,IC),IC=1,NIU)
            ELSE
               WRITE  (*,180) II,(UCOEF(II,IC),IC=1,4)
               WRITE  (*,190)    (UCOEF(II,IC),IC=5,NIU)
            ENDIF

210      CONTINUE

      ENDIF

***   {END MODULE 7}

***** WRITE CERTAINTY EQUIVALENT COEFFICIENTS CECOEF(II,IC).  {MODULE 8}

      IF (JDIAG .EQ. 2) THEN

         WRITE  (*,*) 'CERTAINTY EQUIVALENT COEFFICIENTS CECOEF(II,IC)'

         DO 220 II=1,NII

            IF (NIC .EQ. 4) THEN
               WRITE  (*,180) II,(CECOEF(II,IC),IC=1,NIU)
            ELSE
               WRITE  (*,180) II,(CECOEF(II,IC),IC=1,4)
               WRITE  (*,190)    (CECOEF(II,IC),IC=5,NIU)
            ENDIF

220      CONTINUE

      ENDIF

***   {END MODULE 8}

***** EXIT SUBROUTINE COEFF.  {MODULE 9}

      IF (JDIAG .NE. 0) THEN
         WRITE (*,999)
999      FORMAT (1X,'EXIT  SUBROUTINE COEFF')
      ENDIF

      RETURN

      END

***  {END MODULE 9}

************************** COEFF.FOR **********************************C


C NCLFORTSTART
      SUBROUTINE dgeevxint(BALANC,JOBVL,JOBVR,SENSE,N,A,EVLR,WR,WI,
     +                     OPT,WORK,IWORK,SCALEM,RCONDE,RCONDV,VL,VR,
     +                     LWORK,LIWORK)
      IMPLICIT NONE
c                                                      input
      INTEGER           N, OPT
      CHARACTER*(*)     BALANC, JOBVL, JOBVR, SENSE
ccccc CHARACTER*1       BALANC, JOBVL, JOBVR, SENSE
c                                                      input and output
      DOUBLE PRECISION  A(N,N)
c                                                      output
c                                                      (:,:,real/imag,
c                                                           left/right)
      DOUBLE PRECISION  WR(N), WI(N), EVLR(N,N,2,2)
c
c     These are work arrays originally created by Fortran routine.
c     LWORK should be N*(N+6)
c     LIWORK should be 2*N-1
c
      INTEGER          LWORK,LIWORK
      DOUBLE PRECISION SCALEM(N), RCONDE(N), RCONDV(N)
      DOUBLE PRECISION VL(N,N), VR(N,N)
      DOUBLE PRECISION WORK(LWORK)
      INTEGER          IWORK(LIWORK)
C NCLEND
C --------------------------------------------------------------------------------
C                                                      local dynamically allocated
      INTEGER LDA, ILO, IHI, INFO, I, J
     +      , LDVR, LDVL, K , KP1
C    +      , LDVR, LDVL, LWORK, LIWORK, K , KP1
      DOUBLE PRECISION ABNRM

C just for consistency with LAPACK description   (make large)
      LDA     = N
      LDVR    = N
      LDVL    = N
      INFO    = 0
C These are passed in above.
C     LWORK   = N*(N+6)
C     LIWORK  = 2*N-1

      CALL DGEEVX( BALANC, JOBVL, JOBVR, SENSE, N, A, LDA, WR, WI,
     &             VL, LDVL, VR, LDVR, ILO, IHI, SCALEM, ABNRM,
     &             RCONDE, RCONDV, WORK, LWORK, IWORK, INFO )

c
c This is the array returned to NCL | the WR & WI as attributes.
c
      k = 0
      do j=1,N
         k = k+1
         if (wi(j).eq.0.0d0) then     !   not a complex conjugate
             do i=1,N
                EVLR(i,k,1,1) = VL(i,j)
                EVLR(i,k,2,1) = 0.0d0
                EVLR(i,k,1,2) = VR(i,j)
                EVLR(i,k,2,2) = 0.0d0
             end do
         else if (WR(J).eq.WR(J+1) .and. WI(J).eq.-(WI(J+1))) then  ! conjugate
              kp1 = k+1
              do i=1,N
                 EVLR(i,k  ,1,1) =   VL(i,j)
                 EVLR(i,k  ,2,1) =   VL(i,j+1)
                 EVLR(i,k  ,1,2) =   VR(i,j)
                 EVLR(i,k  ,2,2) =   VR(i,j+1)

                 EVLR(i,kp1,1,1) =   VL(i,j)
                 EVLR(i,kp1,2,1) = -(VL(i,j+1))
                 EVLR(i,kp1,1,2) =   VR(i,j)
                 EVLR(i,kp1,2,2) = -(VR(i,j+1))
              end do
              k = kp1-1
         end if
      end do

      return
      end


c==============================================================================
      real function psr_ne(x, y, z, dmod, ip, lip)
c==============================================================================
c
c     General function to compute the local electron
c     density given the Cartesian coords (x,y,z)
c     in the Galaxy wrt the Galactic centre (0,0,0)
c     in pc/cc for various distance models which are
c     specified by the integer mod. Options for mod
c     are as follows...
c
c                        mod = 0  : LMT model
c                              1  : BWHV model
c                              2  : CWFSR model
c                              3  : TC93 model
c                              4  : NE2001 model
c                              5  : NE=0.03 model
c                              6  : GBC01 model
c
      implicit none
      real rsun
      parameter (rsun = 8.5)
c
c     passed down variables...
c
      real x, y, z
      integer dmod
c
c     local variables
c
      real ne1,ne2,nea,negc,nelism,necN,nevN
      real F1, F2, Fa, Fgc, Flism, FcN, FvN
      integer whicharm,wlism,wLDR,wLHB,wLSB,wLOOPI,hitclump,hitvoid
      integer wvoid,lout
      real negum,a
      real lgn, bgn, dgn, rgn
      logical first
      character ip*(*)
      integer lip
      data first /.true./
      data lgn/260.0/,bgn/0.0/,dgn/0.5/,rgn/0.115/
      real xgn, ygn, zgn, alpha, psr_dist, r, sech2
      common /outputtxt/ lout
      if (first) then
c
c       Calc Position of the Gum nebula
c
        call calc_xyz(lgn,bgn,dgn,xgn,ygn,zgn)
c        if (dmod.eq.0) write(lout,*) 'LMT distance model'
c        if (dmod.eq.1) write(lout,*) 'BWHV distance model'
c        if (dmod.eq.2) write(lout,*) 'CWFSR distance model'
c        if (dmod.eq.3) write(lout,*) 'TC93 distance model'
c        if (dmod.eq.4) write(lout,*) 'NE2001 distance model'
c        if (dmod.eq.5) write(lout,*) 'NE0.03 distance model'
c        if (dmod.eq.6) write(lout,*) 'GBC01 distance model'
	write(lout,*)
        first = .false.
      end if
c
c     Does the line of sight to the pulsar pass
c     through the Gum nebula if so set alpha to
c     1, to take into account the extra cont
c     ribution to n_{e} from this nearby
c     H II region. LMT parameters Dgn=0.5kpc
c     lgn=260, bgn=0, radius=0.115kpc
c
c      if (sqrt((x-xgn)**2.0+(y-ygn)**2.0).lt.rgn) then
      if (psr_dist(x,y,z,xgn,ygn,zgn).lt.rgn) then
        alpha = 1.0
      else
        alpha = 0.0
      end if
      alpha=0.0
c
c     Galactocentric radius
c
      R = sqrt((x ** 2) + (y ** 2))
      if (dmod.eq.0) then
c
c       Calculate n_{e} according to LMT formula
c
        psr_ne = (0.28 * alpha) + ((((0.025 + (0.015 *
     &  exp(- (1.0 * abs(z / 0.070))))) *
     &  (2.0 / (1.0 + (R / rsun))) )))
      else if (dmod.eq.1) then
c
c       Calculate n_{e} according to Bhattacharya et al formula
c
        psr_ne = (0.28 * alpha) + (((( (0.0294*exp(- (1.0 *
     &  abs(z / 0.68)))) + (0.0176 * exp(- (1.0 *
     &  abs(z / 0.070))))) * (2.0 / (1.0 + (R / rsun))))) )
      else if (dmod.eq.2) then
c
c       Calculate n_{e} according to Cordes et al formula
c       DRL added extra Gum nebula term onto published model
c       25/03/93 @ JB
c
        psr_ne = 0.025*exp(-1.0*abs(z))*exp(-1.0*(R**2/400.0)) +
     &  0.2*exp(-1.0*abs(z/0.15))*exp(-1.0*((R-4.0)**2/4.0)) +
     &  (0.28*alpha)
      else if (dmod.eq.3) then
         call density(x,y,z,ne1,ne2,nea,negum,ip,lip)
         psr_ne=ne1+ne2+nea+negum
      else if (dmod.eq.4) then
          write(*,*) "made it into psr_ne.f"
            call density_2001(x,y,z,
     .                ne1,ne2,nea,negc,nelism,necN,nevN,
     .                F1, F2, Fa, Fgc, Flism, FcN, FvN,
     .                whicharm, wlism, wLDR, wLHB, wLSB, wLOOPI,
     .                hitclump, hitvoid, wvoid)
            psr_ne=ne1+ne2+nea+negc+nelism+necN+nevN
      else if (dmod.eq.5) then
c
c     Constant electron density model
c
         psr_ne = 0.03
      else if (dmod.eq.6) then
c
c       Calculate n_{e} according to Gomez et al
c
         psr_ne = 1.77e-2*sech2(R/15.4)*sech2(z/1.10)/sech2(Rsun/15.4)+
     &           1.07e-2*sech2(R/3.6)*sech2(z/0.04)/sech2(Rsun/3.6)
c         a = abs(z)
c         psr_ne =.0203*exp(-1.0*R/30.4)*exp(Rsun/30.4)*exp(-1.0*a/1.07)+
c     &           .0071*exp(-1.0*R/1.5)*exp(Rsun/1.5)*exp(-1.0*a/0.05)
      else
        stop 'Distance model undefined!!!'
      end if
      end


SUBROUTINE calc_tidal_tensor(ielement, tidal)
!
! Subroutine calculates tidal tensor for element ielement
! Tensor is scaled by its potential
!

  use sphdata
  use sphneighbourdata
  use sphkerneldata

  real, dimension(3,3) :: tidal

  integer :: ielement, j,k, imat, jmat

  real, dimension(3) :: dr

  do k = 1, nneigh(ielement)

     j = neighb(ielement,k)

     ! Calculate gradient of SPH kernel
     hmean = 0.5*(xyzmh(5,ielement) + xyzmh(5,j))
     hmean21 = 1./(hmean*hmean)
     hmean41 = hmean21*hmean21
     pmassj = xyzmh(4,j)
     rhoj = rho(j)

     ! Separation of particles
     do jmat = 1,3
        dr(jmat) = xyzmh(jmat,ielement) - xyzmh(jmat,j)
     enddo

     rij2 = dr(1)*dr(1) + dr(2)*dr(2) + dr(3)*dr(3)

     v2 = rij2*hmean21
     v = rij/hmean

     index = v2/dvtable

     if(index<1) index=1

     dxx = v2 - index*dvtable
     index1 = index + 1

     IF (index1.GT.itable) then
        index = itable-1
        index1 = itable
     endif

     IF(index1 < 1 .or. index<1) THEN
        print*, j,ielement, index, itable, rij2, v2,dvtable, v2/dvtable, index1
     endif
     IF (v > radkernel) cycle

     dgrwdx = (grwij(index1) - grwij(index))/dvtable
     grwtij = (grwij(index) + dgrwdx*dxx)*hmean41
     grpm = pmassj*grwtij

     ! Loops for matrix elements i,j
     do imat = 1,3
        do jmat = 1,3
           tidal(imat,jmat) = tidal(imat,jmat) - grpm*dr(imat)*gravxyz(jmat,j)/rhoj
        enddo
     enddo
     ! End of matrix loop
  enddo
  ! End of loop over nearest neighbours

  ! Tensor should be dimensionless - scale using potential and smoothing length
  tidal(:,:) = tidal(:,:)*xyzmh(5,ielement)*xyzmh(5,ielement)/abs(poten(ielement))

return
END SUBROUTINE calc_tidal_tensor


      SUBROUTINE CNMN08 (NDB,NER,C,MS1,B,N3,N4,N5)
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
      DIMENSION C(N4), B(N3,N3), MS1(N5)
C     ROUTINE TO SOLVE SPECIAL LINEAR PROBLEM FOR IMPOSING S-TRANSPOSE
C     TIMES S.LE.1 BOUNDS IN THE MODIFIED METHOD OF FEASIBLE DIRECTIONS.
C     BY G. N. VANDERPLAATS                             APRIL, 1972.
C     NASA-AMES RESEARCH CENTER,  MOFFETT FIELD, CALIF.
C     REF.  'STRUCTURAL OPTIMIZATION BY METHODS OF FEASIBLE DIRECTIONS',
C     G. N. VANDERPLAATS AND F. MOSES, JOURNAL OF COMPUTERS
C     AND STRUCTURES, VOL 3, PP 739-755, 1973.
C     FORM OF L. P. IS BX=C WHERE 1ST NDB COMPONENTS OF X CONTAIN VECTOR
C     U AND LAST NDB COMPONENTS CONTAIN VECTOR V.  CONSTRAINTS ARE
C     U.GE.0, V.GE.0, AND U-TRANSPOSE TIMES V = 0.
C     NER = ERROR FLAG.  IF NER.NE.0 ON RETURN, PROCESS HAS NOT
C     CONVERGED IN 5*NDB ITERATIONS.
C     VECTOR MS1 IDENTIFIES THE SET OF BASIC VARIABLES.
C     ------------------------------------------------------------------
C     CHOOSE INITIAL BASIC VARIABLES AS V, AND INITIALIZE VECTOR MS1
C     ------------------------------------------------------------------
      NER=1
      M2=2*NDB
C     CALCULATE CBMIN AND EPS AND INITIALIZE MS1.
      EPS=-1.0E+10
      CBMIN=0.
      DO 10 I=1,NDB
      BI=B(I,I)
      CBMAX=0.
      IF (BI.LT.-1.0E-6) CBMAX=C(I)/BI
      IF (BI.GT.EPS) EPS=BI
      IF (CBMAX.GT.CBMIN) CBMIN=CBMAX
10    MS1(I)=0
      EPS=.0001*EPS
C     IF (EPS.LT.-1.0E-10) EPS=-1.0E-10
C
C  E-10 CHANGED TO E-03 ON 1/12/81
C
      IF (EPS.LT.-1.0E-03) EPS=-1.0E-03
      IF (EPS.GT.-.0001) EPS=-.0001
      CBMIN=CBMIN*1.0E-6
C     IF (CBMIN.LT.1.0E-10) CBMIN=1.0E-10
C
C  E-10 CHANGED TO E-05 ON 1/12/81
C
      IF (CBMIN.LT.1.0E-05) CBMIN=1.0E-05
      ITER1=0
      NMAX=5*NDB
C     ------------------------------------------------------------------
C     **********             BEGIN NEW ITERATION              **********
C     ------------------------------------------------------------------
20    ITER1=ITER1+1
      IF (ITER1.GT.NMAX) RETURN
C     FIND MAX. C(I)/B(I,I) FOR I=1,NDB.
      CBMAX=.9*CBMIN
      ICHK=0
      DO 30 I=1,NDB
      C1=C(I)
      BI=B(I,I)
C     IF (BI.GT.EPS.OR.C1.GT.0.) GO TO 30
      IF (BI.GT.EPS.OR.C1.GT.-1.0E-05) GO TO 30
C
C  0. CHANGED TO -1.0E-05 ON 1/12/81
C
      CB=C1/BI
      IF (CB.LE.CBMAX) GO TO 30
      ICHK=I
      CBMAX=CB
30    CONTINUE
      IF (CBMAX.LT.CBMIN) GO TO 70
      IF (ICHK.EQ.0) GO TO 70
C     UPDATE VECTOR MS1.
      JJ=ICHK
      IF (MS1(JJ).EQ.0) JJ=ICHK+NDB
      KK=JJ+NDB
      IF (KK.GT.M2) KK=JJ-NDB
      MS1(KK)=ICHK
      MS1(JJ)=0
C     ------------------------------------------------------------------
C                     PIVOT OF B(ICHK,ICHK)
C     ------------------------------------------------------------------
      BB=1./B(ICHK,ICHK)
      DO 40 J=1,NDB
40    B(ICHK,J)=BB*B(ICHK,J)
      C(ICHK)=CBMAX
      B(ICHK,ICHK)=BB
C     ELIMINATE COEFICIENTS ON VARIABLE ENTERING BASIS AND STORE
C     COEFICIENTS ON VARIABLE LEAVING BASIS IN THEIR PLACE.
      DO 60 I=1,NDB
      IF (I.EQ.ICHK) GO TO 60
      BB1=B(I,ICHK)
      B(I,ICHK)=0.
      DO 50 J=1,NDB
50    B(I,J)=B(I,J)-BB1*B(ICHK,J)
      C(I)=C(I)-BB1*CBMAX
60    CONTINUE
      GO TO 20
70    CONTINUE
      NER=0
C     ------------------------------------------------------------------
C     STORE ONLY COMPONENTS OF U-VECTOR IN 'C'.  USE B(I,1) FOR
C     TEMPORARY STORAGE
C     ------------------------------------------------------------------
      DO 80 I=1,NDB
      B(I,1)=C(I)
80    CONTINUE
      DO 90 I=1,NDB
      C(I)=0.
      J=MS1(I)
      IF (J.GT.0) C(I)=B(J,1)
      IF (C(I).LT.0.) C(I)=0.
90    CONTINUE
      RETURN
      END


! For NCL graphics:
! WRAPIT -m64 calc_uh90.stub calc_uh.f90
! This should create a shared library named "calc_uh90.so".

!##################################################################
!##################################################################
!######                                                      ######
!######                  SUBROUTINE CALC_UH                  ######
!######                                                      ######
!######                     Developed by                     ######
!######     Center for Analysis and Prediction of Storms     ######
!######                University of Oklahoma                ######
!######                                                      ######
!##################################################################
!##################################################################
!
!  Calculates updraft helicity (UH) to detect rotating updrafts.
!  Formula follows Kain et al, 2008, Wea. and Forecasting, 931-952,
!  but this version has controls for the limits of integration
!  uhminhgt to uhmxhgt, in m AGL.  Kain et al used 2000 to 5000 m.
!  Units of UH are m^2/s^2.
!
!  Note here that us and vs are at ARPS scalar points.
!  w is at w-point (scalar pt in horiz, staggered vertical)
!
!  Keith Brewster, CAPS/Univ. of Oklahoma
!  March, 2010
!
!   uh = wrf_updraft_helicity(zp,us,vs,w,
SUBROUTINE dcalcuh(nx,ny,nz,nzp1,zp,mapfct,dx,dy,uhmnhgt,uhmxhgt,        &
                   us,vs,w,uh,tem1,tem2)
  IMPLICIT NONE
  INTEGER, INTENT(IN) :: nx,ny,nz,nzp1
  DOUBLE PRECISION, INTENT(IN)  :: zp(nx,ny,nzp1)
  DOUBLE PRECISION, INTENT(IN)  :: mapfct(nx,ny)
  DOUBLE PRECISION, INTENT(IN)  :: dx,dy
  DOUBLE PRECISION, INTENT(IN)  :: uhmnhgt,uhmxhgt
  DOUBLE PRECISION, INTENT(IN)  :: us(nx,ny,nz)
  DOUBLE PRECISION, INTENT(IN)  :: vs(nx,ny,nz)
  DOUBLE PRECISION, INTENT(IN)  :: w(nx,ny,nzp1)
  DOUBLE PRECISION, INTENT(OUT) :: uh(nx,ny)
  DOUBLE PRECISION, INTENT(OUT) :: tem1(nx,ny,nz)
  DOUBLE PRECISION, INTENT(OUT) :: tem2(nx,ny,nz)
!
! Misc local variables
!
  INTEGER :: i,j,k,kbot,ktop
  DOUBLE PRECISION    :: twodx,twody,wgtlw,sum,wmean,wsum,wavg
  DOUBLE PRECISION    :: helbot,heltop,wbot,wtop
  DOUBLE PRECISION    :: 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 dcalcuh