program one
    implicit none
	real,parameter::G=101.94,p0_0=101325,t0_0=288.15,n=7500,pi_c=4.1,z=8         !初始数据
	real,parameter::k=1.4,k1=0.0404,pi=3.1415926,r=287.06
	!导流叶片
	real::sigma_in=0.985
	real::p1_0,t1_0
	!第一级平均直径上气流及几何参数计算
	real::c1_a1=160,d1_1=0.4                  !自取
	real::p1_1,t1_1,rho1_1,c1_1,q1_1,lambda1_1,d1_t1,d1_h1,a1_1,L1_1  !求解
	!末级平均直径上气流及几何参数计算
	real::eta_c=0.872,c_ac=115,
	real::pc_0,tc_0,pc_1,tc_1,rhoc_1,cc_1,qc_1,lambdac_1,dc_t1,dc_h1,ac_1,Lc_1
	!选择级平均加工量
	 real::h_ad,eta_ad,h_adm,eta_adm
	 real::a_0=0.02332,a_2
	 real::a_1
	 !多级计算过程
	 real,dimension(8)::h_adi,c_a2_a,h_i,eta_a
	 real,dimension(9)::p_01_a,t_01_a,rhoc_11_a,p_11_a,t_11_a,p_02_a,t_02_a,t_12_a,c_a1_a,alpha_1_a,&
	                     &c_1_a,lambda_1_a,q_1_a,s_1,d_m1,d_t1,d_h1,L1
	real,dimension(8)::u_1_a,u_2_a,c_1u_a,c_2u_a,w_1u_a,w_2u_a,w_1_a,w_2_a,c_2_a,alpha_2_a,beta_1_a,&
	                   &beta_2_a,M_w_a,d_m2,delta_t_a,lambda_2_a,rhoc_12_a,s_2,d_t2,d_h2,d_m20,p_12_a,L2
	real,dimension(8)::p_03_a,t_03_a,M_c_a,omega_a,lambda_1w_a,t_01_w_a,p_01_w_a,t_02_w_a,p_02_w_a,p_02_w_a_ad,&
	                   &lambda_2w_a,omega_sunshi_ja,omega_sunshi_da
	 real::c_p
	 integer::i,j
	!确定各列叶栅气动计算尺寸
	real::K_G,delta_h,delta_t
	real,dimension(8)::r_he,r_te,r_1_h,r_2_h,r_1_t,r_2_t,r_1_m,r_2_m
	!确定径向计算站数目及其位置
	real,dimension(7,8)::r_r1,u_1,c_1u,c_1a,c_1,w_1u,w_1,alpha_1,beta_1,lambda_1,t_11,M_w,delta_A_1,delta_G_1,delta_GA_1,&
	                     &p_01,p_11,rhoc_11
	real::z_r
	real,dimension(8)::A,B,eps_1,G_c_1,t_0average_1,p_0average_1,t_0zong_1,p_0zong_1
	real,dimension(7)::sigma_1
	!!动叶出口截面
	real,dimension(8)::E,h,C,D
	real,dimension(7,8)::r_r2,u_2,c_2u,c_2a,c_2,w_2u,w_2
	!计算气体状态（动叶）
	real,dimension(8)::delta_t0,t_02,G_c_2,t_0average_2,p_0average_2,eta_average,t_0zong_2,p_0zong_2,eta_zong
	real,dimension(7,8)::lambda_2,t_12,M_c,t_01_w,t_02_w,lambda_1w,lambda_2w,p_01_w,p_02_w,p_02_w_ad,p_12,p_02,rhoc_12,&
	                        &delta_GA_2,delta_A_2,delta_G_2,omega,eta_adi,alpha_2,beta_2
    real,dimension(7)::eps_2

	!导流叶片
	open(unit=10,file='result.txt')
	p1_0=p0_0*sigma_in
    t1_0=t0_0
    write(10,*)'导流叶片:','p1_0=',p1_0,'t1_0=',t1_0
	!第一级平均直径上气流及几何参数计算
	!call jmcs(c1_a1,d1_1,alpha1_1,t1_0,p1_0,p1_1,t1_1,rho1_1,c1_1,q1_1,lambda1_1,d1_t1,d1_h1,a1_1,L1_1)
	c1_1=c1_a1/sin(alpha1_1*pi/180)
	lambda1_1=c1_1/sqrt(2*r*k*t1_0/(k+1))
	t1_1=(1-(k-1)*lambda1_1**2/(k+1))*t1_0
	p1_1=(1-(k-1)*lambda1_1**2/(k+1))**(k/(k-1))*p1_0
	q1_1=lambda1_1*((k+1)/2-(k-1)*(lambda1_1**2)/2)**(1/(k-1))
	a1_1=G*sqrt(t1_0)/(k1*q1_1*p1_0*sin(alpha1_1*pi/180))
	d1_t1=sqrt(4*a1_1/(pi*(1-d1_1**2)))
	d1_h1=d1_t1*d1_1
	L1_1=(d1_t1-d1_h1)/2
	write(10,*)'第一级平均直径上气流及几何参数计算','c1_1=',c1_1,'lambda1_1=',lambda1_1,'t1_1=',t1_1,'p1_1=',p1_1,'q1_1=',q1_1,&
	&'a1_1=',a1_1,'d1_t1=',d1_t1,'d1_h1=',d1_h1,'L1_1=',L1_1

    !gyugyu
	pc_0=p1_0*pi_c
	tc_0=t1_0*(1+(pi_c**((k-1)/k)-1)/eta_c)
	cc_1=c_ac
	lambdac_1=cc_1/sqrt(2*r*k*tc_0/(k+1))
	tc_1=(1-(k-1)*lambdac_1**2/(k+1))*tc_0
	pc_1=(1-(k-1)*lambdac_1**2/(k+1))**(k/(k-1))*pc_0
	qc_1=lambdac_1*((k+1)/2-(k-1)*(lambdac_1**2)/2)**(1/(k-1))
	ac_1=G*sqrt(tc_0)/(k1*qc_1*pc_0)
	dc_t1=d1_t1
	dc_h1=sqrt(dc_t1**2-4*ac_1/pi)
	Lc_1=(dc_t1-dc_h1)/2
	write(10,*)'末级平均直径上气流及几何参数计算','cc_1=',cc_1,'lambdac_1=',lambdac_1,'tc_1=',tc_1,'pc_1=',pc_1,'qc_1=',qc_1&
	&,'ac_1=',ac_1,'dc_t1=',dc_t1,'dc_h1=',dc_h1,'Lc_1=',Lc_1,'tc_0=',tc_0,'pc_0=',pc_0
	!选择级平均加工量
	do while(.true.)                                       !迭代求重热系数
	h_ad=k*r*t1_1*((pc_1/p1_1)**((k-1)/k)-1)/(k-1)
	eta_ad=h_ad/(k*r*(tc_1-t1_1)/(k-1))
	eta_adm=eta_ad*(1+a_0)
	a_1=eta_adm*((pc_1/p1_1)**((k-1)/(k*eta_adm))-1)/((pc_1/p1_1)**((k-1)/k)-1)-1
	a_2=a_1*(z-1)/z
	if((abs(a_2-a_0))/a_0<0.0001)exit
	a_0=a_2
	end do
	h_adm=(1+a_2)*h_ad/z
	write(10,*)'选择级平均加工量','h_ad=',h_ad,'eta_ad=',eta_ad,'h_adm=',h_adm,'eta_adm=',eta_adm,'a_2=',a_2
	!多级计算过程
	h_adi(1)=0.524*h_adm                                                        !分配能量
	h_adi(2)=0.8428*h_adm
	h_adi(3)=1.1502*h_adm
	h_adi(4)=1.1729*h_adm
	h_adi(5)=1.1824*h_adm
	h_adi(6)=1.1721*h_adm
	h_adi(7)=0.9883*h_adm
	h_adi(8)=0.9673*h_adm
	c_a1_a=(/160,160,160,160,155,150,145,140,135/)
	c_a2_a=(/158,156,154,152,152,148,143,138/)
	alpha_1_a=(/60.42,63.62,65.26,66.72,68.92,69.87,71.59,73.95,90/)
	eta_a=(/0.86,0.88,0.91,0.908,0.906,0.904,0.892,0.87/)
	c_p=k*r/(k-1)
	t_01_a(1)=t1_0                 !将之前求解的第一级参数赋值
	p_01_a(1)=p1_0
	do i=1,9
	if(i<9)then
	h_i(i)=h_adi(i)/eta_a(i)
	t_01_a(i+1)=h_i(i)/c_p+t_01_a(i)
	p_01_a(i+1)=p_01_a(i)*(h_adi(i)/(c_p*t_01_a(i))+1)**(k/(k-1))
	end if
	c_1_a(i)=c_a1_a(i)/sin(alpha_1_a(i)*pi/180)
	lambda_1_a(i)=c_1_a(i)/sqrt(2*r*k*t_01_a(i)/(k+1))
	t_11_a(i)=(1-(k-1)*lambda_1_a(i)**2/(k+1))*t_01_a(i)
	p_11_a(i)=(1-(k-1)*lambda_1_a(i)**2/(k+1))**(k/(k-1))*p_01_a(i)
	rhoc_11_a(i)=p_11_a(i)/(t_11_a(i)*r)
	q_1_a(i)=lambda_1_a(i)*((k+1)/2-(k-1)*(lambda_1_a(i)**2)/2)**(1/(k-1))
	s_1(i)=G*sqrt(t_01_a(i))/(k1*q_1_a(i)*p_01_a(i)*sin(alpha_1_a(i)*pi/180))
	d_t1(i)=d1_t1                                                       ! d_m1,d_t1,d_h1,L1
	d_h1(i)=sqrt(d_t1(i)**2-4*s_1(i)/pi)
	d_m1(i)=(d_h1(i)+d_t1(i))/2
	L1(i)=(d_t1(i)-d_h1(i))/2
	write(10,*)'进口截面的状态和几何参数','i=',i,'c_1_a=',c_1_a(i),'alpha_1_a=',alpha_1_a(i),'lambda_1_a=',lambda_1_a(i),'t_11_a=',t_11_a(i),&
	&'p_11_a=',p_11_a(i),'q_1_a=',q_1_a(i),'s_1=',s_1(i),'d_t1=',d_t1(i),'d_h1=',d_h1(i),'d_m1=',d_m1(i),'L1=',L1(i)
	end do
	do i=1,8
	c_1u_a(i)=sqrt((c_1_a(i))**2-(c_a1_a(i))**2)
	u_1_a(i)=n*pi*d_m1(i)/60
	w_1u_a(i)=u_1_a(i)-c_1u_a(i)
	w_1_a(i)=sqrt((w_1u_a(i))**2+(c_a1_a(i))**2)
	M_w_a(i)=w_1_a(i)/sqrt(k*r*t_11_a(i))
	if(M_w_a(i)>0.9)then
	write(10,*)"this is wrong"
	end if
	beta_1_a(i)=asin(c_a1_a(i)/w_1_a(i))*180/pi
	d_m20(i)=(d_m1(i)+d_m1(i+1))/2
	do while(.true.)
	u_2_a(i)=n*pi*d_m20(i)/60
	c_2u_a(i)=(h_i(i)+c_1u_a(i)*u_1_a(i))/u_2_a(i)
	c_2_a(i)=sqrt(c_2u_a(i)**2+c_a2_a(i)**2)
	w_2u_a(i)=u_2_a(i)-c_2u_a(i)
	w_2_a(i)=sqrt((w_2u_a(i))**2+(c_a2_a(i))**2)
	beta_2_a(i)=asin(c_a2_a(i)/w_2_a(i))*180/pi
	alpha_2_a(i)=asin(c_a2_a(i)/c_2_a(i))*180/pi
	delta_t_a(i)=(h_i(i)-0.5*(c_2_a(i)**2-c_1_a(i)**2))*(k-1)/(k*r)
	t_12_a(i)=t_11_a(i)+delta_t_a(i)
    p_12_a(i)=p_11_a(i)*(t_12_a(i)/t_11_a(i))**(k*eta_a(i)/(k-1))
	rhoc_12_a(i)=p_12_a(i)/(t_12_a(i)*r)
	s_2(i)=G/(c_a2_a(i)*rhoc_12_a(i))
	d_t2(i)=d1_t1                                                       ! d_m2,d_t2,d_h2,L1
	d_h2(i)=sqrt(d_t2(i)**2-4*s_2(i)/pi)
	d_m2(i)=(d_h2(i)+d_t2(i))/2
	L2(i)=(d_t2(i)-d_h2(i))/2

	if(abs((d_m2(i)-d_m20(i))/d_m20(i))<0.001)then                      !可能进入无限循环
	exit
	end if
	d_m20(i)=d_m2(i)
	end do
	!write(10,*)'动叶出口计算','i=',i,'c_1u_a=',c_1u_a(i),'u_1_a',u_1_a(i),'w_1u_a=',w_1u_a(i),'w_1_a=',w_1_a(i),&
	!&'M_w_a=',M_w_a(i),'beta_1_a=',beta_1_a(i),'u_2_a',u_2_a(i),'c_2u_a=',c_2u_a(i),'c_2_a=',c_2_a(i),'w_2u_a=',w_2u_a(i),&
	!&'w_2_a=',w_2_a(i),'beta_2_a=',beta_2_a(i),'alpha_2_a=',alpha_2_a(i),'delta_t_a=',delta_t_a(i),'t_12_a=',t_12_a(i),&
	!&'p_12_a=',p_12_a(i),'rhoc_12_a=',rhoc_12_a(i),'s_2=',s_2(i),'d_t2=',d_t2(i),'d_h2=',d_h2(i),'d_m2=',d_m2(i)

	!write(*,*)d_m20(i),d_m2(i),d_m1(i)
	t_02_a(i)=t_01_a(i)+h_i(i)/c_p
	lambda_2_a(i)=c_2_a(i)/sqrt(2*k*r*t_02_a(i)/(k+1))
	p_02_a(i)=p_12_a(i)/(1-(k-1)*lambda_2_a(i)**2/(k+1))**(k/(k-1))
	p_03_a(i)=p_01_a(i)*(1+(k-1)*h_adi(i)/(k*r*p_01_a(i)))**(k/(k-1))
	t_03_a(i)=t_02_a(i)
	M_c_a(i)=c_2_a(i)/sqrt(k*r*t_12_a(i))
	if(M_c_a(i)>0.9)then
	write(10,*)'c is wrong'
	end if
	omega_a(i)=1-(c_2_a(i)**2-c_1_a(i)**2)/(2*h_i(i))
	omega_sunshi_ja(i)=(p_02_a(i)-p_03_a(i))/(p_02_a(i)-p_12_a(i))
	lambda_1w_a(i)=w_1_a(i)/sqrt(2*k*r*t_01_a(i)/(k+1))
	t_01_w_a(i)=t_11_a(i)/(1-(k-1)*lambda_1w_a(i)**2/(k+1))
	p_01_w_a(i)=p_01_a(i)/(1-(k-1)*lambda_1w_a(i)**2/(k+1))**(k/(k-1))
	t_02_w_a(i)=t_01_w_a(i)*(1+u_2_a(i)**2*(1-(d_m1(i)/d_m2(i))**2)*(k-1)/(2*k*r*t_01_w_a(i)))
	p_02_w_a_ad(i)=p_01_w_a(i)*(t_02_w_a(i)/t_01_w_a(i))**(k/(k-1))
	lambda_2w_a(i)=w_2_a(i)/sqrt(2*k*r*t_02_a(i)/(k+1))
	p_02_w_a(i)=p_02_a(i)/(1-(k-1)*lambda_2w_a(i)**2/(k+1))**(k/(k-1))
	omega_sunshi_da(i)=(p_02_w_a(i)-p_02_w_a_ad(i))/(p_11_a(i)-p_01_w_a(i))
	!write(10,*)'静叶出口','i=',i,'t_02_a=',t_02_a(i),'lambda_2_a=',lambda_2_a(i),'p_02_a=',p_02_a(i),'p_03_a=',p_03_a(i),&
	!&'t_03_a=',t_03_a(i),'omega_a=',omega_a(i),'omega_sunshi_ja=',omega_sunshi_ja(i),'lambda_1w_a=',lambda_1w_a(i),&
	!&'t_01_w_a=',t_01_w_a(i),'p_01_w_a=',p_01_w_a(i),'t_02_w_a=',t_02_w_a(i),'p_02_w_a_ad=',p_02_w_a_ad(i),'''lambda_2w_a=',lambda_2w_a(i),&
	!&'p_02_w_a=',p_02_w_a(i),'omega_sunshi_da=',omega_sunshi_da(i)
    write(*,*)p_02_a(i),p_03_a(i),p_12_a(i)
	end do
	!确定各列叶栅气动计算尺寸
	K_G=0.999
	delta_h=0.5*(1+K_G)
	delta_t=0.5*(1+K_G)
	do i=1,8
	r_1_h(i)=d_h1(i)/2
	r_1_t(i)=d_t1(i)/2
	r_2_h(i)=d_h2(i)/2
	r_2_t(i)=d_t2(i)/2
	r_1_m(i)=(d_h1(i)+d_t1(i))/2
	r_2_m(i)=(d_h2(i)+d_t2(i))/2
	r_he(i)=sqrt(delta_h*r_1_h(i)**2+(1-delta_h)*r_1_t(i)**2)
	r_te(i)=sqrt(delta_t*r_1_t(i)**2+(1-delta_t)*r_1_h(i)**2)
	end do
	!确定径向计算站数目及其位置
	z_r=7
	do i=1,z
	r_r1(1,i)=r_1_h(i)
	do j=1,z_r-1
	r_r1(j+1,i)=r_r1(j,i)+(r_te(i)-r_he(i))/(z_r-1)
	end do
	end do
	!动叶进口截面沿径向气流参数分布规律
	do i=1,z
	A(i)=0.9*2*pi*n*(i-omega_a(i))              !自取
	B(i)=(c_1u_a(i)-A(i)*r_1_m(i))*r_1_m(i)
	  do j=1,z_r
	u_1(j,i)=2*pi*r_r1(j,i)*n/60
	c_1u(j,i)=A(i)*r_r1(1,i)+B(i)/r_r1(1,i)
	c_1a(j,i)=sqrt(c_a1_a(i)**2+2*A(i)**2*(r_1_m(i)**2-r_r1(j,i)**2)+4*A(i)*B(i)*log(r_1_m(i)/r_r1(j,i)))
	c_1(j,i)=sqrt(c_1a(j,i)**2+c_1u(j,i)**2)
	w_1u(j,i)=u_1(j,i)-c_1u(j,i)
	w_1(j,i)=sqrt(c_1a(j,i)**2+w_1u(j,i)**2)
	alpha_1(j,i)=atan(c_1a(j,i)/c_1u(j,i))
	beta_1(j,i)=atan(c_1a(j,i)/w_1u(j,i))
	!计算气体状态（认为径向加工量不变）
	lambda_1(j,i)=c_1(j,i)/sqrt(2*k*r*t_01_a(i)/(k+1))
	t_11(j,i)=t_01_a(i)*(1-(k-1)*lambda_1(j,i)**2/(k+1))
	M_w(j,i)=w_1(j,i)/sqrt(k*r*t_11(j,i))
	sigma_1=(/0.992,0.994,0.996,0.998,0.998,0.997,0.996/)   !校核
	p_01(j,i)=sigma_1(j)*p_01_a(i)
	p_11(j,i)=p_01(j,i)*(1-(k-1)*lambda_1(j,i)**2/(k+1))**(k/(k-1))
	rhoc_11(j,i)=p_11(j,i)/(t_11(j,i)*r)
	end do
	end do
	!流量校核
	G_c_1=0
	do i=1,z
	  do j=1,z_r
	   delta_GA_1(j,i)=rhoc_11(j,i)*c_1a(j,i)
	   if(j>1)then
	   delta_A_1(j-1,i)=pi*(r_r1(j,i)**2-r_r1(j-1,i)**2)
	   delta_G_1(j-1,i)=delta_A_1(j-1,i)*(delta_GA_1(j,i)-delta_GA_1(j-1,i))/2
	    G_c_1(i)=G_c_1(i)+delta_G_1(j-1,i)
	   end if
	   end do
	  eps_1(i)=(G_c_1(i)-G)/G
	end do
	do i=1,z
	   t_0zong_1(1)=0
	   p_0zong_1(1)=0
	   do j=1,z_r-1
	   t_0zong_1(i)=delta_G_1(j,i)*(t_01_a(i)+t_01_a(i+1))/2+t_0zong_1(i)
	   p_0zong_1(i)=delta_G_1(j,i)*(p_01_a(i)+p_01_a(i+1))/2+p_0zong_1(i)
	   end do
	   t_0average_1(i)=t_0zong_1(i)/G
	   p_0average_1(i)=p_0zong_1(i)/G
	end do
	 !动叶出口截面
	 do i=1,z
	   E(i)=(1-(d_h1(i)-d_t1(i))**2)*d_t1(i)**2/((1-(d_h2(i)-d_t2(i))**2)*d_t2(i)**2)
	    do j=1,z_r
		r_r2(j,i)=r_2_m(i)*sqrt(1+(r_1_m(i)/r_1_m(i))**2*((r_r1(j,i)/r_1_m(i))**2-1)/E(i))
		u_2(j,i)=2*pi*r_r2(j,i)*n/60
		h(i)=u_2_a(i)*c_2u_a(i)-u_2_a(i)*c_2u_a(i)
		C(i)=E(i)*A(i)
		D(i)=h(i)/(2*pi*n)+A(i)*r_1_m(i)**2-c_2_a(i)**2+B(i)
		c_2u(j,i)=C(i)*r_r2(j,i)+D(i)/r_r2(j,i)
		c_2a(j,i)=sqrt(c_a2_a(i)**2+2*C(i)**2*(r_2_m(i)**2-r_r2(j,i)**2)+4*C(i)*D(i)*log(r_2_m(i)/r_r2(j,i)))
		c_2(j,i)=sqrt(c_2a(j,i)**2+c_2u(j,i)**2)
		w_2u(j,i)=u_2(j,i)-c_2u(j,i)
		w_2(j,i)=sqrt(c_2a(j,i)**2+w_2u(j,i)**2)
		alpha_2(j,i)=atan(c_2a(j,i)/c_2u(j,i))
	    beta_2(j,i)=atan(c_2a(j,i)/w_2u(j,i))
	    end do
	end do
	!计算气体状态（动叶）
	  eps_2=(/0.996,0.996,0.995,0.995,0.995,0.993,0.990/)
	do i=1,z
	delta_t0(i)=h(i)/c_p
	t_02(i)=t_01_a(i)+delta_t0(i)
	  do j=1,z_r
	  lambda_2(j,i)=c_2(j,i)/sqrt(2*k*r*t_02(i)/(k+1))
	  t_12(j,i)=t_02(i)*(1-(k-1)*lambda_2(j,i)**2/(k+1))
	  M_c(j,i)=c_2(j,i)/sqrt(k*r*t_12(j,i))
	  t_01_w(j,i)=t_11(j,i)+w_1(j,i)**2/(2*c_p)
	  lambda_1w(j,i)=w_1(j,i)/sqrt(2*k*r*t_01_w(j,i)/(k+1))
	  p_01_w(j,i)=p_11(j,i)/(1-(k-1)*lambda_1w(j,i)**2/(k+1))**(k/(k-1))
	  t_02_w(j,i)=t_12(j,i)+w_2(j,i)**2/(2*c_p)
	  lambda_2w(j,i)=w_2(j,i)/sqrt(2*k*r*t_02_w(j,i)/(k+1))
	  p_02_w_ad(j,i)=p_01_w(j,i)*(t_02_w(j,i)/t_01_w(j,i))**(k*(k-1))
	  p_02_w(j,i)= p_02_w_ad(j,i)*eps_2(j)
	  p_12(j,i)=p_02_w(j,i)*(1-(k-1)*lambda_2w(j,i)**2/(k+1))**(k/(k-1))
	  p_02(j,i)=p_12(j,i)/(1-(k-1)*lambda_2(j,i)**2/(k+1))**(k/(k-1))
	  rhoc_12(j,i)=p_12(j,i)/(t_12(j,i)*r)
	  delta_GA_2(j,i)=rhoc_12(j,i)*c_2a(j,i)
	  end do
	end do
	G_c_2=0
	do i=1,z
	  do j=1,z_r-1
	  delta_A_2(j,i)=pi*(r_r2(j+1,i)**2-r_r2(j,i)**2)
	  delta_G_2(j,i)=delta_A_2(j,i)*(delta_GA_2(j+1,i)+delta_GA_2(j,i))/2
	  G_c_2(i)=G_c_2(i)+delta_G_2(j,i)
	  end do
	  eps_2(i)=(G_c_2(i)-G)/G
	end do
	do i=1,z
       do j=1,z_r
	   omega(j,i)=1-(c_1u(j,i)+c_2u(j,i))/(u_1(j,i)+u_2(j,i))
	   eta_adi(j,i)=((p_01(j,i+1)/p_02(j,i))**((k-1)/k)-1)/(t_02(i)/t_01_a(i)-1)
	   end do
	end do
	do i=1,z
	   t_0zong_2(1)=0
	   p_0zong_2(1)=0
	   eta_zong(1)=0
	   do j=1,z_r-1
	   t_0zong_2(i)=delta_G_2(j,i)*(t_02(i)+t_02(i))/2+t_0zong_2(i)
	   p_0zong_2(i)=delta_G_2(j,i)*(p_02(j+1,i)+p_02(j,i))/2+p_0zong_2(i)
	   eta_zong(i)=delta_G_2(j,i)*(eta_adi(j,i)+eta_adi(j+1,i))/2+eta_zong(i)
	   end do
	   t_0average_2(i)=t_0zong_2(i)/G
	   p_0average_2(i)=p_0zong_2(i)/G
	  eta_average(i)=eta_zong(i)/G
	end do
	close(10)
    stop
    end program  one

	!#####################截面参数子程序###################################
	subroutine  jmcs(c1_a1,d1_1,alpha1_1,t1_0,p1_0,p1_1,t1_1,rho1_1,c1_1,q1_1,lambda1_1,d1_t1,d1_h1,a1_1,L1_1)
	real::c1_a1,d1_1,alpha1_1,t1_0,p1_0                !自取
	real::p1_1,t1_1,rho1_1,c1_1,q1_1,lambda1_1,d1_t1,d1_h1,a1_1,L1_1  !求解
	c1_1=c1_a1/sin(alpha1_1*pi/180)
	lambda1_1=c1_1/sqrt(2*r*k*t1_0/(k+1))
	t1_1=(1-(k-1)*lambda1_1**2/(k+1))*t1_0
	p1_1=(1-(k-1)*lambda1_1**2/(k+1))**(k/(k-1))*p1_0
	q1_1=lambda1_1*((k+1)/2-(k-1)*(lambda1_1**2)/2)**(1/(k-1))
	a1_1=G*sqrt(t1_0)/(k1*q1_1*p1_0*sin(alpha1_1*pi/180))
	d1_t1=sqrt(4*a1_1/(pi*(1-d1_1**2)))
	d1_h1=d1_t1*d1_1
	L1_1=(d1_t1-d1_h1)/2
	return
	end subroutine jmcs


      SUBROUTINE PENMAN_OHD (SFCTMP,SFCPRS,CH,T2V,TH2,PRCP,FDOWN,T24,
     &                   SSOIL, Q2,Q2SAT,ETP,RCH,EPSCA,RR,SNOWNG,FRZGRA,
     &                   DQSDT2,FLX2)

      IMPLICIT NONE

C ----------------------------------------------------------------------
C SUBROUTINE PENMAN_OHD
C ----------------------------------------------------------------------
C CALCULATE POTENTIAL EVAPORATION FOR THE CURRENT POINT.  VARIOUS
C PARTIAL SUMS/PRODUCTS ARE ALSO CALCULATED AND PASSED BACK TO THE
C CALLING ROUTINE FOR LATER USE.
C ----------------------------------------------------------------------
      LOGICAL SNOWNG
      LOGICAL FRZGRA

      REAL A
      REAL BETA
      REAL CH
      REAL CP
      REAL CPH2O
      REAL CPICE
      REAL DELTA
      REAL DQSDT2
      REAL ELCP
      REAL EPSCA
      REAL ETP
      REAL FDOWN
      REAL FLX2
      REAL FNET
      REAL LSUBC
      REAL LSUBF
      REAL PRCP
      REAL Q2
      REAL Q2SAT
      REAL R
      REAL RAD
      REAL RCH
      REAL RHO
      REAL RR
      REAL SSOIL
      REAL SFCPRS
      REAL SFCTMP
      REAL SIGMA
      REAL T24
      REAL T2V
      REAL TH2

      PARAMETER(CP = 1004.6)
      PARAMETER(CPH2O = 4.218E+3)
      PARAMETER(CPICE = 2.106E+3)
      PARAMETER(R = 287.04)
      PARAMETER(ELCP = 2.4888E+3)
      PARAMETER(LSUBF = 3.335E+5)
      PARAMETER(LSUBC = 2.501000E+6)
      PARAMETER(SIGMA = 5.67E-8)

C ----------------------------------------------------------------------
C EXECUTABLE CODE BEGINS HERE:
C ----------------------------------------------------------------------
      FLX2 = 0.0

C ----------------------------------------------------------------------
C PREPARE PARTIAL QUANTITIES FOR PENMAN_OHD EQUATION.
C ----------------------------------------------------------------------
      DELTA = ELCP * DQSDT2
      T24 = SFCTMP * SFCTMP * SFCTMP * SFCTMP
      RR = T24 * 6.48E-8 /(SFCPRS * CH) + 1.0
      RHO = SFCPRS / (R * T2V)
      RCH = RHO * CP * CH

C ----------------------------------------------------------------------
C ADJUST THE PARTIAL SUMS / PRODUCTS WITH THE LATENT HEAT
C EFFECTS CAUSED BY FALLING PRECIPITATION.
C ----------------------------------------------------------------------
      IF (.NOT. SNOWNG) THEN
        IF (PRCP .GT. 0.0) RR = RR + CPH2O*PRCP/RCH
      ELSE
        RR = RR + CPICE*PRCP/RCH
      ENDIF

      FNET = FDOWN - SIGMA*T24 - SSOIL

C ----------------------------------------------------------------------
C INCLUDE THE LATENT HEAT EFFECTS OF FRZNG RAIN CONVERTING TO ICE ON
C IMPACT IN THE CALCULATION OF FLX2 AND FNET.
C ----------------------------------------------------------------------
      IF (FRZGRA) THEN
        FLX2 = -LSUBF * PRCP
        FNET = FNET - FLX2
      ENDIF

C ----------------------------------------------------------------------
C FINISH PENMAN_OHD EQUATION CALCULATIONS.
C ----------------------------------------------------------------------
      RAD = FNET/RCH + TH2 - SFCTMP
      A = ELCP * (Q2SAT - Q2)
      EPSCA = (A*RR + RAD*DELTA) / (DELTA + RR)
      ETP = EPSCA * RCH / LSUBC

c      write(*,321) 'pen',FNET,SFCPRS,SFCTMP,CH,Q2,Q2SAT,DQSDT2,RR,DELTA
c      write(*,*) rad,rch,th2 ,etp
c321   format(a3,f6.0,f8.0,f9.1,3f7.4,f7.4,2f7.3)

C ----------------------------------------------------------------------
C END SUBROUTINE PENMAN_OHD
C ----------------------------------------------------------------------
      RETURN
      END


C     LAST UPDATE 28/03/96
C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
      REAL FUNCTION CORTAB(D,U,V)
      IMPLICIT NONE
C Purpose: CORTAB corrects intensities for oblique incidence on film,
C          absorption by previous films and paper polarisation
C          correction and going from energy per unit area on film to
C          intensity in reciprocal space.
C
C Calls   0:
C Called by: ARRFIL, FILARR
C
C-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-
C
C Common scalars:
C
      REAL DIST,XC,YC,ROTX,ROTY,ROTZ,TILT,WAVE,XYRAT
      REAL ABSBAS,ABSEML,ABSPAP,C0,PAPN,FILN
      INTEGER NFBEFR,NPBEFR
C
C Arguments:
C
      REAL D,U,V
C
C Local Scalars:
C
      REAL COS2T,POL,SECP,TNP,CT
C
C Common blocks:
C
      COMMON /TRANSF/ DIST,XC,YC,ROTX,ROTY,ROTZ,TILT,WAVE,XYRAT
      COMMON /FILMAB/ ABSBAS,ABSEML,ABSPAP,NFBEFR,NPBEFR,C0,PAPN,FILN
C
C-----------------------------------------------------------------------
      COS2T = 1.0 - 0.5*WAVE*WAVE*D*D
      SECP = SQRT(DIST*DIST+U*U+V*V)/DIST
      IF(ABSEML.GT.0.0)THEN
         CT = (1.0-EXP(-ABSEML*SECP))*(1.0+EXP(-(ABSEML+ABSBAS)*SECP))
         TNP = C0*EXP((PAPN+FILN)*(SECP-1.0))/CT
      ELSE
         TNP = 1.0
      ENDIF
      POL = 0.5 + 0.5*COS2T
      CORTAB = SECP*SECP*SECP*TNP/POL
      RETURN
C
      END


      subroutine surq_daycn

!!    ~ ~ ~ PURPOSE ~ ~ ~
!!    Predicts daily runoff given daily precipitation and snow melt
!!    using a modified SCS curve number approach

!!    ~ ~ ~ INCOMING VARIABLES ~ ~ ~
!!    name        |units         |definition
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~
!!    cnday(:)    |none          |curve number for current day, HRU and at
!!                               |current soil moisture
!!    fcimp(:)    |fraction      |fraction of HRU area that is classified
!!                               |as directly connected impervious
!!    ihru        |none          |HRU number
!!    iurban(:)   |none          |urban simulation code:
!!                               |0  no urban sections in HRU
!!                               |1  urban sections in HRU, simulate using USGS
!!                               |   regression equations
!!                               |2  urban sections in HRU, simulate using build
!!                               |   up/wash off algorithm
!!    precipday   |mm H2O        |precipitation for the day in HRU
!!    urblu(:)    |none          |urban land type identification number from
!!                               |urban.dat
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~

!!    ~ ~ ~ OUTGOING VARIABLES ~ ~ ~
!!    name        |units         |definition
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~
!!    surfq(:)    |mm H2O        |surface runoff for the day in HRU
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~

!!    ~ ~ ~ LOCAL DEFINITIONS ~ ~ ~
!!    name        |units         |definition
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~
!!    bb          |none          |variable used to store intermediate
!!                               |calculation result
!!    cnimp       |none          |curve number for impervious areas
!!    j           |none          |HRU number
!!    pb          |none          |variable used to store intermediate
!!                               |calculation result
!!    r2          |none          |retention parameter in CN equation
!!    surfqimp    |mm H2O        |surface runoff from impervious area
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~

!!    ~ ~ ~ ~ ~ ~ END SPECIFICATIONS ~ ~ ~ ~ ~ ~

      use parm

      integer :: j
      real*8 :: r2, bb, pb, cnimp, surfqimp

      j = 0
      j = ihru

      r2 = 0.
      bb = 0.
      pb = 0.
      r2 = 25400. / cnday(j) - 254.
      bb = .2 * r2
      pb = precipday - bb

      if (pb > 0.) then
        surfq(j) = pb * pb / (precipday + .8 * r2)
      end if

      if (iurban(j) > 0) then
        r2 = 0.
        bb = 0.
        pb = 0.
        surfqimp = 0.
        cnimp = 98.
        r2 = 25400. / cnimp - 254.
        bb = .2 * r2
        pb = precipday - bb
        if (pb > 0.) then
          surfqimp = pb * pb / (precipday + .8 * r2)
        end if
        surfq(j) = surfq(j) * (1. - fcimp(urblu(j))) +
     &                                        surfqimp * fcimp(urblu(j))
      end if

      return
      end


      INTEGER FUNCTION IUNIFL (LOWB,UPPB)
      IMPLICIT NONE

*     FORMAL_PARAMETERS:
      INTEGER LOWB, UPPB

**    Local variables
      REAL UNIFL, DIFF, RAN
      LOGICAL DRAW
      SAVE

      DIFF   = 1./(1.+REAL(UPPB)-REAL(LOWB))

      DRAW = .TRUE.
10    IF (DRAW) THEN
         RAN  = UNIFL()
         DRAW = RAN.EQ.1.
      GOTO 10
      END IF

      IUNIFL = LOWB+INT(RAN/DIFF)
c      write (*,*) lowb,uppb,iunifl
      RETURN
      END


!!# FUNCTION MODULE <<Integrate1_aq>>
MODULE FUN_Integrate1_aq

!!## PURPOSE
!! Integrate a function using Adaptive Quadrature.

!!## METHOD
!! Uses Adaptive Quadrature to approximate the definite
!! integral of f(x) from p(1) to p(2) within a given tolerance, tol.

!!## EXTERNAL KINDS
USE KND_IntrinsicTypes,ONLY: KIND_Rsp,KIND_Rdp !!((01-A-KND_IntrinsicTypes.f90))

!!## EXTERNAL PROCEDURES
USE FUN_Error                                  !!((04-A-FUN_Error.f90))

!!## DEFAULT IMPLICIT
IMPLICIT NONE

!!## DEFAULT ACCESS
PRIVATE

!!## PROCEDURE OVERLOADING
INTERFACE Integrate1_aq
 MODULE PROCEDURE Integrate1_aq_Rsp
 MODULE PROCEDURE Integrate1_aq_Rdp
END INTERFACE

!!## PUBLIC ACCESS LIST
PUBLIC :: Integrate1_aq

CONTAINS

!!### RECURSIVE FUNCTION <<Integrate1_aq_Rsp>>
RECURSIVE FUNCTION Integrate1_aq_Rsp(f,p,tol,N) RESULT(result)
!!#### LOCAL KINDS
USE KND_IntrinsicTypes,ONLY: KIND_R=>KIND_Rsp  !!((01-A-KND_IntrinsicTypes.f90))
USE PAR_Constants_Rsp                          !!((02-A-PAR_Constants_Rsp.f90))
INCLUDE "03-A-INT_Function1_Rsp.f90.hdr"
INCLUDE "06-B-FUN_Integrate1_aq.f90.hdr"
!!--begin--
INCLUDE "06-B-FUN_Integrate1_aq.f90.bdy"
!!--end--
END FUNCTION

!!### RECURSIVE FUNCTION <<Integrate1_aq_Rdp>>
RECURSIVE FUNCTION Integrate1_aq_Rdp(f,p,tol,N) RESULT(result)
!!#### LOCAL KINDS
USE KND_IntrinsicTypes,ONLY: KIND_R=>KIND_Rdp  !!((01-A-KND_IntrinsicTypes.f90))
USE PAR_Constants_Rdp                          !!((02-A-PAR_Constants_Rdp.f90))
INCLUDE "03-A-INT_Function1_Rdp.f90.hdr"
INCLUDE "06-B-FUN_Integrate1_aq.f90.hdr"
!!--begin--
INCLUDE "06-B-FUN_Integrate1_aq.f90.bdy"
!!--end--
END FUNCTION

END MODULE


!---------------------------------------------------------------------------------------------------
!
!	filename = linear.f90
!	authors = Edison Salazar
!		  Pedro Guarderas
!	date = 20/09/2013
!
!---------------------------------------------------------------------------------------------------

!---------------------------------------------------------------------------------------------------
! Module for linear algebra
module linear
  implicit none

contains

!---------------------------------------------------------------------------------------------------
! Printing a matrix
subroutine WriteMatrix( unit, A, m, n )
  implicit none
  integer, intent( in ) :: unit, m, n
  double precision, intent( in ) :: A( m, n )
  integer :: i, j

  do i = 1,m
     do j = 1,n
        write( unit, "(F50.40,1X)", advance="no" ) A( i, j )
     end do
     write( unit, * )
  end do

end subroutine WriteMatrix

!---------------------------------------------------------------------------------------------------
! Printing a vector
subroutine WriteVector( unit, A, n )
  implicit none
  integer, intent( in ) :: unit, n
  double precision, intent( in ) :: A( n )
  integer :: i

  do i = 1,n
     write( unit, "(F50.40,1X)", advance="no" ) A( i )
     write( unit, * )
  end do

end subroutine WriteVector

!---------------------------------------------------------------------------------------------------
subroutine MatMulVec( y, A, x, m, n )
  implicit none
  integer, intent( in ) :: m, n
  double precision, intent( out ) :: y(m)
  double precision, intent( in ) :: A(m,n), x(n)
  integer :: i, j

    !$omp parallel do private(i) shared(y)
    do i = 1,m
      y(i) = 0.0D0
    end do

    !$omp parallel do private(i,j) shared(x,y,A) collapse(2)
    do i = 1,m
      do j = 1,n
        y(i) = y(i) + A(i,j) * x(j)
      end do
    end do

end subroutine MatMulVec

!---------------------------------------------------------------------------------------------------
! Matrix multiplication
subroutine MatMul( C, A, B, m, n, p, q, TA, TB )
  implicit none
  double precision, allocatable, intent( out ) :: C(:,:)
  double precision, intent( in ) :: A(m,n), B(p,q)
  integer, intent( in ) :: m, n, p, q
  logical, intent( in ) :: TA, TB

  double precision :: sum
  integer :: i, j, k

  if ( TA .and. TB ) then
     if ( m == q ) then
        allocate( C(n,p) )
        !$omp parallel do private(sum,k) shared(n,p,m,A,B,C) collapse(2)
        do i = 1,n
           do j = 1,p
              sum = 0.0D0
              do k = 1,m
                 sum = sum + A(k,i) * B(j,k)
              end do
              C(i,j) = sum
           end do
        end do
     end if
  else if ( .not. TA .and. TB ) then
     if ( n == q ) then
        allocate( C(m,p) )
        !$omp parallel do private(sum,k) shared(n,p,m,A,B,C) collapse(2)
        do i = 1,m
           do j = 1,p
              sum = 0.0D0
              do k = 1,n
                 sum = sum + A(i,k) * B(j,k)
              end do
              C(i,j) = sum
           end do
        end do
     end if
  else if ( TA .and. .not. TB ) then
     if ( m == p ) then
        allocate( C(n,q) )
        !$omp parallel do private(sum,k) shared(n,p,m,A,B,C) collapse(2)
        do i = 1,n
           do j = 1,q
              sum = 0.0D0
              do k = 1,m
                 sum = sum + A(k,i) * B(k,j)
              end do
              C(i,j) = sum
           end do
        end do
     end if
  else if ( .not. TA .and. .not. TB ) then
     if ( n == p ) then
        allocate( C(m,q) )
        !$omp parallel do private(sum,k) shared(n,p,m,A,B,C) collapse(2)
        do i = 1,m
           do j = 1,q
              sum = 0.0D0
              do k = 1,n
                 sum = sum + A(i,k) * B(k,j)
              end do
              C(i,j) = sum
           end do
        end do
     end if
  end if

end subroutine MatMul

!---------------------------------------------------------------------------------------------------
! Vector norm
function norm( v, n ) result( nrm )
  integer, intent( in ) :: n
  double precision, intent( in ) :: v(n)
  double precision :: nrm
  integer :: i

  nrm = 0.0D0
  !#omp parallel do shared(n,v) private(i) reduction(+:nrm)
  do i = 1,n
     nrm = nrm + v(i) * v(i)
  end do

  nrm = sqrt( nrm )

end function norm

!---------------------------------------------------------------------------------------------------
! Scalar product
function scalar( v, w, n ) result( scl )
  integer, intent( in ) :: n
  double precision, intent( in ) :: v(n), w(n)
  double precision :: scl
  integer :: i

  scl = 0.0D0
  !#omp parallel do shared(n,v,w) private(i) reduction(+:scl)
  do i = 1,n
     scl = scl + v(i) * w(i)
  end do

end function scalar

!---------------------------------------------------------------------------------------------------
! Cholesky decomposition
subroutine CHBfac( L, A, n )
  integer, intent( in ) :: n
  double precision, intent( in ) :: A(n,n)
  double precision, intent( out ) :: L(n,n)
  integer :: i, j, k

  !$omp parallel do shared(L) collapse(2)
  do i = 1,n
    do j = 1,n
      if ( i >= j ) then
        L(i,j) = A(i,j)
      else
        L(i,j) = 0.0D0
      end if
    end do
  end do

  do j = 1,n
    L(j,j) = sqrt(L(j,j))
    do i = (j+1),n
      L(i,j) = L(i,j) / L(j,j)
    end do
    do k = (j+1),n
      do i = k,n
        L(i,k) = L(i,k) - L(i,j) * L(k,j)
      end do
    end do
  end do

end subroutine CHBfac

!---------------------------------------------------------------------------------------------------
! QR factorization no destructive version
subroutine QRfac( Q, R, A, n )
  integer, intent( in ) :: n
  double precision, intent( in ) :: A(n,n)
  double precision, intent( out ) :: Q(n,n), R(n,n)
  integer :: i, j, k

  !$omp parallel do shared(Q,R,A) collapse(2)
  do i = 1,n
    do j = 1,n
      Q(i,j) = A(i,j)
      R(i,j) = 0.D0
    end do
  end do

  do j = 1,n
     R(j,j) = norm( Q(1:n,1), n )
     if ( R(j,j) == 0 ) then
        write( *, * ) "Error matrix has linearly dependent columns"
     else
        !$omp parallel do shared(Q,R)
        do i = 1,n
           Q(i,j) = Q(i,j) / R(j,j)
        end do
     end if

     do k = j+1,n
        R(j,k) = scalar( A(1:n,j), A(1:n,k), n )
        do i = 1,n
           Q(i,k) = Q(i,k) - Q(i,j) * R(j,k)
        end do
     end do
  end do

end subroutine

end module linear


! Demonstrate built-in arithmetic operators
program operators
implicit none
print*,2 + 3 ! 5
print*,2 - 3 ! -1
print*,2 * 3 ! 6
print*,2 / 3 ! 0 -- quotient truncated to integer
print*,2 / 3.0, 2.0/3 ! 0.666666687 0.666666687 -- int/real or real/int gives real
print*,2 ** 3 ! 8 -- ** is exponentiation, as in Python
end program operators


    subroutine cova3(x1,y1,z1,x2,y2,z2,ivarg,nst,MAXNST,c0,it,cc,aa, &
    irot,MAXROT,rotmat,cmax,cova)
!-----------------------------------------------------------------------

!                    Covariance Between Two Points
!                    *****************************

! This subroutine calculated the covariance associated with a variogram
! model specified by a nugget effect and nested varigoram structures.
! The anisotropy definition can be different for each nested structure.

! INPUT VARIABLES:

!   x1,y1,z1         coordinates of first point
!   x2,y2,z2         coordinates of second point
!   nst(ivarg)       number of nested structures (maximum of 4)
!   ivarg            variogram number (set to 1 unless doing cokriging
!                       or indicator kriging)
!   MAXNST           size of variogram parameter arrays
!   c0(ivarg)        isotropic nugget constant
!   it(i)            type of each nested structure:
!                      1. spherical model of range a;
!                      2. exponential model of parameter a;
!                           i.e. practical range is 3a
!                      3. gaussian model of parameter a;
!                           i.e. practical range is a*sqrt(3)
!                      4. power model of power a (a must be gt. 0  and
!                           lt. 2).  if linear model, a=1,c=slope.
!                      5. hole effect model
!   cc(i)            multiplicative factor of each nested structure.
!                      (sill-c0) for spherical, exponential,and gaussian
!                      slope for linear model.
!   aa(i)            parameter "a" of each nested structure.
!   irot             index of the rotation matrix for the first nested
!                    structure (the second nested structure will use
!                    irot+1, the third irot+2, and so on)
!   MAXROT           size of rotation matrix arrays
!   rotmat           rotation matrices

! OUTPUT VARIABLES:

!   cmax             maximum covariance
!   cova             covariance between (x1,y1,z1) and (x2,y2,z2)

! EXTERNAL REFERENCES: sqdist    computes anisotropic squared distance
!                      rotmat    computes rotation matrix for distance
!-----------------------------------------------------------------------
    parameter(PI=3.14159265,PMX=999.,EPSLON=1.e-10)
    integer ::   nst(*),it(*)
    real ::      c0(*),cc(*),aa(*)
    real*8 ::    rotmat(MAXROT,3,3),hsqd,sqdist

! Calculate the maximum covariance value (used for zero distances and
! for power model covariance):

    istart = 1 + (ivarg-1)*MAXNST
    cmax   = c0(ivarg)
    do is=1,nst(ivarg)
        ist = istart + is - 1
        if(it(ist) == 4) then
            cmax = cmax + PMX
        else
            cmax = cmax + cc(ist)
        endif
    end do

! Check for "zero" distance, return with cmax if so:

    hsqd = sqdist(x1,y1,z1,x2,y2,z2,irot,MAXROT,rotmat)
    if(real(hsqd) < EPSLON) then
        cova = cmax
        return
    endif

! Loop over all the structures:

    cova = 0.0
    do is=1,nst(ivarg)
        ist = istart + is - 1

    ! Compute the appropriate distance:

        if(ist /= 1) then
            ir = min((irot+is-1),MAXROT)
            hsqd=sqdist(x1,y1,z1,x2,y2,z2,ir,MAXROT,rotmat)
        end if
        h = real(dsqrt(hsqd))

    ! Spherical Variogram Model?

        if(it(ist) == 1) then
            hr = h/aa(ist)
            if(hr < 1.) cova=cova+cc(ist)*(1.-hr*(1.5-.5*hr*hr))

        ! Exponential Variogram Model?

        else if(it(ist) == 2) then
            cova = cova + cc(ist)*exp(-3.0*h/aa(ist))

        ! Gaussian Variogram Model?

        else if(it(ist) == 3) then
            cova = cova + cc(ist)*exp(-(3.0*h/aa(ist)) &
            *(3.0*h/aa(ist)))

        ! Power Variogram Model?

        else if(it(ist) == 4) then
            cova = cova + cmax - cc(ist)*(h**aa(ist))

        ! Hole Effect Model?

        else if(it(ist) == 5) then
        !                 d = 10.0 * aa(ist)
        !                 cova = cova + cc(ist)*exp(-3.0*h/d)*cos(h/aa(ist)*PI)
            cova = cova + cc(ist)*cos(h/aa(ist)*PI)
        endif
    end do

! Finished:

    return
    end subroutine cova3


module poisson_2d_m

use, intrinsic :: iso_c_binding

use mesh_fields_m

implicit none

private

include 'fftw3.f03'

type, public :: poisson_t

    type(mesh_t)            :: mesh
    complex(8), allocatable :: kx(:,:)
    complex(8), allocatable :: ky(:,:)
    complex(8), allocatable :: rho(:,:)
    complex(8), allocatable :: ex(:,:)
    complex(8), allocatable :: ey(:,:)
    integer(8)              :: fw
    integer(8)              :: bw

end type poisson_t

public :: init_poisson, solve_poisson

contains

    subroutine init_poisson( self, mesh )

        type(poisson_t)      :: self
        type(mesh_t)         :: mesh

        complex(8)              :: kx0
        complex(8)              :: ky0
        real(8)                 :: pi
        real(8),    allocatable :: tmp(:,:)
        integer                 :: nx
        integer                 :: ny
        complex(8)              :: kx1
        complex(8), allocatable :: k2(:,:)
        integer                 :: ik
        integer                 :: jk

        pi = 4d0 * atan(1d0)

        kx0 = cmplx(2d0 * pi / (mesh%xmax - mesh%xmin), 0d0, kind=8)
        ky0 = cmplx(2d0 * pi / (mesh%ymax - mesh%ymin), 0d0, kind=8)

        nx = mesh%nx
        ny = mesh%ny

        allocate(self%kx(nx/2+1,ny))
        allocate(self%ky(nx/2+1,ny))
        allocate(k2(nx/2+1,ny))

        do ik=1,mesh%nx/2+1
           kx1 = cmplx(ik-1,0d0,kind=8)*kx0
           do jk = 1,mesh%ny/2
              self%kx(ik,jk) = kx1
              self%ky(ik,jk) = cmplx(jk-1,0d0,kind=8)*ky0
           end do
           do jk = mesh%ny/2+1,mesh%ny
              self%kx(ik,jk) = kx1
              self%ky(ik,jk) = cmplx(jk-1-ny,0d0,kind=8)*ky0
           end do
        end do

        self%kx(1,1) = (1d0,0d0)
        k2 = self%kx * self%kx + self%ky * self%ky
        self%kx = self%kx / k2
        self%ky = self%ky / k2

        allocate(self%rho(nx/2+1,ny))
        allocate(self%ex(nx/2+1,ny))
        allocate(self%ey(nx/2+1,ny))
        allocate(tmp(mesh%nx, mesh%ny))

        call dfftw_plan_dft_r2c_2d(self%fw,nx,ny,tmp,self%rho,FFTW_ESTIMATE)
        call dfftw_plan_dft_c2r_2d(self%bw,nx,ny,self%rho,tmp,FFTW_ESTIMATE)

    end subroutine init_poisson

    subroutine solve_poisson ( self, fields )

        type(poisson_t)     :: self
        type(fields_2d_t)   :: fields

        integer               :: nx
        integer               :: ny

        nx = fields%mesh%nx
        ny = fields%mesh%ny

        call dfftw_execute_dft_r2c( self%fw, fields%rho(1:nx,1:ny), self%rho )

        self%ex = cmplx(0d0,-1d0) * self%kx * self%rho
        self%ey = cmplx(0d0,-1d0) * self%ky * self%rho

        call dfftw_execute_dft_c2r( self%bw, self%ex, fields%e(1,1:nx,1:ny) )
        call dfftw_execute_dft_c2r( self%bw, self%ey, fields%e(2,1:nx,1:ny) )

        fields%e(1,nx+1,:) = fields%e(1,1,:)
        fields%e(1,:,ny+1) = fields%e(1,:,1)
        fields%e(2,nx+1,:) = fields%e(2,1,:)
        fields%e(2,:,ny+1) = fields%e(2,:,1)

        fields%e = fields%e / real( nx * ny, kind = 8 )

    end subroutine solve_poisson

end module poisson_2d_m


  subroutine sigmav_ionisation_by_e(dens_e,temp_e,sigmav)
!
! electron impact
!
  implicit none
!
  integer, parameter :: m_max=8, n_max=8
  double precision, parameter :: dens_min = 1.d8
  integer :: m, n
  double precision :: dens_e,temp_e,sigmav,denslog,templog
  double precision, dimension(0:n_max,0:m_max) :: alpha
  data &
       alpha(0,0) /-3.292647100524D+01/, &
       alpha(1,0) /1.293481375348D-02 /, &
       alpha(2,0) /5.517562508468D-03 /, &
       alpha(0,1) /1.423977672396D+01 /, &
       alpha(1,1) /-1.173143955186D-02/, &
       alpha(2,1) /1.063440108279D-03 /, &
       alpha(0,2) /-6.519438729039D+00/, &
       alpha(1,2) /-7.189825749516D-03/, &
       alpha(2,2) /9.247377414923D-04 /, &
       alpha(0,3) /2.009996151806D+00 /, &
       alpha(1,3) /1.275979740638D-02 /, &
       alpha(2,3) /-4.693479616874D-03/, &
       alpha(0,4) /-4.289594424073D-01/, &
       alpha(1,4) /-5.340866322754D-03/, &
       alpha(2,4) /2.324582357388D-03 /, &
       alpha(0,5) /6.047834607038D-02 /, &
       alpha(1,5) /9.624900593359D-04 /, &
       alpha(2,5) /-4.182981184259D-04/, &
       alpha(0,6) /-5.304737965836D-03/, &
       alpha(1,6) /-7.854872454067D-05/, &
       alpha(2,6) /2.735823803201D-05 /, &
       alpha(0,7) /2.606946949696D-04 /, &
       alpha(1,7) /2.317442253442D-06 /, &
       alpha(2,7) /5.148890779990D-08 /, &
       alpha(0,8) /-5.467903073834D-06/, &
       alpha(1,8) /6.077380038450D-09 /, &
       alpha(2,8) /-4.712893073569D-08/, &
       alpha(3,0) /-7.853816321645D-04/, &
       alpha(4,0) /1.436128501544D-04 /, &
       alpha(5,0) /-3.883750282085D-07/, &
       alpha(3,1) /-1.600053527730D-03/, &
       alpha(4,1) /1.136554639958D-05 /, &
       alpha(5,1) /5.177662275946D-05 /, &
       alpha(3,2) /2.037026745547D-03 /, &
       alpha(4,2) /-3.668717204076D-04/, &
       alpha(5,2) /5.368630315837D-06 /, &
       alpha(3,3) /-2.389224140310D-05/, &
       alpha(4,3) /1.358069915666D-04 /, &
       alpha(5,3) /-1.454897555460D-05/, &
       alpha(3,4) /-3.217228075879D-04/, &
       alpha(4,4) /6.660581406632D-06 /, &
       alpha(5,4) /2.396531874534D-06 /, &
       alpha(3,5) /7.957230182146D-05 /, &
       alpha(4,5) /-7.447042563915D-06/, &
       alpha(5,5) /1.849155263575D-07 /, &
       alpha(3,6) /-5.915348564130D-06/, &
       alpha(4,6) /8.666302868477D-07 /, &
       alpha(5,6) /-6.115514821045D-08/, &
       alpha(3,7) /-7.144182523188D-09/, &
       alpha(4,7) /-2.540194754187D-08/, &
       alpha(5,7) /4.097857835689D-09 /, &
       alpha(3,8) /1.086858755070D-08 /, &
       alpha(4,8) /-3.448417246175D-10/, &
       alpha(5,8) /-8.714183216468D-11/, &
       alpha(6,0) /-1.489774355194D-06/, &
       alpha(7,0) /1.416361431167D-07 /, &
       alpha(8,0) /-3.890932078762D-09/, &
       alpha(6,1) /-7.947999902838D-06/, &
       alpha(7,1) /4.508505683240D-07 /, &
       alpha(8,1) /-8.952614093357D-09/, &
       alpha(6,2) /3.713958914062D-06 /, &
       alpha(7,2) /-3.125764373429D-07/, &
       alpha(8,2) /7.451213220623D-09 /, &
       alpha(6,3) /4.212031496989D-08 /, &
       alpha(7,3) /5.506044670830D-08 /, &
       alpha(8,3) /-1.852677638893D-09/, &
       alpha(6,4) /-1.785208321244D-07/, &
       alpha(7,4) /6.095649574151D-10 /, &
       alpha(8,4) /1.470204228549D-10 /, &
       alpha(6,5) /1.618233640838D-08 /, &
       alpha(7,5) /-8.182928298434D-10/, &
       alpha(8,5) /4.835789623340D-12 /, &
       alpha(6,6) /1.075473174260D-09 /, &
       alpha(7,6) /4.118000674849D-11 /, &
       alpha(8,6) /-1.089323091222D-12/, &
       alpha(6,7) /-2.048657335774D-10/, &
       alpha(7,7) /3.027916374251D-12 /, &
       alpha(8,7) /1.155854020410D-14 /, &
       alpha(6,8) /8.023660696154D-12 /, &
       alpha(7,8) /-2.396518500447D-13/, &
       alpha(8,8) /2.173645280354D-15 /
!
  denslog=log(dens_e/dens_min)
  templog=log(temp_e)
!
  sigmav=0.d0
  do m=0,m_max
    do n=0,n_max
      sigmav=sigmav+alpha(n,m)*denslog**n*templog**m
    enddo
  enddo
  sigmav =  exp(sigmav)
!
  end subroutine sigmav_ionisation_by_e
!
!ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
!
  subroutine sigmav_ionisation_by_i(Ebeam,temp_i,sigmav)
!
! ion impact (hydrogen in hydrogen)
!
  implicit none
!
  integer, parameter :: m_max=8, n_max=8
  integer :: m, n
  double precision :: Ebeam,temp_i,sigmav,ebeamlog,templog
  double precision, dimension(0:n_max,0:m_max) :: alpha
  data &
       alpha(0,0) /-1.617454916209e+02/, &
       alpha(1,0) /1.767238902030e+01 /, &
       alpha(2,0) /-4.334843983767e+01/, &
       alpha(0,1) /1.021458246570e+02 /, &
       alpha(1,1) /-7.102574692619e+01/, &
       alpha(2,1) /3.855259623260e+01 /, &
       alpha(0,2) /-5.712267930902e+01/, &
       alpha(1,2) /4.246688953154e+01 /, &
       alpha(2,2) /-1.316883030631e+01/, &
       alpha(0,3) /2.140540272484e+01 /, &
       alpha(1,3) /-1.128638171243e+01/, &
       alpha(2,3) /2.145592145856e+00 /, &
       alpha(0,4) /-4.767517412803e+00/, &
       alpha(1,4) /1.661679851896e+00 /, &
       alpha(2,4) /-1.467281287038e-01/, &
       alpha(0,5) /6.293295208376e-01 /, &
       alpha(1,5) /-1.476754423056e-01/, &
       alpha(2,5) /-2.915256218527e-03/, &
       alpha(0,6) /-4.858173640838e-02/, &
       alpha(1,6) /8.175790218529e-03 /, &
       alpha(2,6) /1.092542891192e-03 /, &
       alpha(0,7) /2.031177914273e-03 /, &
       alpha(1,7) /-2.732531913524e-04/, &
       alpha(2,7) /-6.205102802216e-05/, &
       alpha(0,8) /-3.557982934756e-05/, &
       alpha(1,8) /4.398387454014e-06 /, &
       alpha(2,8) /1.158798945435e-06 /, &
       alpha(3,0) /2.464254915383e+01 /, &
       alpha(4,0) /-5.439093405254e+00/, &
       alpha(5,0) /5.959975304236e-01 /, &
       alpha(3,1) /-1.283426276878e+01/, &
       alpha(4,1) /2.357085001656e+00 /, &
       alpha(5,1) /-2.391382925527e-01/, &
       alpha(3,2) /2.369698902002e+00 /, &
       alpha(4,2) /-2.961732508220e-01/, &
       alpha(5,2) /2.789277301925e-02 /, &
       alpha(3,3) /-1.506665823159e-01/, &
       alpha(4,3) /-9.917174972226e-04/, &
       alpha(5,3) /8.562387824450e-05 /, &
       alpha(3,4) /-8.144926683660e-03/, &
       alpha(4,4) /1.935894665907e-03 /, &
       alpha(5,4) /-1.340759667335e-04/, &
       alpha(3,5) /2.231505500086e-03 /, &
       alpha(4,5) /-1.679264493005e-05/, &
       alpha(5,5) /-5.927455645560e-06/, &
       alpha(3,6) /-2.210941355372e-04/, &
       alpha(4,6) /5.532386419162e-08 /, &
       alpha(5,6) /5.820264508685e-07 /, &
       alpha(3,7) /1.310924337643e-05 /, &
       alpha(4,7) /-1.121430499351e-06/, &
       alpha(5,7) /7.694068657107e-08 /, &
       alpha(3,8) /-3.431837053957e-07/, &
       alpha(4,8) /5.960280736984e-08 /, &
       alpha(5,8) /-4.972708712807e-09/, &
       alpha(6,0) /-3.361958123977e-02/, &
       alpha(7,0) /8.706597041685e-04 /, &
       alpha(8,0) /-6.359765062372e-06/, &
       alpha(6,1) /1.289667246580e-02 /, &
       alpha(7,1) /-3.140899683782e-04/, &
       alpha(8,1) /1.742836004704e-06 /, &
       alpha(6,2) /-1.858739201548e-03/, &
       alpha(7,2) /7.343984485463e-05 /, &
       alpha(8,2) /-1.235536456998e-06/, &
       alpha(6,3) /9.235982885753e-05 /, &
       alpha(7,3) /-8.601564864429e-06/, &
       alpha(8,3) /2.257852760280e-07 /, &
       alpha(6,4) /9.875232214392e-06 /, &
       alpha(7,4) /-6.467790579320e-07/, &
       alpha(8,4) /1.608335682237e-08 /, &
       alpha(6,5) /-1.680823118052e-06/, &
       alpha(7,5) /1.734797315767e-07 /, &
       alpha(8,5) /-3.855914336143e-09/, &
       alpha(6,6) /3.019916624608e-08 /, &
       alpha(7,6) /2.523651535182e-09 /, &
       alpha(8,6) /-3.556222618473e-10/, &
       alpha(6,7) /6.889325889968e-09 /, &
       alpha(7,7) /-1.719633613108e-09/, &
       alpha(8,7) /7.627265694554e-11 /, &
       alpha(6,8) /-3.171970185702e-10/, &
       alpha(7,8) /7.332933714195e-11 /, &
       alpha(8,8) /-2.960493966948e-12/
!
  ebeamlog=log(Ebeam)
  templog=log(temp_i)
!
  sigmav=0.d0
  do m=0,m_max
    do n=0,n_max
      sigmav=sigmav+alpha(n,m)*ebeamlog**n*templog**m
    enddo
  enddo
  sigmav =  exp(sigmav)
!
  end subroutine sigmav_ionisation_by_i
!
!ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc


 MODULE GDSWZD_MOD
!$$$  MODULE DOCUMENTATION BLOCK
!
! $Revision: 74685 $
!
! MODULE:  GDSWZD_MOD  GDS WIZARD MODULE
!   PRGMMR: GAYNO     ORG: W/NMC23       DATE: 2015-01-21
!
! ABSTRACT: DRIVER MODULE FOR GDSWZD ROUTINES.  THESE ROUTINES
!           DO THE FOLLOWING FOR SEVERAL MAP PROJECTIONS:
!            - CONVERT FROM EARTH TO GRID COORDINATES OR VICE VERSA.
!            - COMPUTE VECTOR ROTATION SINES AND COSINES.
!            - COMPUTE MAP JACOBIANS.
!            - COMPUTE GRID BOX AREA.
!           MAP PROJECTIONS INCLUDE:
!            - EQUIDISTANT CYCLINDRICAL
!            - MERCATOR CYLINDRICAL
!            - GAUSSIAN CYLINDRICAL
!            - POLAR STEREOGRAPHIC
!            - LAMBERT CONFORMAL CONIC
!            - ROTATED EQUIDISTANT CYCLINDRICAL ("E" AND
!              NON-"E" STAGGERS).
!
! PROGRAM HISTORY LOG:
!   2015-01-21  GAYNO   INITIAL VERSION FROM A MERGER OF
!                       ROUTINES GDSWIZ AND GDSWZD.
!
! USAGE:  "USE GDSWZD_MOD"  THEN CALL THE PUBLIC DRIVER
!         ROUTINE "GDSWZD".
!
! ATTRIBUTES:
!   LANGUAGE: FORTRAN 90
!
!$$$
!
 IMPLICIT NONE

 PRIVATE

 PUBLIC                       :: GDSWZD

 CONTAINS

 SUBROUTINE GDSWZD(IGDTNUM,IGDTMPL,IGDTLEN,IOPT,NPTS,FILL, &
                   XPTS,YPTS,RLON,RLAT,NRET, &
                   CROT,SROT,XLON,XLAT,YLON,YLAT,AREA)
!$$$  SUBPROGRAM DOCUMENTATION BLOCK
!
! SUBPROGRAM:  GDSWZD     GRID DESCRIPTION SECTION WIZARD
!   PRGMMR: IREDELL       ORG: W/NMC23       DATE: 96-04-10
!
! ABSTRACT: THIS SUBPROGRAM DECODES THE GRIB 2 GRID DEFINITION
!           TEMPLATE (PASSED IN INTEGER FORM AS DECODED BY THE
!           NCEP G2 LIBRARY) AND RETURNS ONE OF THE FOLLOWING:
!             (IOPT= 0) GRID AND EARTH COORDINATES OF ALL GRID POINTS
!             (IOPT=+1) EARTH COORDINATES OF SELECTED GRID COORDINATES
!             (IOPT=-1) GRID COORDINATES OF SELECTED EARTH COORDINATES
!           THE CURRENT CODE RECOGNIZES THE FOLLOWING PROJECTIONS,
!           WHERE "IGDTNUM" IS THE GRID DEFINITION TEMPLATE NUMBER:
!             (IGDTNUM=00) EQUIDISTANT CYLINDRICAL
!             (IGDTNUM=01) ROTATED EQUIDISTANT CYLINDRICAL.  "E"
!                          AND NON-"E" STAGGERED
!             (IGDTNUM=10) MERCATOR CYCLINDRICAL
!             (IGDTNUM=20) POLAR STEREOGRAPHIC AZIMUTHAL
!             (IGDTNUM=30) LAMBERT CONFORMAL CONICAL
!             (IGDTNUM=40) GAUSSIAN EQUIDISTANT CYCLINDRICAL
!           IF THE SELECTED COORDINATES ARE MORE THAN ONE GRIDPOINT
!           BEYOND THE THE EDGES OF THE GRID DOMAIN, THEN THE RELEVANT
!           OUTPUT ELEMENTS ARE SET TO FILL VALUES.  ALSO IF IOPT=0,
!           IF THE NUMBER OF GRID POINTS EXCEEDS THE NUMBER ALLOTTED,
!           THEN ALL THE OUTPUT ELEMENTS ARE SET TO FILL VALUES.
!           THE ACTUAL NUMBER OF VALID POINTS COMPUTED IS RETURNED TOO.
!           OPTIONALLY, THE VECTOR ROTATIONS, MAP JACOBIANS AND
!           GRID BOX AREAS MAY BE RETURNED.  TO COMPUTE THE
!           VECTOR ROTATIONS, THE OPTIONAL ARGUMENTS 'SROT' AND 'CROT'
!           MUST BE PRESENT.  TO COMPUTE THE MAP JACOBIANS, THE
!           OPTIONAL ARGUMENTS 'XLON', 'XLAT', 'YLON', 'YLAT' MUST BE PRESENT.
!           TO COMPUTE THE GRID BOX AREAS, THE OPTIONAL ARGUMENT
!           'AREA' MUST BE PRESENT.
!
! PROGRAM HISTORY LOG:
! 1996-04-10  IREDELL
! 1997-10-20  IREDELL  INCLUDE MAP OPTIONS
! 1998-08-20  BALDWIN  ADD TYPE 203 2-D ETA GRIDS
! 2008-04-11  GAYNO    ADD TYPE 205 - ROT LAT/LON B-STAGGER
! 2012-08-02  GAYNO    FIX COMPUTATION OF I/J FOR 203 GRIDS WITH
!                      NSCAN /= 0.
! 2015-01-26  GAYNO    MERGER OF GDSWIZ AND GDSWZD.  MAKE MODULE.
!                      REMOVE REFERENCES TO OBSOLETE NCEP GRID
!                      201 AND 202. MAKE CROT,SORT,XLON,XLAT,
!                      YLON,YLAT AND AREA OPTIONAL ARGUMENTS.
! 2015-07-13  GAYNO    CONVERT TO GRIB 2. REPLACE GRIB 1 KGDS ARRAY
!                      WITH GRIB 2 GRID DEFINITION TEMPLATE ARRAY.
!                      REMOVED CALLS TO ROUTINES GDSWZDC9 AND
!                      GDSWZDCA.  THESE ROUTINES WORKED FOR
!                      ROTATED LAT/LON GRIDS THAT ARE NOW
!                      OBSOLETE UNDER THE GRIB 2 STANDARD.
!
! USAGE:    CALL GDSWZD(IGDTNUM,IGDTMPL,IGDTLEN,IOPT,NPTS,FILL,
!    &                  XPTS,YPTS,RLON,RLAT,NRET,
!    &                  CROT,SROT,XLON,XLAT,YLON,YLAT,AREA)
!
!   INPUT ARGUMENT LIST:
!     IGDTNUM  - INTEGER GRID DEFINITION TEMPLATE NUMBER.
!                CORRESPONDS TO THE GFLD%IGDTNUM COMPONENT OF THE
!                NCEP G2 LIBRARY GRIDMOD DATA STRUCTURE.
!                  00 - EQUIDISTANT CYLINDRICAL
!                  01 - ROTATED EQUIDISTANT CYLINDRICAL.  "E"
!                       AND NON-"E" STAGGERED
!                  10 - MERCATOR CYCLINDRICAL
!                  20 - POLAR STEREOGRAPHIC AZIMUTHAL
!                  30 - LAMBERT CONFORMAL CONICAL
!                  40 - GAUSSIAN EQUIDISTANT CYCLINDRICAL
!     IGDTMPL  - INTEGER (IGDTLEN) GRID DEFINITION TEMPLATE ARRAY.
!                CORRESPONDS TO THE GFLD%IGDTMPL COMPONENT OF THE
!                NCEP G2 LIBRARY GRIDMOD DATA STRUCTURE FOR
!                SECTION THREE.
!                ALL PROJECTIONS:
!                 (1):  SHAPE OF EARTH, OCTET 15
!                 (2):  SCALE FACTOR OF SPHERICAL EARTH RADIUS,
!                       OCTET 16
!                 (3):  SCALED VALUE OF RADIUS OF SPHERICAL EARTH,
!                       OCTETS 17-20
!                 (4):  SCALE FACTOR OF MAJOR AXIS OF ELLIPTICAL EARTH,
!                       OCTET 21
!                 (5):  SCALED VALUE OF MAJOR AXIS OF ELLIPTICAL EARTH,
!                       OCTETS 22-25
!                 (6):  SCALE FACTOR OF MINOR AXIS OF ELLIPTICAL EARTH,
!                       OCTET 26
!                 (7):  SCALED VALUE OF MINOR AXIS OF ELLIPTICAL EARTH,
!                       OCTETS 27-30
!                EQUIDISTANT CYCLINDRICAL:
!                 (8):  NUMBER OF POINTS ALONG A PARALLEL, OCTS 31-34
!                 (9):  NUMBER OF POINTS ALONG A MERIDIAN, OCTS 35-38
!                 (10): BASIC ANGLE OF INITIAL PRODUCTION DOMAIN,
!                       OCTETS 39-42.
!                 (11): SUBDIVISIONS OF BASIC ANGLE, OCTETS 43-46
!                 (12): LATITUDE OF FIRST GRID POINT, OCTETS 47-50
!                 (13): LONGITUDE OF FIRST GRID POINT, OCTETS 51-54
!                 (14): RESOLUTION AND COMPONENT FLAGS, OCTET 55
!                 (15): LATITUDE OF LAST GRID POINT, OCTETS 56-59
!                 (16): LONGITUDE OF LAST GRID POINT, OCTETS 60-63
!                 (17): I-DIRECTION INCREMENT, OCTETS 64-67
!                 (18): J-DIRECTION INCREMENT, OCTETS 68-71
!                 (19): SCANNING MODE, OCTET 72
!                MERCATOR CYCLINDRICAL:
!                 (8):  NUMBER OF POINTS ALONG A PARALLEL, OCTS 31-34
!                 (9):  NUMBER OF POINTS ALONG A MERIDIAN, OCTS 35-38
!                 (10): LATITUDE OF FIRST POINT, OCTETS 39-42
!                 (11): LONGITUDE OF FIRST POINT, OCTETS 43-46
!                 (12): RESOLUTION AND COMPONENT FLAGS, OCTET 47
!                 (13): TANGENT LATITUDE, OCTETS 48-51
!                 (14): LATITUDE OF LAST POINT, OCTETS 52-55
!                 (15): LONGITUDE OF LAST POINT, OCTETS 56-59
!                 (16): SCANNING MODE FLAGS, OCTET 60
!                 (17): ORIENTATION OF GRID, OCTETS 61-64
!                 (18): LONGITUDINAL GRID LENGTH, OCTETS 65-68
!                 (19): LATITUDINAL GRID LENGTH, OCTETS 69-72
!                LAMBERT CONFORMAL CONICAL:
!                 (8):  NUMBER OF POINTS ALONG X-AXIS, OCTS 31-34
!                 (9):  NUMBER OF POINTS ALONG Y-AXIS, OCTS 35-38
!                 (10): LATITUDE OF FIRST POINT, OCTETS 39-42
!                 (11): LONGITUDE OF FIRST POINT, OCTETS 43-46
!                 (12): RESOLUTION OF COMPONENT FLAG, OCTET 47
!                 (13): LATITUDE WHERE GRID LENGTHS SPECIFIED,
!                       OCTETS 48-51
!                 (14): LONGITUDE OF MERIDIAN THAT IS PARALLEL TO
!                       Y-AXIS, OCTETS 52-55
!                 (15): X-DIRECTION GRID LENGTH, OCTETS 56-59
!                 (16): Y-DIRECTION GRID LENGTH, OCTETS 60-63
!                 (17): PROJECTION CENTER FLAG, OCTET 64
!                 (18): SCANNING MODE, OCTET 65
!                 (19): FIRST TANGENT LATITUDE FROM POLE, OCTETS 66-69
!                 (20): SECOND TANGENT LATITUDE FROM POLE, OCTETS 70-73
!                 (21): LATITUDE OF SOUTH POLE OF PROJECTION,
!                       OCTETS 74-77
!                 (22): LONGITUDE OF SOUTH POLE OF PROJECTION,
!                       OCTETS 78-81
!                GAUSSIAN CYLINDRICAL:
!                 (8):  NUMBER OF POINTS ALONG A PARALLEL, OCTS 31-34
!                 (9):  NUMBER OF POINTS ALONG A MERIDIAN, OCTS 35-38
!                 (10): BASIC ANGLE OF INITIAL PRODUCTION DOMAIN,
!                       OCTETS 39-42
!                 (11): SUBDIVISIONS OF BASIC ANGLE, OCTETS 43-46
!                 (12): LATITUDE OF FIRST GRID POINT, OCTETS 47-50
!                 (13): LONGITUDE OF FIRST GRID POINT, OCTETS 51-54
!                 (14): RESOLUTION AND COMPONENT FLAGS, OCTET 55
!                 (15): LATITUDE OF LAST GRID POINT, OCTETS 56-59
!                 (16): LONGITUDE OF LAST GRID POINT, OCTETS 60-63
!                 (17): I-DIRECTION INCREMENT, OCTETS 64-67
!                 (18): NUMBER OF PARALLELS BETWEEN POLE AND EQUATOR,
!                       OCTETS 68-71
!                 (19): SCANNING MODE, OCTET 72
!                POLAR STEREOGRAPHIC AZIMUTHAL:
!                 (8):  NUMBER OF POINTS ALONG X-AXIS, OCTETS 31-34
!                 (9):  NUMBER OF POINTS ALONG Y-AXIS, OCTETS 35-38
!                 (10): LATITUDE OF FIRST GRID POINT, OCTETS 39-42
!                 (11): LONGITUDE OF FIRST GRID POINT, OCTETS 43-46
!                 (12): RESOLUTION AND COMPONENT FLAGS, OCTET 47
!                 (13): TRUE LATITUDE, OCTETS 48-51
!                 (14): ORIENTATION LONGITUDE, OCTETS 52-55
!                 (15): X-DIRECTION GRID LENGTH, OCTETS 56-59
!                 (16): Y-DIRECTION GRID LENGTH, OCTETS 60-63
!                 (17): PROJECTION CENTER FLAG, OCTET 64
!                 (18): SCANNING MODE FLAGS, OCTET 65
!                ROTATED EQUIDISTANT CYCLINDRICAL:
!                 (8):  NUMBER OF POINTS ALONG A PARALLEL, OCTS 31-34
!                 (9):  NUMBER OF POINTS ALONG A MERIDIAN, OCTS 35-38
!                 (10): BASIC ANGLE OF INITIAL PRODUCTION DOMAIN,
!                       OCTETS 39-42
!                 (11): SUBDIVISIONS OF BASIC ANGLE, OCTETS 43-46
!                 (12): LATITUDE OF FIRST GRID POINT, OCTETS 47-50
!                 (13): LONGITUDE OF FIRST GRID POINT, OCTETS 51-54
!                 (14): RESOLUTION AND COMPONENT FLAGS, OCTET 55
!                 (15): LATITUDE OF LAST GRID POINT, OCTETS 56-59
!                 (16): LONGITUDE OF LAST GRID POINT, OCTETS 60-63
!                 (17): I-DIRECTION INCREMENT, OCTETS 64-67
!                 (18): J-DIRECTION INCREMENT, OCTETS 68-71
!                 (19): SCANNING MODE, OCTET 72
!                 (20): LATITUDE OF SOUTHERN POLE OF PROJECTION,
!                       OCTETS 73-76
!                 (21): LONGITUDE OF SOUTHERN POLE OF PROJECTION,
!                       OCTETS 77-80
!                 (22): ANGLE OF ROTATION OF PROJECTION, OCTS 81-84
!     IGDTLEN  - INTEGER NUMBER OF ELEMENTS OF THE GRID DEFINITION
!                TEMPLATE ARRAY.  CORRESPONDS TO THE GFLD%IGDTLEN
!                COMPONENT OF THE NCEP G2 LIBRARY GRIDMOD DATA STRUCTURE.
!     IOPT     - INTEGER OPTION FLAG
!                ( 0 TO COMPUTE EARTH COORDS OF ALL THE GRID POINTS)
!                (+1 TO COMPUTE EARTH COORDS OF SELECTED GRID COORDS)
!                (-1 TO COMPUTE GRID COORDS OF SELECTED EARTH COORDS)
!     NPTS     - INTEGER MAXIMUM NUMBER OF COORDINATES
!     FILL     - REAL FILL VALUE TO SET INVALID OUTPUT DATA
!                (MUST BE IMPOSSIBLE VALUE; SUGGESTED VALUE: -9999.)
!     XPTS     - REAL (NPTS) GRID X POINT COORDINATES IF IOPT>0
!     YPTS     - REAL (NPTS) GRID Y POINT COORDINATES IF IOPT>0
!     RLON     - REAL (NPTS) EARTH LONGITUDES IN DEGREES E IF IOPT<0
!                (ACCEPTABLE RANGE: -360. TO 360.)
!     RLAT     - REAL (NPTS) EARTH LATITUDES IN DEGREES N IF IOPT<0
!                (ACCEPTABLE RANGE: -90. TO 90.)
!
!   OUTPUT ARGUMENT LIST:
!     XPTS     - REAL (NPTS) GRID X POINT COORDINATES IF IOPT<=0
!     YPTS     - REAL (NPTS) GRID Y POINT COORDINATES IF IOPT<=0
!     RLON     - REAL (NPTS) EARTH LONGITUDES IN DEGREES E IF IOPT>=0
!     RLAT     - REAL (NPTS) EARTH LATITUDES IN DEGREES N IF IOPT>=0
!     NRET     - INTEGER NUMBER OF VALID POINTS COMPUTED
!                (-1 IF PROJECTION UNRECOGNIZED)
!     CROT     - REAL, OPTIONAL (NPTS) CLOCKWISE VECTOR ROTATION COSINES
!     SROT     - REAL, OPTIONAL (NPTS) CLOCKWISE VECTOR ROTATION SINES
!                (UGRID=CROT*UEARTH-SROT*VEARTH;
!                 VGRID=SROT*UEARTH+CROT*VEARTH)
!     XLON     - REAL, OPTIONAL (NPTS) DX/DLON IN 1/DEGREES
!     XLAT     - REAL, OPTIONAL (NPTS) DX/DLAT IN 1/DEGREES
!     YLON     - REAL, OPTIONAL (NPTS) DY/DLON IN 1/DEGREES
!     YLAT     - REAL, OPTIONAL (NPTS) DY/DLAT IN 1/DEGREES
!     AREA     - REAL, OPTIONAL (NPTS) AREA WEIGHTS IN M**2
!                (PROPORTIONAL TO THE SQUARE OF THE MAP FACTOR
!                 IN THE CASE OF CONFORMAL PROJECTIONS)
!
! SUBPROGRAMS CALLED:
!   GDSWZD_EQUID_CYLIND              GDS WIZARD FOR EQUIDISTANT CYLINDRICAL
!   GDSWZD_MERCATOR                  GDS WIZARD FOR MERCATOR CYLINDRICAL
!   GDSWZD_LAMBERT_CONF              GDS WIZARD FOR LAMBERT CONFORMAL CONICAL
!   GDSWZD_GAUSSIAN                  GDS WIZARD FOR GAUSSIAN CYLINDRICAL
!   GDSWZD_POLAR_STEREO              GDS WIZARD FOR POLAR STEREOGRAPHIC AZIMUTHAL
!   GDSWZD_ROT_EQUID_CYLIND_EGRID    GDS WIZARD FOR ROTATED EQUIDISTANT CYLINDRICAL
!   GDSWZD_ROT_EQUID_CYLIND          GDS WIZARD FOR ROTATED EQUIDISTANT CYLINDRICAL
!
! ATTRIBUTES:
!   LANGUAGE: FORTRAN 90
!
!$$$
!
 USE GDSWZD_EQUID_CYLIND_MOD
 USE GDSWZD_MERCATOR_MOD
 USE GDSWZD_LAMBERT_CONF_MOD
 USE GDSWZD_GAUSSIAN_MOD
 USE GDSWZD_POLAR_STEREO_MOD
 USE GDSWZD_ROT_EQUID_CYLIND_EGRID_MOD
 USE GDSWZD_ROT_EQUID_CYLIND_MOD
!
 IMPLICIT NONE
!
 INTEGER,        INTENT(IN   ) :: IGDTNUM, IGDTLEN
 INTEGER,        INTENT(IN   ) :: IGDTMPL(IGDTLEN)
 INTEGER,        INTENT(IN   ) :: IOPT, NPTS
 INTEGER,        INTENT(  OUT) :: NRET
!
 REAL,           INTENT(IN   ) :: FILL
 REAL,           INTENT(INOUT) :: RLON(NPTS),RLAT(NPTS)
 REAL,           INTENT(INOUT) :: XPTS(NPTS),YPTS(NPTS)
 REAL, OPTIONAL, INTENT(  OUT) :: CROT(NPTS),SROT(NPTS)
 REAL, OPTIONAL, INTENT(  OUT) :: XLON(NPTS),XLAT(NPTS)
 REAL, OPTIONAL, INTENT(  OUT) :: YLON(NPTS),YLAT(NPTS),AREA(NPTS)
!
 INTEGER                       :: IS1, IM, JM, NM, KSCAN, NSCAN, N
 INTEGER                       :: IOPF, NN, I, J
 INTEGER                       :: I_OFFSET_ODD, I_OFFSET_EVEN
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
!  COMPUTE GRID COORDINATES FOR ALL GRID POINTS
 IF(IOPT.EQ.0) THEN
   IF(IGDTNUM==0) THEN
     IM=IGDTMPL(8)
     JM=IGDTMPL(9)
     NM=IM*JM
     NSCAN=MOD(IGDTMPL(19)/32,2)
   ELSEIF(IGDTNUM==1) THEN
     IM=IGDTMPL(8)
     JM=IGDTMPL(9)
     NM=IM*JM
     I_OFFSET_ODD=MOD(IGDTMPL(19)/8,2)
     I_OFFSET_EVEN=MOD(IGDTMPL(19)/4,2)
     IF(I_OFFSET_ODD/=I_OFFSET_EVEN)THEN
       IF(I_OFFSET_ODD==0) THEN
         IS1=(JM+1)/2
       ELSE
         IS1=JM/2
       ENDIF
     ENDIF
     NSCAN=MOD(IGDTMPL(19)/32,2)
   ELSEIF(IGDTNUM==10) THEN
     IM=IGDTMPL(8)
     JM=IGDTMPL(9)
     NM=IM*JM
     NSCAN=MOD(IGDTMPL(16)/32,2)
   ELSEIF(IGDTNUM==20) THEN
     IM=IGDTMPL(8)
     JM=IGDTMPL(9)
     NM=IM*JM
     NSCAN=MOD(IGDTMPL(18)/32,2)
   ELSEIF(IGDTNUM==30) THEN
     IM=IGDTMPL(8)
     JM=IGDTMPL(9)
     NM=IM*JM
     NSCAN=MOD(IGDTMPL(18)/32,2)
   ELSEIF(IGDTNUM==40)THEN
     IM=IGDTMPL(8)
     JM=IGDTMPL(9)
     NM=IM*JM
     NSCAN=MOD(IGDTMPL(19)/32,2)
   ELSE ! PROJECTION NOT RECOGNIZED
     RLAT=FILL
     RLON=FILL
     XPTS=FILL
     YPTS=FILL
     RETURN
   ENDIF
   IF(NM.LE.NPTS) THEN
     IF(IGDTNUM==1.AND.(I_OFFSET_ODD/=I_OFFSET_EVEN)) THEN
       KSCAN=I_OFFSET_ODD
       DO N=1,NM
         IF(NSCAN.EQ.0) THEN
           J=(N-1)/IM+1
           I=(N-IM*(J-1))*2-MOD(J+KSCAN,2)
         ELSE
           NN=(N*2)-1+KSCAN
           I = (NN-1)/JM + 1
           J = MOD(NN-1,JM) + 1
           IF (MOD(JM,2)==0.AND.MOD(I,2)==0.AND.KSCAN==0) J = J + 1
           IF (MOD(JM,2)==0.AND.MOD(I,2)==0.AND.KSCAN==1) J = J - 1
         ENDIF
         XPTS(N)=IS1+(I-(J-KSCAN))/2
         YPTS(N)=(I+(J-KSCAN))/2
       ENDDO
     ELSE
       DO N=1,NM
         IF(NSCAN.EQ.0) THEN
           J=(N-1)/IM+1
           I=N-IM*(J-1)
         ELSE
           I=(N-1)/JM+1
           J=N-JM*(I-1)
         ENDIF
         XPTS(N)=I
         YPTS(N)=J
       ENDDO
     ENDIF
     DO N=NM+1,NPTS
       XPTS(N)=FILL
       YPTS(N)=FILL
     ENDDO
   ELSE ! NM > NPTS
     RLAT=FILL
     RLON=FILL
     XPTS=FILL
     YPTS=FILL
     RETURN
   ENDIF
   IOPF=1
 ELSE  ! IOPT /= 0
   IOPF=IOPT
   IF(IGDTNUM==1) THEN
     I_OFFSET_ODD=MOD(IGDTMPL(19)/8,2)
     I_OFFSET_EVEN=MOD(IGDTMPL(19)/4,2)
   ENDIF
 ENDIF ! IOPT CHECK
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
!  EQUIDISTANT CYLINDRICAL
 IF(IGDTNUM==0) THEN
   CALL GDSWZD_EQUID_CYLIND(IGDTNUM,IGDTMPL,IGDTLEN,IOPF,NPTS,FILL, &
               XPTS,YPTS,RLON,RLAT,NRET, &
               CROT,SROT,XLON,XLAT,YLON,YLAT,AREA)
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
!  MERCATOR CYLINDRICAL
 ELSEIF(IGDTNUM==10) THEN
   CALL GDSWZD_MERCATOR(IGDTNUM,IGDTMPL,IGDTLEN,IOPF,NPTS,FILL,  &
               XPTS,YPTS,RLON,RLAT,NRET, &
               CROT,SROT,XLON,XLAT,YLON,YLAT,AREA)
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
!  LAMBERT CONFORMAL CONICAL
 ELSEIF(IGDTNUM==30) THEN
   CALL GDSWZD_LAMBERT_CONF(IGDTNUM,IGDTMPL,IGDTLEN,IOPF,NPTS,FILL, &
               XPTS,YPTS,RLON,RLAT,NRET, &
               CROT,SROT,XLON,XLAT,YLON,YLAT,AREA)
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
!  GAUSSIAN CYLINDRICAL
 ELSEIF(IGDTNUM==40) THEN
   CALL GDSWZD_GAUSSIAN(IGDTNUM,IGDTMPL,IGDTLEN,IOPF,NPTS,FILL, &
               XPTS,YPTS,RLON,RLAT,NRET, &
               CROT,SROT,XLON,XLAT,YLON,YLAT,AREA)
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
!  POLAR STEREOGRAPHIC AZIMUTHAL
 ELSEIF(IGDTNUM==20) THEN
   CALL GDSWZD_POLAR_STEREO(IGDTNUM,IGDTMPL,IGDTLEN,IOPF,NPTS,FILL, &
               XPTS,YPTS,RLON,RLAT,NRET, &
               CROT,SROT,XLON,XLAT,YLON,YLAT,AREA)
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
!  2-D E-STAGGERED ROTATED EQUIDISTANT CYLINDRICAL
 ELSEIF(IGDTNUM==1.AND.(I_OFFSET_ODD/=I_OFFSET_EVEN)) THEN
   CALL GDSWZD_ROT_EQUID_CYLIND_EGRID(IGDTNUM,IGDTMPL,IGDTLEN,IOPF,NPTS,FILL, &
               XPTS,YPTS,RLON,RLAT,NRET, &
               CROT,SROT,XLON,XLAT,YLON,YLAT,AREA)
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
!  2-D B-STAGGERED ROTATED EQUIDISTANT CYLINDRICAL
 ELSEIF(IGDTNUM==1) THEN
   CALL GDSWZD_ROT_EQUID_CYLIND(IGDTNUM,IGDTMPL,IGDTLEN,IOPF,NPTS,FILL, &
               XPTS,YPTS,RLON,RLAT,NRET, &
               CROT,SROT,XLON,XLAT,YLON,YLAT,AREA)
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
!  PROJECTION UNRECOGNIZED
 ELSE
   IF(IOPT.GE.0) THEN
     RLON=FILL
     RLAT=FILL
   ENDIF
   IF(IOPT.LE.0) THEN
     XPTS=FILL
     YPTS=FILL
   ENDIF
 ENDIF
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
 END SUBROUTINE GDSWZD

 END MODULE GDSWZD_MOD


! Created by EverLookNeverSee@GitHub on 4/14/20.
! This program tests whether input number is even or odd.
! Note: In this program the property of the integer division
! is used to distinguish between the odd and an even number.
program even_odd
    implicit none
    integer :: number
    print *, "Enter a positive integer: "
    read *, number
    if (number / 2 * 2 - number == 0) then
        print *, number, "is an even number."
    else
        print *, number, "is an odd number."
    end if
end program even_odd


	function csin(z1)
	complex csin, z1, z2
	dimension dummy(2)
	equivalence (a,z2,dummy(1)), (b,dummy(2))

	z2 = z1
	c = exp(b)
	d = 1.0/c
	b = cos(a)*(c-d)/2.0
	a = sin(a)*(c+d)/2.0
	csin = z2
	return
	end


      REAL FUNCTION slRVLG (R2000, D2000)
*+
*     - - - - -
*      R V L G
*     - - - - -
*
*  Velocity component in a given direction due to the combination
*  of the rotation of the Galaxy and the motion of the Galaxy
*  relative to the mean motion of the local group (single precision)
*
*  Given:
*     R2000,D2000   real    J2000.0 mean RA,Dec (radians)
*
*  Result:
*     Component of SOLAR motion in direction R2000,D2000 (km/s)
*
*  Sign convention:
*     The result is +ve when the Sun is receding from the
*     given point on the sky.
*
*  Reference:
*     IAU Trans 1976, 168, p201.
*
*  Called:
*     slCS2C, slVDV
*
*  P.T.Wallace   Starlink   June 1985
*
*  Copyright (C) 1995 Rutherford Appleton Laboratory
*
*  License:
*    This program is free software; you can redistribute it and/or modify
*    it under the terms of the GNU General Public License as published by
*    the Free Software Foundation; either version 2 of the License, or
*    (at your option) any later version.
*
*    This program is distributed in the hope that it will be useful,
*    but WITHOUT ANY WARRANTY; without even the implied warranty of
*    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
*    GNU General Public License for more details.
*
*    You should have received a copy of the GNU General Public License
*    along with this program (see SLA_CONDITIONS); if not, write to the
*    Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
*    Boston, MA  02110-1301  USA
*
*  Copyright (C) 1995 Association of Universities for Research in Astronomy Inc.
*-

      IMPLICIT NONE

      REAL R2000,D2000

      REAL VA(3), VB(3)

      REAL slVDV

*
*  Solar velocity due to Galactic rotation and translation
*
*  Speed = 300 km/s
*
*  Apex  = L2,B2  90deg, 0deg
*        = RA,Dec  21 12 01.1  +48 19 47  J2000.0
*
*  This is expressed in the form of a J2000.0 x,y,z vector:
*
*      VA(1) = X = -SPEED*COS(RA)*COS(DEC)
*      VA(2) = Y = -SPEED*SIN(RA)*COS(DEC)
*      VA(3) = Z = -SPEED*SIN(DEC)

      DATA VA / -148.23284, +133.44888, -224.09467 /

*  Convert given J2000 RA,Dec to x,y,z
      CALL slCS2C(R2000,D2000,VB)

*  Compute dot product with Solar motion vector
      slRVLG=slVDV(VA,VB)

      END


      SUBROUTINE PBCS(RXX,RYY,RIX,RIY)
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!!  periodic boundary condition for non-orthoganal boxes
!!  work in fractional space
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

      USE header_file
      IMPLICIT NONE

      REAL(kind = double) :: RXX,RYY,RIX,RIY,RAI,RBI

      CALL CARTFRAC(RXX,RYY,RAI,RBI)

      IF(RAI > 1.0d0) RAI = RAI - 1.0d0
      IF(RAI <  0.0d0) RAI = RAI + 1.0d0
      IF(RBI > 1.0d0) RBI = RBI - 1.0d0
      IF(RBI <  0.0d0) RBI = RBI + 1.0d0

      CALL FRACCART(RAI,RBI,RIX,RIY)

      END SUBROUTINE


!##############################################################################
! PROGRAM brentmin
!
! ## Finding the minimum of a function with simple constraints
!
! This code is published under the GNU General Public License v3
!                         (https://www.gnu.org/licenses/gpl-3.0.en.html)
!
! Authors: Hans Fehr and Fabian Kindermann
!          contact@ce-fortran.com
!
! #VC# VERSION: 1.0  (23 January 2018)
!
!##############################################################################
include "prog02_11m.f90"

program brentmin

    use globals
    use toolbox

    implicit none
    real*8 :: x, f, a, b

    ! initial interval and function values
    a = 0d0
    b = (W-p(1)*0.01d0)/p(2)

    ! set starting point
    x = (a+b)/2d0

    ! call minimizing routine
    call fminsearch(x, f, a, b, utility)

    ! output
    write(*,'(/a,f12.7)')' x_1 = ',(W-p(2)*x)/p(1)
    write(*,'(a,f12.7)')' x_2 = ',x
    write(*,'(a,f12.7)')' u   = ',-f

end program


	SUBROUTINE GR_CMPV  ( rmin, rmax, rint, maxlvl, nlvl, clvl,
     +			      iret )
C************************************************************************
C* GR_CMPV								*
C*									*
C* This subroutine defines contour levels, given the data range and	*
C* the contour interval.						*
C*									*
C* GR_CMPV  ( RMIN, RMAX, RINT, MAXLVL, NLVL, CLVL, IRET )		*
C*									*
C* Input parameters:							*
C*	RMIN		REAL		Minimum value			*
C*	RMAX		REAL		Maximum value			*
C*	RINT		REAL		Contour interval		*
C*	MAXLVL		INTEGER		Max number of contour levels	*
C*									*
C* Output parameters:							*
C*	NLVL		INTEGER		Number of contour levels	*
C*	CLVL (NLVL)	REAL		Contour levels			*
C*	IRET		INTEGER		Return code			*
C*					  0 = normal return 		*
C*					 -8 = invalid range		*
C**									*
C* Log:									*
C* M. desJardins/GSFC	 2/85						*
C* M. desJardins/GSFC	 9/88	Cleaned up for GEMPAK4			*
C* K. Brill/HPC		 8/02	Stop DO WHILE using KTMX		*
C************************************************************************
	INCLUDE		'GEMPRM.PRM'
C*
	REAL		clvl (*)
	LOGICAL		done
C*
	INCLUDE		'ERMISS.FNC'
C------------------------------------------------------------------------
	iret = 0
	nlvl = 0
C
C*	Check for errors in input.
C
	IF  ( ( rint .le. 0. ) .or. ( rmin .gt. rmax ) .or.
     +	      ( ERMISS ( rmin ) ) .or. ( ERMISS ( rmax ) ) .or.
     +	      ( ERMISS ( rint ) ) )  THEN
	    iret = -8
	    RETURN
	END IF
C
C*	Find multiplier to use for rint to compute minimum value.
C
	r   = ( rmin / rint )
	knt = INT ( r )
	IF  ( FLOAT (knt) .eq. knt )  knt = knt - 1
	IF  ( rmin .ge. 0. )  knt = knt + 1
	ktmx = INT ( rmax / rint ) + 1
C
C*	Add contour values until rmax is reached or until MAXLVL levels
C*	are generated.
C
	done = .false.
	DO WHILE  ( .not. done )
	    tval = knt * rint
	    IF  ( tval .ge. rmin )  THEN
		IF  ( tval .gt. rmax )  THEN
		    done = .true.
		  ELSE IF  ( nlvl .ge. maxlvl )  THEN
		    done = .true.
		  ELSE
		    nlvl = nlvl + 1
		    clvl ( nlvl ) = tval
		END IF
	    END IF
	    knt = knt + 1
	    IF ( knt .gt. ktmx ) done = .true.
	END DO
C*
	RETURN
	END