module blgridmod 1
contains


subroutine blgrid(zdef,zb,z,hite1,hite2,hite3,& 1,6
	hite4,sqi,aq,alf,beta)
use precis
implicit none
integer nf,nu,n
real(mrl) :: zdef(:),zb(:),z(:)
real(mrl) sq,sum2,sum3,as,alf,hite2,hite3,hite4,hite1
real(mrl) sqi,rat,aq,beta,hitem,sum,dum,dun,gmin,fmax,blend23,blend34
real(mrl) F_hump,F_tk
real(mrl), allocatable :: dz(:),f(:),g(:),dzdef(:),dzb(:),dum2(:)

nf=size(z)
nu=nf-1

!if boundary layer too shallow, return default nocturnal grid
if (hite3.le.zdef(1)+hite1) then !return nocturnal grid 
	do n=1,nf
		z(n)=zdef(n) 
	end do
	return
end if

!first stage: expand nocturnal boundary layer grid upward
allocate (dz(nu),f(nu),g(nu),dzdef(nu),dzb(nu),dum2(nf))
blend23=alf/(hite3-hite2)
blend34=beta/1000.
rat=min(hite1/(1.+hite3-zdef(1)-hite1),1._mrl) !expansion turns on as rat -> 0
hitem=.5*(hite3+hite2) !midpoint of 'cloud'
do n=1,nu
	dzdef(n)=zdef(n+1)-zdef(n)
end do
do n=1,nu
	dzb(n)=dzdef(n)
end do
do n=1,nf
	zb(n)=zdef(n)
end do
sum=0
sum2=0
do n=1,nu
	dum=max(F_tk(blend34*(z(n)-hite4)),&
		2*F_tk((-zdef(n)+zdef(1))/hite1))
	dum=rat+(1-rat)*dum !turns on expansion gradually
	dum2(n)=(1-dum)
	dzb(n)=dzb(n)*dum
	sum=sum+dzb(n)	
	sum2=sum2+dum2(n)
end do
dun=0
if (sum2.ne.0.) dun=(zb(nf)-sum-zb(1))/sum2
do n=1,nu
	dzb(n)=dzb(n)+dun*dum2(n)
end do
do n=nf-1,2,-1
	zb(n)=zb(n+1)-dzb(n)
end do
zb(1)=zdef(1)

!second stage: cloud contraction zone
rat=1.
if (hite3.gt.hite2.and.hite2.gt.zdef(1))&
	rat=min((hite3-hite2)/(hite3-zdef(1)),.5_mrl)/.5
sq=rat**2+(1-rat**2)*sqi !turn on gradually as sufficient sub-cloud zone
!sq=sqi
!becomes available
if (sq.lt.0.999) then !squeeze grid at top of PBL
!print *, 'sq=',sq,'  rat=',rat,'  sqi=',sqi
	do n=1,nu
		f(n)=F_hump((z(n)-z(1))/(hite2-z(1)))
		if (z(n).le.hitem) then
			g(n)=(-1+aq)*F_tk(blend23*(z(n)-hite2))
		else
			g(n)=(-1+aq)*F_tk(blend23*(hite3-z(n)))
		end if
	end do
	sum2=0
	sum3=0
	do n=1,nu
		sum2=sum2+f(n)*dzb(n)
		sum3=sum3+g(n)*dzb(n)
	end do
	as=-sum3/sum2
	gmin=minval(g)
	fmax=maxval(f)
	aq=aq+.25*(sq-(1+gmin)/(1+as*fmax))
	do n=1,nu
		dz(n)=dzb(n)*(1+as*f(n)+g(n))
	end do
else ! use result from first stage, with no cloud contraction
	do n=1,nu
		dz(n)=dzb(n)
	end do
end if
! reconstuct z for return
do n=2,nf-1
	z(n)=z(n-1)+dz(n-1)
end do
deallocate (dz,f,g,dzdef,dzb,dum2)
return 
end subroutine blgrid

end module blgridmod


subroutine  noct_grid(zdef,nf,shrink,nexp)
real zdef(nf),shrink
integer n,nf,nexp
do n=2,nf-1
	zdef(n)=zfunc(n,nf,zdef(1),zdef(nf),shrink,nexp)
end do
end subroutine noct_grid


function zfunc(n,nf,zb,zt,shrink,nexp)
real zfunc,dum,zb,zt,shrink
integer nexp,n,nf
dum=(n-1.)/(nf-1.)
zfunc = zb + (zt-zb)*(shrink*dum+(2-shrink)*dum**(nexp+1))/(1+dum**nexp)
return
end function zfunc



