subroutine arpgrid  1,2
	use kvar
	implicit none
	integer nz
	real(mrl) z0,z1,z2
	real(mrl), allocatable, dimension(:) :: ztemp,dzk
	nz=nu+3
	allocate(ztemp(nz),dzk(nz))
	z0=0.
	z1=dlayer1
	z2=min(ztop,z1+dlayer2)
        call STRHGRD(nz,strhopt,z0,z1,z2,ztop,& 
	dzmin,strhtune,ztemp,dzk)
	do n=1,nf
	zf(n)=ztemp(n+1)
	write (*,'(f9.1)') zf(n)
	end do
	end subroutine arpgrid


      SUBROUTINE STRHGRD(nz,strhopt,z0,z1,z2,ztop,dzmin,strhtune, z,dzk)  1,1
	use kvar, only : mrl
      implicit none

      integer nz
      integer strhopt 
      real(mrl) z0
      real(mrl) z1
      real(mrl) z2
      real(mrl) ztop
      real(mrl) dzmin
      real(mrl) strhtune

      real(mrl) z   (nz)
      real(mrl) dzk (nz)

      real(mrl) rnzh,dzm
      real(mrl) a,b,c,hnew,zkmid,dzu
      integer nzh,nzl,k
      real(mrl) dz

      IF( (z1-z0).eq.(nz-3)*dzmin.and.(z1-z0).eq.(ztop-z0) ) THEN 

        dz = (ztop-z0)/(nz-3)
        DO 10 k=1,nz-1
          dzk(k)= dz 
10      CONTINUE
        DO 20 k=1,nz
          z(k)=z0 + (k-2) * dz 
20      CONTINUE

        write(6,'(/1x,a,f13.3,/a,f13.3)')&
       'Layer 1 depth was as deep as the entire domain. i',&
       'A uniform vertical grid is assumed with dz=',dz,&
       ' over the model depth of ',ztop-z0

        RETURN

      ENDIF

      IF(z1.lt.z0) z1 = z0
      IF(z2.gt.ztop) z2 = ztop 

      nzl = (z1-z0)/dzmin

      IF( (z1-z0).ge.(nz-3)*dzmin ) THEN
        write(6,'(/1x,a,f13.3,/a,f13.3,a,a)')&
       'Can not setup a vertical grid with uniform dz=',dzmin,&
       ' over the depth of ',z1-z0,' please specify a smaller',&
       ' value of dlayer1 '
        STOP 
      ENDIF 

      IF( z2.ge.ztop ) then 
        dzm = (ztop-z0-nzl*dzmin)/(nz-3-nzl)
!       print*, nzl*dzmin + (nz-3-nzl)*dzm
        nzh = 0
        dzu = 2*dzm - dzmin
      ELSE 
        a = 2*(nz-3-nzl)
        b = 2*z0-ztop-z2-(nz-3-3*nzl)*dzmin
        c = dzmin*(z2-z0-nzl*dzmin)
        dzm = (-b + sqrt(b*b-4*a*c) )/(2*a)

        rnzh = (ztop-z2)/(2*dzm-dzmin)
        nzh = int(rnzh)
       
        hnew = nzl*dzmin + nzh*(2*dzm-dzmin) +& 
             (nz-3-nzl-nzh)*dzm + z0

        IF( nzh.ne.0 ) THEN
          dzu = (2*dzm-dzmin) + (ztop-hnew)/nzh
        ELSEIF( nz-3-nzl-nzh .ne. 0 ) THEN
          dzm = dzm + (ztop-hnew)/(nz-3-nzl-nzh)
          dzu = (2*dzm-dzmin) 
        ENDIF

       ENDIF 

      DO 100 k=1,nzl+1 
        dzk(k)=dzmin
100   CONTINUE


      IF( strhopt.eq.1 ) THEN

        a   = (dzm-dzmin)
        DO 150 k=nzl+2,nz-2-nzh
          dzk(k)= dzm+a* &
        ((2.0*float(k-nzl-2)/float(nz-4-nzh-nzl)-1.0) )**3
150     CONTINUE


      ELSE

        zkmid=0.5*float( nz-nzh+nzl)

        IF( nzl+2-zkmid.eq.0.0 ) THEN
          b = 0.0
        ELSE
          b= strhtune* 2.0/(nzl+2-zkmid)
        ENDIF

        a=(dzmin-dzm)/tanh( strhtune* 2.0)

        DO 200 k=nzl+2,nz-2-nzh
          dzk(k)=dzm + a*tanh(b*(float(k)-zkmid))
200     CONTINUE

      ENDIF

      DO 300 k=nz-2-nzh+1, nz-2
        dzk(k)= dzu
300   CONTINUE

      dzk(nz-1) = dzk(nz-2)
      dzk(nz  ) = dzk(nz-1)


      z(2) = z0
      do 400 k=3,nz-1
        z(k) = z(k-1)+dzk(k-1)
400   CONTINUE
   
      z(1) =z(2)-dzk(1)
      z(nz-1)=ztop
      z(nz)=z(nz-1)+dzk(nz-1)

      RETURN
      END