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