function F_tk(x) 5,1
!returns approximation of .5*(1+tanh(x))
use precis
real(mrl) F_tk,x,y
real ar(-60:60)
integer j
data ar/&
	0.0000, 0.0027, 0.0030, 0.0033, 0.0037, 0.0041, 0.0045, 0.0050,& 
	0.0055, 0.0061, 0.0067, 0.0074, 0.0082, 0.0090, 0.0100, 0.0110,& 
	0.0121, 0.0134, 0.0148, 0.0163, 0.0180, 0.0198, 0.0219, 0.0241,& 
	0.0266, 0.0293, 0.0323, 0.0356, 0.0392, 0.0431, 0.0474, 0.0522,& 
	0.0573, 0.0630, 0.0691, 0.0759, 0.0832, 0.0911, 0.0998, 0.1091,& 
	0.1192, 0.1301, 0.1419, 0.1545, 0.1680, 0.1824, 0.1978, 0.2142,& 
	0.2315, 0.2497, 0.2689, 0.2890, 0.3100, 0.3318, 0.3543, 0.3775,& 
	0.4013, 0.4256, 0.4502, 0.4750, 0.5000, 0.5250, 0.5498, 0.5744,& 
	0.5987, 0.6225, 0.6457, 0.6682, 0.6900, 0.7109, 0.7311, 0.7503,& 
	0.7685, 0.7858, 0.8022, 0.8176, 0.8320, 0.8455, 0.8581, 0.8699,& 
	0.8808, 0.8909, 0.9002, 0.9089, 0.9168, 0.9241, 0.9309, 0.9370,& 
	0.9427, 0.9478, 0.9526, 0.9569, 0.9608, 0.9644, 0.9677, 0.9707,& 
	0.9734, 0.9759, 0.9781, 0.9802, 0.9820, 0.9837, 0.9852, 0.9866,& 
	0.9879, 0.9890, 0.9900, 0.9910, 0.9918, 0.9926, 0.9933, 0.9939,& 
	0.9945, 0.9950, 0.9955, 0.9959, 0.9963, 0.9967, 0.9970, 0.9973,& 
	1.0000/
y=20*min(max(x,-2.999_mrl),2.999_mrl)
j=int(y+60)-60
F_tk=ar(j)+(y-j)*(ar(j+1)-ar(j))	
return
end function F_tk


function F_hump(x) 1,1
!returns approximation of 5*x*exp(-4*x*x) for x>0.
use precis
real(mrl) F_hump,x,y
integer j
real ar(0:100)
data ar/&
	0.0000, 0.0998, 0.1987, 0.2957, 0.3899, 0.4804, 0.5664, 0.6472,&
	0.7221, 0.7906, 0.8521, 0.9064, 0.9531, 0.9920, 1.0231, 1.0465,&  
	1.0623, 1.0706, 1.0719, 1.0664, 1.0546, 1.0370, 1.0142, 0.9866,&  
	0.9549, 0.9197, 0.8815, 0.8410, 0.7987, 0.7551, 0.7108, 0.6662,&  
	0.6217, 0.5778, 0.5348, 0.4930, 0.4526, 0.4139, 0.3770, 0.3421,&  
	0.3092, 0.2784, 0.2497, 0.2232, 0.1987, 0.1762, 0.1557, 0.1371,&  
	0.1203, 0.1052, 0.0916, 0.0795, 0.0687, 0.0592, 0.0508, 0.0435,&  
	0.0371, 0.0315, 0.0267, 0.0225, 0.0189, 0.0158, 0.0132, 0.0110,&  
	0.0091, 0.0075, 0.0062, 0.0051, 0.0042, 0.0034, 0.0028, 0.0022,&  
	0.0018, 0.0014, 0.0012, 0.0009, 0.0007, 0.0006, 0.0005, 0.0004,&  
	0.0003, 0.0002, 0.0002, 0.0001, 0.0001, 0.0001, 0.0001, 0.0000,&  
	0.0000, 0.0000, 0.0000, 0.0000, 0.0000, 0.0000, 0.0000, 0.0000,&  
	0.0000, 0.0000, 0.0000, 0.0000, 0.0000/
!F_hump=ar(nint(50.*amin1(amax1(x,0.),2.)))
y=50.*min(max(x,0._mrl),1.99_mrl)
j=int(y)
F_hump=ar(j)+(y-j)*(ar(j+1)-ar(j))	
return
end function F_hump