*###[ ffxb2p:
	subroutine ffxb2p(cb2i,cb1,cb0,ca0i,xp,xm1,xm2,piDpj,ier)
***#[*comment:***********************************************************
*									*
*	Compute the PV B2, the coefficients of p(mu)p(nu) and g(mu,nu)	*
*	of 1/(ipi^2)\int d^nQ Q(mu)Q(nu)/(Q^2-m_1^2)/((Q+p)^2-m_2^2)	*
*	originally based on aaxbx by Andre Aeppli.			*
*									*
*	Input:	cb1	   complex	vector two point function	*
*		cb0	   complex	scalar two point function	*
*		ca0i(2)	   complex	scalar onepoint function with	*
*						m1,m2			*
*		xp	   real		p.p in B&D metric		*
*		xm1,2	   real		m_1^2,m_2^2			*
*		piDpj(3,3) real		dotproducts between s1,s2,p	*
*		ier	   integer	digits lost so far		*
*									*
*	Output:	cb2i(2)	   complex	B21,B22: coeffs of p*p, g in B2	*
*									*
***#]*comment:***********************************************************
*  #[ declarations:
	implicit none
*
*	arguments
*
	integer ier
	DOUBLE PRECISION xp,xm1,xm2,piDpj(3,3)
	DOUBLE COMPLEX cb2i(2),cb1,cb0,ca0i(2)
*
*	local variables
*
	DOUBLE PRECISION dm1p,dm2p,dm1m2
*
*  #] declarations:
*  #[ work:
*
	dm1p = xm1 - xp
	dm2p = xm2 - xp
	dm1m2= xm1 - xm2
	call ffxb2q(cb2i,cb1,cb0,ca0i,xp,xm1,xm2,dm1p,dm2p,dm1m2,
     +		piDpj,ier)
*
*  #] work:
*###] ffxb2p:
	end
*###[ ffxb2q:
	subroutine ffxb2q(cb2i,cb1,cb0,ca0i,xp,xm1,xm2,dm1p,dm2p,dm1m2,
     +		piDpj,ier)
***#[*comment:***********************************************************
*									*
*	Compute the PV B2, the coefficients of p(mu)p(nu) and g(mu,nu)	*
*	of 1/(ipi^2)\int d^nQ Q(mu)Q(nu)/(Q^2-m_1^2)/((Q+p)^2-m_2^2)	*
*	originally based on aaxbx by Andre Aeppli.			*
*									*
*	Input:	cb1	   complex	vector two point function	*
*		cb0	   complex	scalar two point function	*
*		ca0i(2)	   complex	scalar onepoint function with	*
*						m1,m2			*
*		xp	   real		p.p in B&D metric		*
*		xm1,2	   real		m_1^2,m_2^2			*
*		piDpj(3,3) real		dotproducts between s1,s2,p	*
*		ier	   integer	digits lost so far		*
*									*
*	Output:	cb2i(2)	   complex	B21,B22: coeffs of p*p, g in B2	*
*									*
***#]*comment:***********************************************************
*  #[ declarations:
	implicit none
*
*	arguments
*
	integer ier
	DOUBLE PRECISION xp,xm1,xm2,dm1p,dm2p,dm1m2,piDpj(3,3)
	DOUBLE COMPLEX cb2i(2),cb1,cb0,ca0i(2)
*
*	local variables
*
	integer i,j,ier0,ier1
	logical llogmm
	DOUBLE PRECISION xmax,absc,xlam,slam,alp,bet,xmxp,dfflo3,xlo3,
     +		xmxsav,xnoe,xnoe2,xlogmm,dfflo1,rloss,
     +		qiDqj(3,3)
	DOUBLE COMPLEX cs(16),cc,csom,clo2,clo3,zfflo2,zfflo3
*
*	common blocks
*
	include 'ff.h'
*
*	statement function
*
	absc(cc) = abs(DBLE(cc)) + abs(DIMAG(cc))
*
*  #] declarations:
*  #[ test input:
	if ( ltest ) then
	    ier0 = ier
	    call ffdot2(qiDqj,xp,xm1,xm2,dm1p,dm2p,dm1m2,ier0)
	    rloss = xloss*DBLE(10)**(-mod(ier0,50))
	    do 20 j=1,3
		do 10 i=1,3
		    if ( rloss*abs(piDpj(i,j)-qiDqj(i,j)).gt.precx*
     +			abs(piDpj(i,j))) print *,'ffxb2q: error: piDpj('
     +			,i,j,') wrong: ',piDpj(i,j),qiDqj(i,j),
     +			piDpj(i,j)-qiDqj(i,j),ier0
   10		continue
   20	    continue
	endif
*  #] test input:
*  #[ normal case:
	ier0 = ier
	ier1 = ier
*
*	with thanks to Andre Aeppli, off whom I stole the original
*
	if ( xp .ne. 0) then
	    cs(1) = ca0i(2)
	    cs(2) = DBLE(xm1)*cb0
	    cs(3) = DBLE(2*piDpj(1,3))*cb1
	    cs(4) = (xm1+xm2)/2
	    cs(5) = -xp/6
	    cb2i(1) = cs(1) - cs(2) + 2*cs(3) - cs(4) - cs(5)
	    cb2i(2) = cs(1) + 2*cs(2) - cs(3) + 2*cs(4) + 2*cs(5)
	    xmax = max(absc(cs(2)),absc(cs(3)),absc(cs(4)),absc(cs(5)))
	    xmxsav = xmax
	    if ( absc(cb2i(1)) .ge. xloss*xmax ) goto 100
	    if ( lwrite ) then
		print *,'cb2i(1) = ',cb2i(1),xmax
		print *,'with cs '
		print '(i3,2e30.16)',1,cs(1),2,-cs(2),3,2*cs(3),4,
     +			-cs(4),5,-cs(5)
	    endif
*  #] normal case:
*  #[   improve: m1=m2:
*
*	    a relatively simple case: dm1m2 = 0 (bi0.frm)
*
	    if ( dm1m2.eq.0 .and. xm1.ne.0 ) then
		if ( xp.lt.0 ) then
		    slam = sqrt(xp**2-4*xm1*xp)
		    xlo3 = dfflo3((xp-slam)/(2*xm1),ier)
		    cs(1) = xp*(-1/DBLE(3) + slam/(4*xm1))
		    cs(2) = xp**2*(-slam/(4*xm1**2) - 3/(4*xm1))
		    cs(3) = xp**3/(4*xm1**2)
		    cs(4) = DBLE(xp/xm1)*ca0i(1)
		    cs(5) = xlo3/xp*(-xm1*slam)
		    cs(6) = xlo3*slam
		else
		    slam = isgnal*sqrt(-xp**2+4*xm1*xp)
		    clo3 = zfflo3(DCMPLX(DBLE(xp/(2*xm1)),
     +			DBLE(-slam/(2*xm1))),ier)
		    cs(1) = DBLE(xp)*DCMPLX(-1/DBLE(3),
     +			DBLE(slam/(4*xm1)))
		    cs(2) = DBLE(xp**2)*DCMPLX(DBLE(-3/(4*xm1)),
     +			DBLE(-slam/(4*xm1**2)))
		    cs(3) = DBLE(xp**3/(4*xm1**2))
		    cs(4) = DBLE(xp/xm1)*ca0i(1)
		    cs(5) = clo3*DCMPLX(DBLE(0),DBLE(-xm1*slam/xp))
		    cs(6) = clo3*DCMPLX(DBLE(0),DBLE(slam))
		endif
		csom = cs(1) + cs(2) + cs(3) + cs(4) + cs(5) + cs(6)
		xmxp = max(absc(cs(2)),absc(cs(3)),absc(cs(4)),
     +			absc(cs(5)),absc(cs(6)))
*
*		get rid of noise in the imaginary part
*
		if ( xloss*abs(DIMAG(csom)).lt.precc*abs(DBLE(csom)) )
     +			csom = DCMPLX(DBLE(csom),DBLE(0))
		if ( lwrite ) then
		    print *,'cb2i(1)+= ',csom,xmxp
		    print *,'with cs '
		    print '(i3,2e30.16)',(i,cs(i),i=1,6)
		endif
		if ( xmxp.lt.xmax ) then
		    cb2i(1) = csom
		    xmax = xmxp
		endif
		if ( absc(cb2i(1)).ge.xloss**2*xmax ) goto 100
	    endif
*  #]   improve: m1=m2:
*  #[   improve: |xp| < xm1 < xm2:
*
*	    try again (see bi.frm)
*
	    xlam =  4*(piDpj(1,3)**2 - xm1*xp)
	    if ( xm1.eq.0 .or. xm2.eq.0 ) then
	    	xlogmm = 0
	    elseif ( abs(dm1m2).lt.xloss*xm1 ) then
	    	xlogmm = dfflo1(dm1m2/xm1,ier)
	    else
	    	xlogmm = log(xm2/xm1)
	    endif
	    if ( xlam.gt.0 .and. abs(xp).lt.xloss*xm2 .and.
     +			xm1.lt.xm2 ) then
		slam = sqrt(xlam)
		alp = (2*xm1*xm2/(2*piDpj(1,2)+slam) + xm1)/(slam-dm1m2)
*		bet = [xm2-xm1-xp-slam]
		bet = 4*xm1*xp/(2*piDpj(1,3)+slam)
		cs(1) = DBLE(xp/xm2)*ca0i(2)
		cs(2) = xlogmm*bet*(-2*xm1**2*xm2 - 2*xm1**3)
     +		/((-dm1m2+slam)*(2*piDpj(1,2)+slam)*(2*piDpj(1,3)+slam))
		cs(3) = xlogmm*(-4*xp*xm1**3)
     +		/((-dm1m2+slam)*(2*piDpj(1,2)+slam)*(2*piDpj(1,3)+slam))
		xnoe = 1/(2*piDpj(2,3)+slam)
		xnoe2 = xnoe**2
		cs(4) = xnoe2*xm1*bet*(xp-4*xm2)
		cs(5) = xnoe2*xm1*2*xp*xm2
		cs(6) = xnoe2*xm1**2*bet
		cs(7) = xnoe2*xm1**2*4*xp
		cs(8) = xnoe2*bet*(xp*xm2+3*xm2**2)
		cs(9) = xnoe2*(-6*xp*xm2**2)
		cs(10)= xp*(7/6.d0 - 2*xm1*slam*xnoe2 +
     +			4*xm2*slam*xnoe2 - 2*slam*xnoe)
		cs(11)= xp**2*( -2*slam*xnoe2 )
		xlo3 = dfflo3(2*xp*xnoe,ier)
		cs(12) = xlo3*dm1m2**2*slam/xp**2
		cs(13) = xlo3*(xm1 - 2*xm2)*slam/xp
		cs(14) = xlo3*slam
		csom = 0
		xmxp = 0
		do 50 i=1,14
		    csom = csom + cs(i)
		    xmxp = max(xmxp,absc(cs(i)))
   50		continue
		if ( lwrite ) then
		    print *,'cb2i(1)+= ',csom,xmxp
		    print *,'with cs '
		    print '(i3,2e30.16)',(i,cs(i),i=1,14)
		endif
		if ( xmxp.lt.xmax ) then
		    cb2i(1) = csom
		    xmax = xmxp
		endif
		if ( absc(cb2i(1)).ge.xloss**2*xmax ) goto 100
	    endif
*  #]   improve: |xp| < xm1 < xm2:
*  #[   improve: |xp| < xm2 < xm1:
	    if ( xlam.gt.0 .and. abs(xp).lt.xloss*xm1 .and.
     +			xm2.lt.xm1 ) then
		slam = sqrt(xlam)
		alp = (2*xm2*xm1/(2*piDpj(1,2)+slam) + xm2)/(slam+dm1m2)
*		bet = [xm1-xm2-xp-slam]
		bet = 4*xm2*xp/(-2*piDpj(2,3)+slam)
		xnoe = 1/(-2*piDpj(1,3)+slam)
		xnoe2 = xnoe**2
		cs(1) = DBLE(xp/xm1)*ca0i(1)
		cs(2) = -xlogmm*bet*(12*xp*xm1*xm2+6*xp*xm2**2-
     +		6*xp**2*xm2-2*xm1*xm2**2-2*xm2**3)
     +		/((dm1m2+slam)*(2*piDpj(1,2)+slam)*(-2*piDpj(2,3)+slam))
		cs(3) = -xlogmm*(-24*xp*xm1**2*xm2-4*xp*xm2**3+36*
     +		xp**2*xm1*xm2+12*xp**2*xm2**2-12*xp**3*xm2)
     +		/((dm1m2+slam)*(2*piDpj(1,2)+slam)*(-2*piDpj(2,3)+slam))
		cs(4) = xnoe2*xm2*bet*(xp-4*xm1)
		cs(5) = xnoe2*xm2*(-10*xp*xm1)
		cs(6) = xnoe2*xm2**2*bet
		cs(7) = xnoe2*xm2**2*4*xp
		cs(8) = xnoe2*bet*(xp*xm1+3*xm1**2)
		cs(9) = xnoe2*6*xp*xm1**2
		cs(10)= xp*(7/6.d0 - 2*xm1*slam*xnoe2 +
     +			4*xm2*slam*xnoe2 - 2*slam*xnoe)
		cs(11)= xp**2*( -2*slam*xnoe2 )
		xlo3 = dfflo3(2*xp*xnoe,ier)
		cs(12) = xlo3*dm1m2**2*slam/xp**2
		cs(13) = xlo3*(xm1 - 2*xm2)*slam/xp
		cs(14) = xlo3*slam
		csom = 0
		xmxp = 0
		do 60 i=1,14
		    csom = csom + cs(i)
		    xmxp = max(xmxp,absc(cs(i)))
   60		continue
		if ( lwrite ) then
		    print *,'cb2i(1)+= ',csom,xmxp
		    print *,'with cs '
		    print '(i3,2e30.16)',(i,cs(i),i=1,14)
		endif
		if ( xmxp.lt.xmax ) then
		    cb2i(1) = csom
		    xmax = xmxp
		endif
		if ( absc(cb2i(1)).ge.xloss**2*xmax ) goto 100
	    endif
*  #]   improve: |xp| < xm2 < xm1:
*  #[   wrap up:
	    if ( lwarn ) then
		call ffwarn(225,ier0,absc(cb2i(1)),xmax)
		if ( lwrite ) then
		    print *,'xp,xm1,xm2 = ',xp,xm1,xm2
		endif
	    endif
  100	    continue
	    xmax = xmxsav
	    if ( absc(cb2i(2)) .lt. xloss**2*xmax ) then
		if ( lwrite ) then
		    print *,'cb2i(2) = ',cb2i(2),xmax
		    print *,'with cs '
		    print '(i3,2e30.16)',1,cs(1),2,2*cs(2),3,-cs(3),
     +			4,2*cs(4)
		endif
*
		if ( lwarn ) then
		    call ffwarn(226,ier1,absc(cb2i(2)),xmax)
		endif
  110		continue
		if ( lwrite ) print *,'cb2i(2)+= ',cb2i(2)
	    endif
	    cb2i(1) = DBLE(1/(3*xp)) * cb2i(1)
	    cb2i(2) = DBLE(1/6.d0)   * cb2i(2)
*  #]   wrap up:
*  #[ xp=0, m1!=m2:
	elseif (dm1m2 .ne. 0) then
*		#[ old code:
*		first calculate B21
*	    cs(1) = +DBLE(xm1*xm1/dm1m2) * ca0i(1)
*	    cs(2) = -     xm1*xm1/dm1m2  * xm1
*	    cs(3) = -DBLE((3*xm1**2-3*xm1*xm2+xm2**2)/dm1m2) * ca0i(2)
*	    cs(4) = +     (3*xm1**2-3*xm1*xm2+xm2**2)/dm1m2  * xm2
*	    cs(5) = (11*xm1**2-7*xm1*xm2+2*xm2**2)/6
**
*	    cb2i(2) = cs(1)+cs(2)+cs(3)+cs(4)+cs(5)
*	    if ( lwarn  ) then
*		xmax = max(absc(cs(1)),absc(cs(2)),absc(cs(3)),
*     +			absc(cs(4)),absc(cs(5)))
*		if ( absc(cb2i(2)) .lt. xloss*xmax )
*     +			call ffwarn(298,ier0,absc(cb2i(2)),xmax)
*	    endif
*	    cb2i(1)=1/(3*dm1m2**2) * cb2i(2)
*		 B22 in the same way as with xp diff from zero
*		 18-nov-1993 fixed sign error in cs(2) GJ
*	    cs(1) = ca0i(2)
*	    cs(2) =+DBLE(2*xm1)*cb0
*	    cs(3) = DBLE(dm1m2)*cb1
*	    cs(4) = xm1+xm2
*	    cb2i(2) = cs(1) + cs(2) + cs(3) + cs(4)
*	    if ( lwarn ) then
*		xmax = max(absc(cs(1)),absc(cs(3)),absc(cs(4)))
*		if ( absc(cb2i(2)) .lt. xloss*xmax )
*     +			call ffwarn(298,ier1,absc(cb2i(2)),xmax)
*	    endif
*	    cb2i(2) = cb2i(2)/6
*		#] old code:
*		#[ B21:
		llogmm = .FALSE.
*
*		B21 (see thesis, b21.frm)
*
		cs(1) = DBLE(xm1**2/3/dm1m2**3)*ca0i(1)
		cs(2) = DBLE((-xm1**2 + xm1*xm2 - xm2**2/3)/dm1m2**3)*
     +			ca0i(2)
		cs(3) = (5*xm1**3/18 - xm1*xm2**2/2 + 2*xm2**3/9)
     +			/dm1m2**3
		cb2i(1) = cs(1)+cs(2)+cs(3)
		xmax = max(absc(cs(2)),absc(cs(3)))
		if ( absc(cb2i(1)).gt.xloss**2*xmax ) goto 160
		if ( lwrite ) then
		    print *,'cb2i(1) = ',cb2i(1),xmax
		    print *,'with cs '
		    print '(i3,2e30.16)',(i,cs(i),i=1,3)
		endif
*
*		ma ~ mb
*
		if ( abs(dm1m2).lt.xloss*xm1 ) then
		    xlogmm = dfflo1(dm1m2/xm1,ier)
		else
		    xlogmm = log(xm2/xm1)
		endif
		llogmm = .TRUE.
		cs(1) = (xm1/dm1m2)/6
		cs(2) = (xm1/dm1m2)**2/3
		cs(3) = (xm1/dm1m2)**3*xlogmm/3
		cs(4) = -2/DBLE(9) + ca0i(1)*DBLE(1/(3*xm1))
		cs(5) = -xlogmm/3
		csom = cs(1)+cs(2)+cs(3)+cs(4)+cs(5)
		xmxp = max(absc(cs(2)),absc(cs(3)),absc(cs(4)),
     +			absc(cs(5)))
		if ( lwrite ) then
		    print *,'cb2i(1)+= ',csom,xmxp
		    print *,'with cs '
		    print '(i3,2e30.16)',(i,cs(i),i=1,5)
		endif
		if ( xmxp.lt.xmax ) then
		    xmax = xmxp
		    cb2i(1) = csom
		    if ( absc(cb2i(1)).gt.xloss**2*xmax ) goto 160
		endif
*
*		and last try
*
		xlo3 = dfflo3(dm1m2/xm1,ier)
		cs(1) = (dm1m2/xm1)**2/6
		cs(2) = (dm1m2/xm1)/3
		cs(3) = xlo3/(3*(dm1m2/xm1)**3)
*same		cs(4) = -2/DBLE(9) + ca0i(1)*DBLE(1/(3*xm1))
		cs(5) = -xlo3/3
		csom = cs(1)+cs(2)+cs(3)+cs(4)+cs(5)
		xmxp = max(absc(cs(2)),absc(cs(3)),absc(cs(4)),
     +			absc(cs(5)))
		if ( lwrite ) then
		    print *,'cb2i(1)+= ',csom,xmxp
		    print *,'with cs '
		    print '(i3,2e30.16)',(i,cs(i),i=1,5)
		endif
		if ( xmxp.lt.xmax ) then
		    xmax = xmxp
		    cb2i(1) = csom
		    if ( absc(cb2i(1)).gt.xloss**2*xmax ) goto 160
		endif
*
*		give up
*
		if ( lwarn ) then
		    call ffwarn(225,ier,absc(cb2i(1)),xmax)
		    if ( lwrite ) then
			print *,'xp,xm1,xm2 = ',xp,xm1,xm2
		    endif
		endif
  160		continue
*		#] B21:
*		#[ B22:
*
*		B22
*
		cs(1) = +DBLE(xm1/(4*dm1m2))*ca0i(1)
		cs(2) = -DBLE(xm2/(4*dm1m2))*ca0i(2)
		cs(3) = (xm1+xm2)/8
		cb2i(2) = cs(1) + cs(2) + cs(3)
		xmax = max(absc(cs(2)),absc(cs(3)))
		if ( absc(cb2i(2)).gt.xloss*xmax ) goto 210
		if ( lwrite ) then
		    print *,'cb2i(2) = ',cb2i(2),xmax
		    print *,'with cs '
		    print '(i3,2e30.16)',(i,cs(i),i=1,3)
		endif
*
*		second try, close together
*
		if ( .not.llogmm ) then
		    if ( abs(dm1m2).lt.xloss*xm1 ) then
		    	xlogmm = dfflo1(dm1m2/xm1,ier)
		    else
		    	xlogmm = log(xm2/xm1)
		    endif
		endif
		cs(1) = dm1m2*( -1/DBLE(8) - ca0i(1)*DBLE(1/(4*xm1)) )
		cs(2) = dm1m2*xlogmm/4
		cs(3) = xm1*(xm1/dm1m2)/4*xlogmm
		cs(4) = xm1*( 1/DBLE(4) + ca0i(1)*DBLE(1/(2*xm1)) )
		cs(5) = -xm1*xlogmm/2
		csom = cs(1) + cs(2) + cs(3) + cs(4) + cs(5)
		xmxp = max(absc(cs(2)),absc(cs(3)),absc(cs(4)),
     +			absc(cs(5)))
		if ( lwrite ) then
		    print *,'cb2i(2)+= ',csom,xmxp
		    print *,'with cs '
		    print '(i3,2e30.16)',(i,cs(i),i=1,2)
		endif
		if ( xmxp.lt.xmax ) then
		    xmax = xmxp
		    cb2i(2) = csom
		endif
		if ( absc(cb2i(2)).gt.xloss*xmax ) goto 210
*
*		give up
*
		if ( lwarn ) then
		    call ffwarn(226,ier,absc(cb2i(2)),xmax)
		    if ( lwrite ) then
			print *,'xp,xm1,xm2 = ',xp,xm1,xm2
		    endif
		endif
  210		continue
*		#] B22:
*  #] xp=0, m1!=m2:
*  #[ xp=0, m1==m2:
	else
*
*	    taken over from ffxb2a, which in turns stem from my thesis GJ
*
	    cb2i(1) = cb0/3
	    cb2i(2) = DBLE(xm1/2)*(cb0 + 1)
	endif
*  #] xp=0, m1==m2:
*  #[ finish up:
	ier = max(ier0,ier1)
*  #] finish up:
*###] ffxb2q:
	end


!
!     CalculiX - A 3-dimensional finite element program
!     Copyright (C) 1998-2021 Guido Dhondt
!
!     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(version 2);
!
!
!     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; if not, write to the Free Software
!     Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
!
      subroutine subtracthmatrix(neqp,aubh,adbh,aux,dp,jqp,irowp,b,
     &     theta1,dtimef)
!
!     transfer effect of H-matrix for compressible fluids to the
!     rhs
!
      implicit none
!
      integer i,j,neqp,ir,ic,jqp(*),irowp(*)
!
      real*8 aux(*),aubh(*),adbh(*),dp(*),value,constant,theta1,dtimef,
     &     b(*)
!
      do i=1,neqp
        aux(i)=adbh(i)*dp(i)
      enddo
!
      do ic=1,neqp
        do j=jqp(ic),jqp(ic+1)-1
          ir=irowp(j)
          value=aubh(j)
          aux(ir)=aux(ir)+value*dp(ic)
          aux(ic)=aux(ic)+value*dp(ir)
        enddo
      enddo
!
      constant=dtimef*dtimef*theta1
!
      do i=1,neqp
        b(i)=b(i)-constant*aux(i)
      enddo
!
      return
      end


module spline_int_module
USE nrtype
implicit none
private
public::spline
public::splint
contains

 ! *************************************************************
 ! new subroutine: spline
 ! *************************************************************
 SUBROUTINE spline(x,y,yp1,ypn,y2,err,message)
 ! computes 2nd derivatives of the interpolating function at tabulated points
 IMPLICIT NONE
 ! dummy variables
 REAL(DP), DIMENSION(:), INTENT(IN) :: x,y
 REAL(DP), INTENT(IN) :: yp1,ypn
 REAL(DP), DIMENSION(:), INTENT(OUT) :: y2
 integer(i4b),intent(out)      :: err
 character(*),intent(out)      :: message
 ! local variables
 character(len=128) :: cmessage
 INTEGER(I4B) :: n
 REAL(DP), DIMENSION(size(x)) :: a,b,c,r
 ! initialize error control
 err=0; message="f-spline/"
 ! check that the size of the vectors match
 if(size(x)/=size(y) .or. size(y)/=size(y2)) then
  err=20; message="f-spline/sizeMismatch"; return
 else
  n=size(x)
 end if
 ! start procedure
 c(1:n-1)=x(2:n)-x(1:n-1)
 r(1:n-1)=6.0_dp*((y(2:n)-y(1:n-1))/c(1:n-1))
 r(2:n-1)=r(2:n-1)-r(1:n-2)
 a(2:n-1)=c(1:n-2)
 b(2:n-1)=2.0_dp*(c(2:n-1)+a(2:n-1))
 b(1)=1.0
 b(n)=1.0
 if (yp1 > 0.99e30_dp) then
  r(1)=0.0
  c(1)=0.0
 else
  r(1)=(3.0_dp/(x(2)-x(1)))*((y(2)-y(1))/(x(2)-x(1))-yp1)
  c(1)=0.5
 end if
 if (ypn > 0.99e30_dp) then
  r(n)=0.0
  a(n)=0.0
 else
  r(n)=(-3.0_dp/(x(n)-x(n-1)))*((y(n)-y(n-1))/(x(n)-x(n-1))-ypn)
  a(n)=0.5
 end if
 call tridag(a(2:n),b(1:n),c(1:n-1),r(1:n),y2(1:n),err,cmessage)
 if (err/=0) message=trim(message)//trim(cmessage); return
 END SUBROUTINE spline

 ! *************************************************************
 ! new subroutine: splint
 ! *************************************************************
 SUBROUTINE splint(xa,ya,y2a,x,y,err,message)
 IMPLICIT NONE
 ! declare dummy variables
 REAL(DP), DIMENSION(:), INTENT(IN)  :: xa,ya,y2a
 REAL(DP), INTENT(IN)  :: x
 REAL(DP), INTENT(OUT) :: y
 integer(i4b),intent(out)      :: err
 character(*),intent(out)      :: message
 ! declare local variables
 INTEGER(I4B) :: khi,klo,n
 REAL(DP) :: a,b,h
 ! check size of input vectors
 if (size(xa)==size(ya) .and. size(ya)==size(y2a)) then
  n=size(xa)
 else
  err=20; message="f-splint/sizeMismatch"; return
 end if
 ! start procedure
 klo=max(min(locate(xa,x),n-1),1)
 khi=klo+1
 h=xa(khi)-xa(klo)
 if (h == 0.0_dp) then; err=20; message="f-splint/badXinput"; return; end if
 a=(xa(khi)-x)/h
 b=(x-xa(klo))/h
 y=a*ya(klo)+b*ya(khi)+((a**3-a)*y2a(klo)+(b**3-b)*y2a(khi))*(h**2)/6.0_dp
 END SUBROUTINE splint

 ! *************************************************************
 ! new subroutine: locate
 ! *************************************************************
 FUNCTION locate(xx,x)
 IMPLICIT NONE
 REAL(DP), DIMENSION(:), INTENT(IN) :: xx
 REAL(DP), INTENT(IN) :: x
 INTEGER(I4B) :: locate
 INTEGER(I4B) :: n,jl,jm,ju
 LOGICAL :: ascnd
 n=size(xx)
 ascnd = (xx(n) >= xx(1))
 jl=0
 ju=n+1
 do
  if (ju-jl <= 1) exit
  jm=(ju+jl)/2
  if (ascnd .eqv. (x >= xx(jm))) then
   jl=jm
  else
   ju=jm
  end if
 end do
 if (x == xx(1)) then
  locate=1
 else if (x == xx(n)) then
  locate=n-1
 else
  locate=jl
 end if
 END FUNCTION locate

 ! *************************************************************
 ! new subroutine: tridag
 ! *************************************************************
 SUBROUTINE tridag(a,b,c,r,u,err,message)
 IMPLICIT NONE
 ! dummy variables
 REAL(DP), DIMENSION(:), INTENT(IN) :: a,b,c,r
 REAL(DP), DIMENSION(:), INTENT(OUT) :: u
 integer(i4b),intent(out)      :: err
 character(*),intent(out)      :: message
 ! local variables
 REAL(DP), DIMENSION(size(b)) :: gam
 INTEGER(I4B) :: n,j
 REAL(DP) :: bet
 ! initialize error control
 err=0; message="f-spline/OK"
 ! check that the size of the vectors match
 if ( all((/size(b),size(c)+1,size(r),size(u)/) == size(a)+1) ) then
  n=size(a)+1
 else
  err=20; message="f-tridag/sizeMismatch"; return
 end if
 ! start procedure
 bet=b(1)
 if (bet == 0.0_dp) then; err=20; message="f-tridag/errorAtCodeStage-1"; return; end if
 u(1)=r(1)/bet
 do j=2,n
  gam(j)=c(j-1)/bet
  bet=b(j)-a(j-1)*gam(j)
  if (bet == 0.0_dp) then; err=20; message="f-tridag/errorAtCodeStage-2"; return; end if
  u(j)=(r(j)-a(j-1)*u(j-1))/bet
 end do
 do j=n-1,1,-1
  u(j)=u(j)-gam(j+1)*u(j+1)
 end do
 END SUBROUTINE tridag

end module spline_int_module


      module MOD_RKQS
      contains
      SUBROUTINE rkqs(y,dydx,n,x,htry,eps,yscal,hdid,hnext,derivs)

      use MOD_RKCK
      IMPLICIT REAL*8(A-H,O-Z)

      INTEGER n,NMAX
      REAL*8 eps,hdid,hnext,htry,x,dydx(n),y(n),yscal(n)
      EXTERNAL derivs
      PARAMETER (NMAX=50)
CU    USES derivs,rkck
      INTEGER i
      REAL*8 errmax,h,xnew,yerr(NMAX),ytemp(NMAX),SAFETY,PGROW,
     *PSHRNK,ERRCON
      PARAMETER (SAFETY=0.9,PGROW=-.2,PSHRNK=-.25,ERRCON=1.89d-4)
      h=htry
1     call rkck(y,dydx,n,x,h,ytemp,yerr,derivs)
      errmax=0.
      do 11 i=1,n
        errmax=max(errmax,abs(yerr(i)/yscal(i)))
11    continue
      errmax=errmax/eps
      if(errmax.gt.1.)then
        h=SAFETY*h*(errmax**PSHRNK)
        if(h.lt.0.1*h)then
          h=.1*h
        endif
        xnew=x+h
        if(xnew.eq.x)pause 'stepsize underflow in rkqs'
        goto 1
      else
        if(errmax.gt.ERRCON)then
          hnext=SAFETY*h*(errmax**PGROW)
        else
          hnext=5.*h
        endif
        hdid=h
        x=x+h
        do 12 i=1,n
          y(i)=ytemp(i)
12      continue
        return
      endif
      END subroutine
C  (C) Copr. 1986-92 Numerical Recipes Software 0-1$72#.
      end module


!==========================================================================
elemental function gsw_enthalpy_ice (t, p)
!==========================================================================
!
! Calculates the specific enthalpy of ice (h_Ih).
!
!  t  =  in-situ temperature (ITS-90)                             [ deg C ]
!  p  =  sea pressure                                              [ dbar ]
!        ( i.e. absolute pressure - 10.1325 dbar )
!
!  gsw_enthalpy_ice  :  specific enthalpy of ice                   [ J/kg ]
!--------------------------------------------------------------------------

use gsw_mod_teos10_constants, only : gsw_t0, db2pa

use gsw_mod_gibbs_ice_coefficients

use gsw_mod_kinds

implicit none

real (r8), intent(in) :: t, p

real (r8) :: gsw_enthalpy_ice

real (r8) :: tau, dzi, g0
complex (r8) :: r2, sqtau_t1, sqtau_t2, g

tau = (t + gsw_t0)*rec_tt

dzi = db2pa*p*rec_pt

g0 = g00 + dzi*(g01 + dzi*(g02 + dzi*(g03 + g04*dzi)))

r2 = r20 + dzi*(r21 + r22*dzi)

sqtau_t1 = (tau/t1)**2
sqtau_t2 = (tau/t2)**2

g = r1*t1*(log(1.0_r8 - sqtau_t1) + sqtau_t1) &
    + r2*t2*(log(1.0_r8 - sqtau_t2) + sqtau_t2)

gsw_enthalpy_ice = g0 + tt*real(g)

return
end function

!--------------------------------------------------------------------------


module sweeper_1D

  use control, only : dp

  implicit none

  contains

  subroutine apply_transport_operator_1D(phi)
    ! ##########################################################################
    ! Sweep over each cell, angle, and octant
    ! ##########################################################################

    ! Use Statements
    use angle, only : p_leg, wt, mu
    use mesh, only : dx
    use control, only : store_psi, number_angles_per_octant, number_cells, scatter_leg_order, &
                        number_legendre, number_groups, use_DGM, boundary_east, number_angles, &
                        boundary_west
    use state, only : mg_sig_t, sweep_count, mg_mMap, mg_incident_x, mg_psi, &
                      mg_source, sigphi
    use sources, only : compute_source
    use omp_lib, only : omp_get_wtime
    use dgm, only : delta_m, psi_m, dgm_order

    ! Variable definitions
    real(kind=dp), intent(inout), dimension(:,:,:) :: &
        phi           ! Scalar flux for current iteration and group g
    real(kind=dp), dimension(0:number_legendre, number_groups, number_cells) :: &
        phi_update    ! Container to hold the updated scalar flux
    integer :: &
        g,          & ! Group index
        o,          & ! Octant index
        oo,         & ! Octant order index
        c,          & ! Cell index
        mat,        & ! Material index
        a,          & ! Angle index
        an,         & ! Global angle index
        cmin,       & ! Lower cell number
        cmax,       & ! Upper cell number
        cstep,      & ! Cell stepping direction
        amin,       & ! Lower angle number
        amax,       & ! Upper angle number
        astep         ! Angle stepping direction
    real(kind=dp), dimension(0:number_legendre) :: &
        M           ! Legendre polynomial integration vector
    real(kind=dp), dimension(number_groups) :: &
        psi_center, & ! Angular flux at cell center
        source        ! Fission, In-Scattering, External source in group g
    integer, dimension(2) :: &
        octant_map    ! Map of the octant order
    logical :: &
        octant        ! Positive/Negative octant flag

    ! Increment the sweep counter
    sweep_count = sweep_count + 1

    ! Reset phi
    phi_update = 0.0_8

    ! Update the forcing function
    call compute_source()

    ! Change octant order if right boundary is vacuum
    if (boundary_east == 0.0 .and. boundary_west /= 0.0) then
      octant_map = [2, 1]
    else
      octant_map = [1, 2]
    end if

    do oo = 1, 2  ! Sweep over octants
      o = octant_map(oo)
      ! Sweep in the correct direction within the octant
      octant = o == 1
      amin = merge(1, number_angles_per_octant, octant)
      amax = merge(number_angles_per_octant, 1, octant)
      astep = merge(1, -1, octant)
      cmin = merge(1, number_cells, octant)
      cmax = merge(number_cells, 1, octant)
      cstep = merge(1, -1, octant)

      ! set boundary conditions
      if (o == 1) then
        mg_incident_x = boundary_west * mg_incident_x  ! Set albedo conditions
      else
        mg_incident_x = boundary_east * mg_incident_x  ! Set albedo conditions
      end if

      do c = cmin, cmax, cstep  ! Sweep over cells
        mat = mg_mMap(c)

        do a = amin, amax, astep  ! Sweep over angle
          ! Get the correct angle index
          an = merge(a, number_angles - a + 1, octant)

          ! legendre polynomial integration vector
          M = wt(a) * p_leg(:, an)

          ! Get the source in this cell, group, and angle
          source(:) = mg_source(:, c)
          source(:) = source(:) + matmul(transpose(sigphi(:scatter_leg_order,:,c)), p_leg(:scatter_leg_order,an))
          if (use_DGM) then
            source(:) = source(:) - delta_m(:, an, mg_mMap(c), dgm_order) * psi_m(0, :, an, c)
          end if

          call computeEQ(source(:), mg_sig_t(:, mat), dx(c), mu(a), mg_incident_x(:, a, 1, 1), psi_center)

          if (store_psi) then
            mg_psi(:, an, c) = psi_center(:)
          end if

          ! Loop over the energy groups
          do g = 1, number_groups

            ! Increment the legendre expansions of the scalar flux
            phi_update(:, g, c) = phi_update(:, g, c) + M(:) * psi_center(g)
          end do  ! End g loop
        end do  ! End a loop
      end do  ! End c loop
    end do  ! End o loop

    phi = phi_update

  end subroutine apply_transport_operator_1D

  subroutine computeEQ(S, sig, dx, mua, incident, cellPsi)
    ! ##########################################################################
    ! Compute the value for the closure relationship
    ! ##########################################################################

    ! Use statements
    use control, only : equation_type

    ! Variable definitions
    real(kind=dp), dimension(:), intent(inout) :: &
        incident ! Angular flux incident on the cell
    real(kind=dp), dimension(:), intent(in) :: &
        S,     & ! Source within the cell
        sig      ! Total cross section within the cell
    real(kind=dp), intent(in) :: &
        dx,    & ! Width of the cell
        mua      ! Angle for the cell
    real(kind=dp), dimension(:), intent(inout) :: &
        cellPsi  ! Angular flux at cell center
    real(kind=dp), allocatable, dimension(:) :: &
        tau,   & ! Parameter used in step characteristics
        A        ! Parameter used in step characteristics
    real(kind=dp) :: &
        invmu    ! Parameter used in diamond and step differences

    if (equation_type == 'DD') then
      ! Diamond Difference relationship
      invmu = dx / (2.0_8 * abs(mua))
      cellPsi(:) = (incident(:) + invmu * S(:)) / (1.0_8 + invmu * sig(:))
      incident(:) = 2.0_8 * cellPsi(:) - incident(:)
    else if (equation_type == 'SC') then
      ! Step Characteristics relationship
      allocate(tau(size(sig)), A(size(sig)))
      tau = sig(:) * dx / mua
      A = exp(-tau)
      cellPsi = incident * (1.0_8 - A) / tau + S * (sig * dx + mua * (A - 1.0_8)) / (sig ** 2.0_8 * dx)
      incident = A * incident + S * (1.0_8 - A) / sig
      deallocate(tau, A)
    else if (equation_type == 'SD') then
      ! Step Difference relationship
      invmu = dx / (abs(mua))
      cellPsi = (incident + invmu * S) / (1.0_8 + invmu * sig)
      incident = cellPsi
    else
      print *, 'ERROR : Equation not implemented'
      stop
    end if

  end subroutine computeEQ

end module sweeper_1D


      MODULE dopen_I
      INTERFACE
!...Generated by Pacific-Sierra Research 77to90  4.4G  10:47:01  03/09/06
      SUBROUTINE dopen (C, MDIM, NORBS, NDUBL, NSINGL, FRACT, SDM)
      USE vast_kind_param,ONLY: DOUBLE
      INTEGER, INTENT(IN) :: MDIM
      INTEGER, INTENT(IN) :: NORBS
      INTEGER, INTENT(IN) :: NDUBL
      INTEGER, INTENT(IN) :: NSINGL
      REAL(DOUBLE), INTENT(IN) :: FRACT
      REAL(DOUBLE), DIMENSION(MDIM,MDIM), INTENT(IN) :: C
      REAL(DOUBLE), DIMENSION((MDIM*(MDIM + 1))/2), INTENT(OUT) :: SDM
      END SUBROUTINE
      END INTERFACE
      END MODULE


module diag_module
  use precision_module, only : wp
  use error_module

  implicit none
  public

contains
!------------------------------------------------------------------------

!*****************************************************************************
!subroutine adiabatization(ediab1,ediab2,h12,h13,h14,eig)
!== Old version of the subroutine. Employs diagonalization of 4x4 matrix
!== with specific matrix elements - h12, h13, h14. Coded to model singlet-triplet
!== Intersystem Crossing.
!*****************************************************************************
!
!  integer           ::  OK, INFO
!  complex(wp)    ::  A(4,4), B(4), DUMMY(1,1), WORK(8)
!  complex(wp), intent(in)     ::  h12, h13, h14
!  real(wp), intent(in)   ::  ediab1, ediab2
!  real(wp), intent(out)  ::  eig(4)
!
!! define elements of matrix A for singlet-triplet intersections
!! define diagonal elements of matrix A
!      A(1,1)=ediab1
!      A(2,2)=ediab2
!      A(3,3)=ediab2
!      A(4,4)=ediab2
!! define upper-right elements of matrix A
!      A(1,2)=h12
!      A(1,3)=h13
!      A(1,4)=h14
!      A(2,3)=(0.0d0, 0.0d0)
!      A(2,4)=(0.0d0, 0.0d0)
!      A(3,4)=(0.0d0, 0.0d0)
!! define upper-right elements of matrix A
!      A(2,1)=DCONJG(A(1,2))
!      A(3,1)=DCONJG(A(1,3))
!      A(3,2)=DCONJG(A(2,3))
!      A(4,1)=DCONJG(A(1,4))
!      A(4,2)=DCONJG(A(2,4))
!      A(4,3)=DCONJG(A(3,4))
!
!! diagonalize matrix A and determine eigenvalues (adiabatic energies)
!      CALL ZGEEV('N', 'N', 4, A, 4, B, DUMMY, &
!                1, DUMMY, 1, WORK, 8, WORK, OK)
!
!      eig=real(B)
!
! sort adiabatic energies in increasing ('I') order
!      CALL DLASRT('I',4,eig,INFO)
!
!      IF (OK .ne. 0) THEN
!          call error_message(3)!error code in parentheses
!      ENDIF
!
subroutine adiabatization(ediab1,ediab2,eig)

use sort
use input_module, only : soc

real(wp), intent(in)  :: ediab1, ediab2
real(wp), intent(out) :: eig(2)
real(wp)              :: A(2,2)
integer               :: l, inf
real(wp)              :: work(2*(3+2/2))

A(1,1) = ediab1
A(2,2) = ediab2
A(1,2) = soc
A(2,1) = A(1,2)

l = 2*(3+2/2)

call dsyev('V','U',2,A,2,eig,work,l,inf)

! sort adiabatic energies in increasing ('I') order
call insert_sort(eig)

end subroutine adiabatization

!---------------------------------------------------------------------
end module diag_module


SUBROUTINE ZHBGVD_F95( AB, BB, W, UPLO, Z, INFO )
!
!  -- LAPACK95 interface driver routine (version 3.0) --
!     UNI-C, Denmark; Univ. of Tennessee, USA; NAG Ltd., UK
!     September, 2000
!
!  .. USE STATEMENTS ..
   USE LA_PRECISION, ONLY: WP =>  DP
   USE LA_AUXMOD, ONLY: ERINFO, LSAME
   USE F77_LAPACK, ONLY: HBGVD_F77 => LA_HBGVD
!  .. IMPLICIT STATEMENT ..
   IMPLICIT NONE
!  .. SCALAR ARGUMENTS ..
   CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO
   INTEGER, INTENT(OUT), OPTIONAL :: INFO
!  .. ARRAY ARGUMENTS ..
   COMPLEX(WP), INTENT(INOUT) :: AB(:,:), BB(:,:)
   REAL(WP), INTENT(OUT) :: W(:)
   COMPLEX(WP), INTENT(OUT), OPTIONAL, TARGET :: Z(:,:)
!----------------------------------------------------------------------
!
! Purpose
! =======
!
!    LA_SBGV, LA_SBGVD, LA_HBGV and LA_HBGVD compute all eigenvalues and,
! optionally, all eigenvectors of the generalized eigenvalue problem
!                    A*z = lambda*B*z,
! where A and B are real symmetric in the cases of LA_SBGV and LA_SBGVD
! and complex Hermitian in the cases of LA_HBGV and LA_HBGVD. Matrix B
! is positive definite. Matrices A and B are stored in a band format.
!    LA_SBGVD and LA_HBGVD use a divide and conquer algorithm. If
! eigenvectors are desired, they can be much faster than LA_SBGV and
! LA_HBGV for large matrices but use more workspace.
!
! =========
!
!         SUBROUTINE LA_SBGV / LA_SBGVD / LA_HBGV / LA_HBGVD( AB, BB, &
!                                        W, UPLO=uplo, Z=z, INFO=info )
!               <type>(<wp>), INTENT(INOUT) :: AB(:,:), BB(:,:)
!               REAL(<wp>), INTENT(OUT) :: W(:)
!               CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO
!               <type>(<wp>), INTENT(OUT), OPTIONAL :: Z(:,:)
!               INTEGER, INTENT(OUT), OPTIONAL :: INFO
!         where
!               <type> ::= REAL | COMPLEX
!               <wp>   ::= KIND(1.0) | KIND(1.0D0)
!
! Arguments
! =========
!
! AB      (input/output) REAL or COMPLEX array, shape (:,:) with
!         size(AB,1) = ka + 1 and size(AB,2) = n, where ka is the number
! 	  of subdiagonals or superdiagonals in the band and n is the
!    	  order of A and B.
!         On entry, the upper (if UPLO = 'U') or lower (if UPLO = 'L')
! 	  triangle of matrix A in band storage. The ka + 1 diagonals of
! 	  A are stored in the rows of AB so that the j-th column of A
!         is stored in the j-th column of AB as follows:
!         if UPLO = 'U', AB(ka+1+i-j,j) = A(i,j) for max(1,j-ka)<=i<=j,
! 	                                           1<=j<=n
!         if UPLO = 'L', AB(1+i-j,j)    = A(i,j) for j<=i<=min(n,j+ka),
! 	                                           1<=j<=n.
!         On exit, the contents of AB are destroyed.
! BB      (input/output) REAL or COMPLEX array, shape (:,:) with
!         size(BB,1) = kb + 1 and size(BB,2) = n, where kb is the number
! 	  of subdiagonals or superdiagonals in the band of B.
!         On entry, the upper (if UPLO = 'U') or lower (if UPLO = 'L')
! 	  triangle of matrix B in band storage. The kb + 1 diagonals of
! 	  B are stored in the rows of BB so that the j-th column of B
!         is stored in the j-th column of BB as follows:
!         if UPLO = 'U', BB(kb+1+i-j,j) = B(i,j) for max(1,j-kb)<=i<=j,
! 	                                           1<=j<=n
!         if UPLO = 'L', BB(1+i-j,j)    = B(i,j) for j<=i<=min(n,j+kb),
! 	                                           1<=j<=n.
!         On exit, the factor S from the split Cholesky factorization
! 	  B = S^H*S.
! W       (output) REAL array, shape (:) with size(W) = n.
!         The eigenvalues in ascending order.
! UPLO    Optional (input) CHARACTER(LEN=1).
!           = 'U': Upper triangles of A and B are stored;
!           = 'L': Lower triangles of A and B are stored.
!         Default value: 'U'.
! Z       Optional (output) REAL or COMPLEX square array, shape (:,:)
!         with size(Z,1) = n.
!         The matrix Z of eigenvectors, normalized so that Z^H*B*Z = I.
! INFO    Optional (output) INTEGER.
!         = 0: successful exit.
!         < 0: if INFO = -i, the i-th argument had an illegal value.
!         > 0: the algorithm failed to converge or matrix B is not
! 	    positive definite:
!            <= n: if INFO = i, i off-diagonal elements of an
! 	      intermediate tridiagonal form did not converge to
! 	      zero.
!            > n: if INFO = n+i, for 1<=i<=n, then the leading minor of
! 	      order i of B is not positive definite. The factorization
! 	      of B could not be completed and no eigenvalues or
! 	      eigenvectors were computed.
!         If INFO is not present and an error occurs, then the program is
! 	  terminated with an error message.
!-----------------------------------------------------------------------
!  .. LOCAL PARAMETERS ..
      CHARACTER(LEN=8), PARAMETER :: SRNAME = 'LA_HBGVD'
!  .. LOCAL SCALARS ..
      CHARACTER(LEN=1) :: LJOBZ, LUPLO
      INTEGER :: LINFO, N, ISTAT, ISTAT1, S1Z, S2Z, KAB, KBB, &
          LDAB, LDBB, LWORK, LIWORK, LRWORK, IWORKMIN(1)
!  .. LOCAL ARRAYS ..
      COMPLEX(WP), TARGET :: LLZ(1,1), WORKMIN(1)
      COMPLEX(WP), POINTER :: WORK(:)
      INTEGER, POINTER :: IWORK(:)
  REAL(WP), TARGET :: RWORKMIN(1)
  REAL(WP), POINTER :: RWORK(:)
!  .. INTRINSIC FUNCTIONS ..
      INTRINSIC SIZE, MAX, PRESENT
!  .. EXECUTABLE STATEMENTS ..
      LINFO = 0; KAB = SIZE(AB,1)-1; N = SIZE(AB,2); LDAB = MAX(SIZE(AB,1),1)
      ISTAT = 0; KBB = SIZE(BB,1)-1; LDBB = MAX(SIZE(BB,1),1)
      IF( PRESENT(Z) )THEN; S1Z = SIZE(Z,1); S2Z = SIZE(Z,2); LJOBZ = 'V'
      ELSE; S1Z = 1; S2Z = 1; LJOBZ = 'N'; END IF
        IF( PRESENT(UPLO) ) THEN; LUPLO = UPLO; ELSE; LUPLO = 'U'; END IF
!  .. TEST THE ARGUMENTS
          IF( KAB < 0 .OR. N < 0 ) THEN; LINFO = -1
          ELSE IF( KBB < 0 .OR. SIZE(BB,2) /= N ) THEN; LINFO = -2
          ELSE IF( SIZE(W) /= N )THEN; LINFO = -3
          ELSE IF( .NOT.LSAME(LUPLO,'U') .AND. .NOT.LSAME(LUPLO,'L') )THEN; LINFO = -4
          ELSE IF( PRESENT(Z) .AND. ( S1Z /= N .OR. S2Z /= N ) )THEN; LINFO = -5
          ELSE IF( N > 0 )THEN
	    LIWORK = -1
	    LRWORK = -1
	    LWORK = -1
	    IF (PRESENT (Z)) THEN
	     CALL HBGVD_F77(LJOBZ, LUPLO, N, KAB, KBB, AB, LDAB, BB, &
     &           LDBB, W, Z, S1Z, WORKMIN, LWORK, RWORKMIN, LRWORK, &
     &           IWORKMIN, LIWORK, LINFO )
             ELSE
	       CALL HBGVD_F77(LJOBZ, LUPLO, N, KAB, KBB, AB, LDAB, BB, &
     &           LDBB, W, LLZ, S1Z, WORKMIN, LWORK, RWORKMIN, LRWORK, &
     &           IWORKMIN, LIWORK, LINFO )
             ENDIF
             LWORK = WORKMIN(1)
	     LRWORK = RWORKMIN(1)
	     LIWORK = IWORKMIN(1)
! THEN NEXT 3 LINES SHOULD BE REMOVED WHEN THE BUG IS FIXED IN LAPACK77
            LWORK = 2 * LWORK + 1
	    LRWORK =2 * LRWORK + 1
	    LIWORK =2 * LIWORK + 1

            ALLOCATE(WORK(LWORK), RWORK(LRWORK), IWORK(LIWORK), STAT=ISTAT)
            IF( ISTAT == 0 )THEN
	      IF (PRESENT (Z)) THEN
	        CALL HBGVD_F77( LJOBZ, LUPLO, N, KAB, KBB, AB,LDAB, BB, &
     &            LDBB, W, Z, S1Z,  WORK, LWORK, RWORK, LRWORK, IWORK, &
     &            LIWORK, LINFO )
              ELSE
	        CALL HBGVD_F77( LJOBZ, LUPLO, N, KAB, KBB, AB,LDAB, BB, &
     &            LDBB, W, LLZ, S1Z,  WORK, LWORK, RWORK, LRWORK, IWORK, &
     &            LIWORK, LINFO )
              ENDIF
            ELSE; LINFO = -100; ENDIF
	    DEALLOCATE(WORK, RWORK, IWORK, STAT=ISTAT1)
	  ENDIF
	  CALL ERINFO(LINFO,SRNAME,INFO,ISTAT)
END SUBROUTINE ZHBGVD_F95


!
!     CalculiX - A 3-dimensional finite element program
!              Copyright (C) 1998-2018 Guido Dhondt
!
!     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(version 2);
!
!
!     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; if not, write to the Free Software
!     Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
!
      subroutine springdamp_n2f(xl,elas,voldl,s,imat,elcon,
     &  ncmat_,ntmat_,nope,iperturb,springarea,nmethod,mi,
     &  reltime,nasym)
!
!     calculates the contact damping matrix (node-to-face penalty)
!     (User's manual -> theory -> boundary conditions ->
!      node-to-face penalty contact)
!
      implicit none
!
      integer i,j,imat,ncmat_,ntmat_,k,l,nope,nterms,iflag,i1,
     &  iperturb(*),nmethod,mi(*),nasym
!
      real*8 xl(3,10),elas(21),ratio(9),pproj(3),val,shp2(7,9),
     &  al(3),s(60,60),voldl(0:mi(2),10),pl(3,10),xn(3),dm,
     &  c1,c2,c3,c4,elcon(0:ncmat_,ntmat_,*),xm(3),xmu(3,3,10),
     &  dxmu(3,10),dval(3,10),fpu(3,3,10),xi,et,xs2(3,7),xk,
     &  a11,a12,a22,b1(3,10),b2(3,10),dal(3,3,10),qxxy(3),fnl(3),
     &  qxyy(3),dxi(3,10),det(3,10),determinant,c11,c12,c22,
     &  qxyx(3),qyxy(3),springarea(2),dist,tu(3,3,10),
     &  clear,reltime,alnew(3)
!
      data iflag /4/
!
!     actual positions of the nodes belonging to the contact spring
!     (otherwise no contact force)
!
      do i=1,nope
         do j=1,3
            pl(j,i)=xl(j,i)+voldl(j,i)
         enddo
      enddo
!
!     contact springs
!
      nterms=nope-1
!
!     vector al connects the actual position of the slave node
!     with its projection on the master face = vec_r (User's
!     manual -> theory -> boundary conditions -> node-to-face
!     penalty contact)
!
      do i=1,3
         pproj(i)=pl(i,nope)
      enddo
      call attach_2d(pl,pproj,nterms,ratio,dist,xi,et)
      do i=1,3
         al(i)=pl(i,nope)-pproj(i)
      enddo
!
!     determining the jacobian vector on the surface
!
      if(nterms.eq.8) then
         call shape8q(xi,et,pl,xm,xs2,shp2,iflag)
      elseif(nterms.eq.4) then
         call shape4q(xi,et,pl,xm,xs2,shp2,iflag)
      elseif(nterms.eq.6) then
         call shape6tri(xi,et,pl,xm,xs2,shp2,iflag)
      else
         call shape3tri(xi,et,pl,xm,xs2,shp2,iflag)
      endif
!
!     d xi / d vec_u_j
!     d eta / d vec_u_j
!
!     dxi and det are determined from the orthogonality
!     condition
!
      a11=-(xs2(1,1)*xs2(1,1)+xs2(2,1)*xs2(2,1)+xs2(3,1)*xs2(3,1))
     &    +al(1)*xs2(1,5)+al(2)*xs2(2,5)+al(3)*xs2(3,5)
      a12=-(xs2(1,1)*xs2(1,2)+xs2(2,1)*xs2(2,2)+xs2(3,1)*xs2(3,2))
     &    +al(1)*xs2(1,6)+al(2)*xs2(2,6)+al(3)*xs2(3,6)
      a22=-(xs2(1,2)*xs2(1,2)+xs2(2,2)*xs2(2,2)+xs2(3,2)*xs2(3,2))
     &    +al(1)*xs2(1,7)+al(2)*xs2(2,7)+al(3)*xs2(3,7)
!
      do i=1,3
         do j=1,nterms
            b1(i,j)=shp2(4,j)*xs2(i,1)-shp2(1,j)*al(i)
            b2(i,j)=shp2(4,j)*xs2(i,2)-shp2(2,j)*al(i)
         enddo
         b1(i,nope)=-xs2(i,1)
         b2(i,nope)=-xs2(i,2)
      enddo
!
      determinant=a11*a22-a12*a12
      c11=a22/determinant
      c12=-a12/determinant
      c22=a11/determinant
!
      do i=1,3
         do j=1,nope
            dxi(i,j)=c11*b1(i,j)+c12*b2(i,j)
            det(i,j)=c12*b1(i,j)+c22*b2(i,j)
         enddo
      enddo
!
!     d vec_r / d vec_u_k
!
      do i=1,nope
         do j=1,3
            do k=1,3
               dal(j,k,i)=-xs2(j,1)*dxi(k,i)-xs2(j,2)*det(k,i)
            enddo
         enddo
      enddo
      do i=1,nterms
         do j=1,3
            dal(j,j,i)=dal(j,j,i)-shp2(4,i)
         enddo
      enddo
      do j=1,3
         dal(j,j,nope)=dal(j,j,nope)+1.d0
      enddo
!
!     d2q/dxx x dq/dy
!
      qxxy(1)=xs2(2,5)*xs2(3,2)-xs2(3,5)*xs2(2,2)
      qxxy(2)=xs2(3,5)*xs2(1,2)-xs2(1,5)*xs2(3,2)
      qxxy(3)=xs2(1,5)*xs2(2,2)-xs2(2,5)*xs2(1,2)
!
!     dq/dx x d2q/dyy
!
      qxyy(1)=xs2(2,1)*xs2(3,7)-xs2(3,1)*xs2(2,7)
      qxyy(2)=xs2(3,1)*xs2(1,7)-xs2(1,1)*xs2(3,7)
      qxyy(3)=xs2(1,1)*xs2(2,7)-xs2(2,1)*xs2(1,7)
!
!     Modified by Stefan Sicklinger
!
!     dq/dx x d2q/dxy
!
      qxyx(1)=xs2(2,1)*xs2(3,6)-xs2(3,1)*xs2(2,6)
      qxyx(2)=xs2(3,1)*xs2(1,6)-xs2(1,1)*xs2(3,6)
      qxyx(3)=xs2(1,1)*xs2(2,6)-xs2(2,1)*xs2(1,6)
!
!     d2q/dxy x dq/dy
!
      qyxy(1)=xs2(2,6)*xs2(3,2)-xs2(3,6)*xs2(2,2)
      qyxy(2)=xs2(3,6)*xs2(1,2)-xs2(1,6)*xs2(3,2)
      qyxy(3)=xs2(1,6)*xs2(2,2)-xs2(2,6)*xs2(1,2)
!
!
!     End modifications
!
!     normal on the surface
!
      dm=dsqrt(xm(1)*xm(1)+xm(2)*xm(2)+xm(3)*xm(3))
      do i=1,3
         xn(i)=xm(i)/dm
      enddo
!
!     distance from surface along normal (= clearance)
!
      clear=al(1)*xn(1)+al(2)*xn(2)+al(3)*xn(3)
      if(nmethod.eq.1) then
         clear=clear-springarea(2)*(1.d0-reltime)
      endif
!
!     representative area: usually the slave surface stored in
!     springarea; however, if no area was assigned because the
!     node does not belong to any element, the master surface
!     is used
!
      if(springarea(1).le.0.d0) then
         if(nterms.eq.3) then
            springarea(1)=dm/2.d0
         else
            springarea(1)=dm*4.d0
         endif
      endif
!
      elas(2)=-springarea(1)*elcon(5,1,imat)
      elas(1)=elas(2)*clear
!
!     contact force
!
      do i=1,3
         fnl(i)=-elas(1)*xn(i)
      enddo
!
!     derivatives of the jacobian vector w.r.t. the displacement
!     vectors (d m / d u_k)
!
      do k=1,nterms
         xmu(1,1,k)=0.d0
         xmu(2,2,k)=0.d0
         xmu(3,3,k)=0.d0
         xmu(1,2,k)=shp2(1,k)*xs2(3,2)-shp2(2,k)*xs2(3,1)
         xmu(2,3,k)=shp2(1,k)*xs2(1,2)-shp2(2,k)*xs2(1,1)
         xmu(3,1,k)=shp2(1,k)*xs2(2,2)-shp2(2,k)*xs2(2,1)
         xmu(1,3,k)=-xmu(3,1,k)
         xmu(2,1,k)=-xmu(1,2,k)
         xmu(3,2,k)=-xmu(2,3,k)
      enddo
      do i=1,3
         do j=1,3
            xmu(i,j,nope)=0.d0
         enddo
      enddo
!
!     correction due to change of xi and eta
!
      do k=1,nope
         do j=1,3
            do i=1,3
!
!     modified by Stefan Sicklinger
!
               xmu(i,j,k)=xmu(i,j,k)+(qxxy(i)+qxyx(i))*dxi(j,k)
     &                                +(qxyy(i)+qyxy(i))*det(j,k)
            enddo
         enddo
      enddo
!
!     derivatives of the size of the jacobian vector w.r.t. the
!     displacement vectors (d ||m||/d u_k)
!
      do k=1,nope
         do i=1,3
            dxmu(i,k)=xn(1)*xmu(1,i,k)+xn(2)*xmu(2,i,k)+
     &           xn(3)*xmu(3,i,k)
         enddo
!
!        auxiliary variable: (d clear d u_k)*||m||
!
         do i=1,3
            dval(i,k)=al(1)*xmu(1,i,k)+al(2)*xmu(2,i,k)+
     &               al(3)*xmu(3,i,k)-clear*dxmu(i,k)+
     &               xm(1)*dal(1,i,k)+xm(2)*dal(2,i,k)+xm(3)*dal(3,i,k)
         enddo
!
      enddo
!
      c1=1.d0/dm
      c2=c1*c1
      c3=elas(2)*c2
      c4=elas(1)*c1
!
!     derivatives of the forces w.r.t. the displacement vectors
!
      do k=1,nope
         do j=1,3
            do i=1,3
               fpu(i,j,k)=-c3*xm(i)*dval(j,k)
     &                    +c4*(xn(i)*dxmu(j,k)-xmu(i,j,k))
            enddo
         enddo
      enddo
!
!     tangential damping
!
      if(elcon(8,1,imat).gt.0.d0) then
!
!     stiffness of shear stress versus slip curve
!
         xk=elcon(8,1,imat)*elcon(5,1,imat)*springarea(1)
!
!     calculating the relative displacement between the slave node
!     and its projection on the master surface
!
         do i=1,3
            alnew(i)=voldl(i,nope)
            do j=1,nterms
               alnew(i)=alnew(i)-ratio(j)*voldl(i,j)
            enddo
         enddo
!
!     calculating the difference in relative displacement since
!     the start of the increment = vec_s
!
         do i=1,3
            al(i)=alnew(i)
         enddo
!
!     s=||vec_s||
!
         val=al(1)*xn(1)+al(2)*xn(2)+al(3)*xn(3)
!
!     d vec_s/ d vec_u_k
!     notice: xi & et are const.
!
         do k=1,nope
            do i=1,3
               do j=1,3
                  dal(i,j,k)=0.d0
               enddo
            enddo
         enddo
!
         do i=1,nterms
            do j=1,3
               dal(j,j,i)=-shp2(4,i)
            enddo
         enddo
!
         do j=1,3
            dal(j,j,nope)=1.d0
         enddo
!
!     d s/ dvec_u_k.||m||
!
         do k=1,nope
            do i=1,3
               dval(i,k)=al(1)*xmu(1,i,k)+al(2)*xmu(2,i,k)
     &              +al(3)*xmu(3,i,k)-val*dxmu(i,k)
     &              +xm(1)*dal(1,i,k)+xm(2)*dal(2,i,k)
     &              +xm(3)*dal(3,i,k)
            enddo
         enddo
!
!     d vec_t/d vec_u_k
!
         do k=1,nope
            do j=1,3
               do i=1,3
                  tu(i,j,k)=dal(i,j,k)
     &                 -c1*(xn(i)*(dval(j,k)-val*dxmu(j,k))
     &                 +val*xmu(i,j,k))
               enddo
            enddo
         enddo
!
!     damping matrix
!
         do k=1,nope
            do j=1,3
               do i=1,3
                  fpu(i,j,k)=fpu(i,j,k)+xk*tu(i,j,k)
               enddo
            enddo
         enddo
      endif
!
!     determining the damping matrix contributions
!
!     complete field shp2
!
      shp2(1,nope)=0.d0
      shp2(2,nope)=0.d0
      shp2(4,nope)=-1.d0
!
      do k=1,nope
         do l=1,nope
            do i=1,3
               i1=i+(k-1)*3
               do j=1,3
                  s(i1,j+(l-1)*3)=-shp2(4,k)*fpu(i,j,l)
     &                            -shp2(1,k)*fnl(i)*dxi(j,l)
     &                            -shp2(2,k)*fnl(i)*det(j,l)
               enddo
            enddo
         enddo
      enddo
!
!     symmetrizing the matrix
!     this is done in the absence of friction or for modal dynamic
!     calculations
!
      if((nasym.eq.0).or.((nmethod.eq.4).and.(iperturb(1).le.1))) then
         do j=1,3*nope
            do i=1,j-1
               s(i,j)=(s(i,j)+s(j,i))/2.d0
            enddo
         enddo
      endif
!
      return
      end


!-----------------------------------------------------------------------
! Skeleton 3D Electromagnetic PIC code
! written by Viktor K. Decyk, UCLA
      program bpic3
! #include "bpush3.h"
      implicit none
! indx/indy/indz = exponent which determines grid points in x/y/z
! direction: nx = 2**indx, ny = 2**indy, nz = 2**indz.
      integer, parameter :: indx =   7, indy =   7, indz =   7
! npx/npy/npz = number of electrons distributed in x/y/z direction.
      integer, parameter :: npx =  384, npy =   384, npz =   384
! ndim = number of velocity coordinates = 3
      integer, parameter :: ndim = 3
! tend = time at end of simulation, in units of plasma frequency.
! dt = time interval between successive calculations.
! qme = charge on electron, in units of e.
      real, parameter :: tend = 10.0, dt = 0.035, qme = -1.0
! vtx/vty/vtz = thermal velocity of electrons in x/y/z direction
      real, parameter :: vtx = 1.0, vty = 1.0, vtz = 1.0
! vx0/vy0/vz0 = drift velocity of electrons in x/y/z direction
      real, parameter :: vx0 = 0.0, vy0 = 0.0, vz0 = 0.0
! ax/ay/az = smoothed particle size in x/y/z direction
! ci = reciprocal of velocity of light.
      real :: ax = .912871, ay = .912871, az = .912871, ci = 0.1
! idimp = number of particle coordinates = 6
! ipbc = particle boundary condition: 1 = periodic
! sortime = number of time steps between standard electron sorting
! relativity = (no,yes) = (0,1) = relativity is used
      integer :: idimp = 6, ipbc = 1, sortime = 20, relativity = 1
! wke/we = particle kinetic/electrostatic field energy
! wf/wm/wt = magnetic field/transverse electric field/total energy
      real :: wke = 0.0, we = 0.0, wf = 0.0, wm = 0.0, wt = 0.0
! declare scalars for standard code
      integer :: np, nx, ny, nz, nxh, nyh, nzh, nxe, nye, nze, nxeh
      integer :: nxyzh, nxhyz, ny1, nyz1, ntime, nloop, isign
      real :: qbme, affp, dth
!
! declare arrays for standard code:
! part, part2 = particle arrays
      real, dimension(:,:), pointer :: part, part2, tpart
! qe = electron charge density with guard cells
      real, dimension(:,:,:), pointer :: qe
! cue = electron current density with guard cells
! fxyze/bxyze = smoothed electric/magnetic field with guard cells
      real, dimension(:,:,:,:), pointer :: cue, fxyze, bxyze
! exyz/bxyz = transverse electric/magnetic field in fourier space
      complex, dimension(:,:,:,:), pointer :: exyz, bxyz
! ffc = form factor array for poisson solver
      complex, dimension(:,:,:), pointer :: ffc
! mixup = bit reverse table for FFT
      integer, dimension(:), pointer :: mixup
! sct = sine/cosine table for FFT
      complex, dimension(:), pointer :: sct
! npic = scratch array for reordering particles
      integer, dimension(:), pointer :: npic
!
! declare and initialize timing data
      real :: time
      integer, dimension(4) :: itime
      real :: tdpost = 0.0, tguard = 0.0, tfft = 0.0, tfield = 0.0
      real :: tdjpost = 0.0, tpush = 0.0, tsort = 0.0
      double precision :: dtime
!
! initialize scalars for standard code
! np = total number of particles in simulation
! nx/ny/nz = number of grid points in x/y direction
      np = npx*npy*npz; nx = 2**indx; ny = 2**indy; nz = 2**indz
      nxh = nx/2; nyh = max(1,ny/2); nzh = max(1,nz/2)
      nxe = nx + 2; nye = ny + 1; nze = nz + 1; nxeh = nxe/2
      nxyzh = max(nx,ny,nz)/2; nxhyz = max(nxh,ny,nz)
      ny1 = ny + 1; nyz1 = ny1*(nz + 1)
! nloop = number of time steps in simulation
! ntime = current time step
      nloop = tend/dt + .0001; ntime = 0
      qbme = qme
      affp = real(nx)*real(ny)*real(nz)/real(np)
      dth = 0.0
!
! allocate data for standard code
      allocate(part(idimp,np))
      if (sortime > 0) allocate(part2(idimp,np))
      allocate(qe(nxe,nye,nze),fxyze(ndim,nxe,nye,nze))
      allocate(cue(ndim,nxe,nye,nze),bxyze(ndim,nxe,nye,nze))
      allocate(exyz(ndim,nxeh,nye,nze),bxyz(ndim,nxeh,nye,nze))
      allocate(ffc(nxh,nyh,nzh),mixup(nxhyz),sct(nxyzh))
      allocate(npic(nyz1))
!
! prepare fft tables
      call CWFFT3RINIT(mixup,sct,indx,indy,indz,nxhyz,nxyzh)
! calculate form factors
      isign = 0
      call CPOIS33(qe,fxyze,isign,ffc,ax,ay,az,affp,we,nx,ny,nz,nxeh,nye&
     &,nze,nxh,nyh,nzh)
! initialize electrons
      call CDISTR3(part,vtx,vty,vtz,vx0,vy0,vz0,npx,npy,npz,idimp,np,nx,&
     &ny,nz,ipbc)
!
! initialize transverse electromagnetic fields
      exyz = cmplx(0.0,0.0)
      bxyz = cmplx(0.0,0.0)
!
      if (dt > 0.37*ci) then
         write (*,*) 'Warning: Courant condition may be exceeded!'
      endif
!
! * * * start main iteration loop * * *
!
  500 if (nloop <= ntime) go to 2000
!     write (*,*) 'ntime = ', ntime
!
! deposit current with standard procedure: updates part, cue
      call dtimer(dtime,itime,-1)
      cue = 0.0
      if (relativity==1) then
         call CGRJPOST3L(part,cue,qme,dth,ci,np,idimp,nx,ny,nz,nxe,nye, &
     &nze,ipbc)
      else
         call CGJPOST3L(part,cue,qme,dth,np,idimp,nx,ny,nz,nxe,nye,nze, &
     &ipbc)
      endif
      call dtimer(dtime,itime,1)
      time = real(dtime)
      tdjpost = tdjpost + time
!
! deposit charge with standard procedure: updates qe
      call dtimer(dtime,itime,-1)
      qe = 0.0
      call CGPOST3L(part,qe,qme,np,idimp,nxe,nye,nze)
      call dtimer(dtime,itime,1)
      time = real(dtime)
      tdpost = tdpost + time
!
! add guard cells with standard procedure: updates cue, qe
      call dtimer(dtime,itime,-1)
      call CACGUARD3L(cue,nx,ny,nz,nxe,nye,nze)
      call CAGUARD3L(qe,nx,ny,nz,nxe,nye,nze)
      call dtimer(dtime,itime,1)
      time = real(dtime)
      tguard = tguard + time
!
! transform charge to fourier space with standard procedure: updates qe
      call dtimer(dtime,itime,-1)
      isign = -1
      call CWFFT3RX(qe,isign,mixup,sct,indx,indy,indz,nxeh,nye,nze,nxhyz&
     &,nxyzh)
      call dtimer(dtime,itime,1)
      time = real(dtime)
      tfft = tfft + time
!
! transform current to fourier space with standard procedure: update cue
      call dtimer(dtime,itime,-1)
      isign = -1
      call CWFFT3R3(cue,isign,mixup,sct,indx,indy,indz,nxeh,nye,nze,    &
     &nxhyz,nxyzh)
      call dtimer(dtime,itime,1)
      time = real(dtime)
      tfft = tfft + time
!
! take transverse part of current with standard procedure: updates cue
      call dtimer(dtime,itime,-1)
      call CCUPERP3(cue,nx,ny,nz,nxeh,nye,nze)
      call dtimer(dtime,itime,1)
      time = real(dtime)
      tfield = tfield + time
!
! calculate electromagnetic fields in fourier space with standard
! procedure: updates exyz, bxyz, wf, wm
      call dtimer(dtime,itime,-1)
      if (ntime==0) then
         call CIBPOIS33(cue,bxyz,ffc,ci,wm,nx,ny,nz,nxeh,nye,nze,nxh,nyh&
     &,nzh)
         wf = 0.0
         dth = 0.5*dt
      else
         call CMAXWEL3(exyz,bxyz,cue,ffc,ci,dt,wf,wm,nx,ny,nz,nxeh,nye, &
     &nze,nxh,nyh,nzh)
      endif
      call dtimer(dtime,itime,1)
      time = real(dtime)
      tfield = tfield + time
!
! calculate force/charge in fourier space with standard procedure:
! updates fxyze, we
      call dtimer(dtime,itime,-1)
      isign = -1
      call CPOIS33(qe,fxyze,isign,ffc,ax,ay,az,affp,we,nx,ny,nz,nxeh,nye&
     &,nze,nxh,nyh,nzh)
      call dtimer(dtime,itime,1)
      time = real(dtime)
      tfield = tfield + time
!
! add longitudinal and transverse electric fields with standard
! procedure: updates fxyze
      call dtimer(dtime,itime,-1)
      isign = 1
      call CEMFIELD3(fxyze,exyz,ffc,isign,nx,ny,nz,nxeh,nye,nze,nxh,nyh,&
     &nzh)
! copy magnetic field with standard procedure: updates bxyze
      isign = -1
      call CEMFIELD3(bxyze,bxyz,ffc,isign,nx,ny,nz,nxeh,nye,nze,nxh,nyh,&
     &nzh)
      call dtimer(dtime,itime,1)
      time = real(dtime)
      tfield = tfield + time
!
! transform electric force to real space with standard procedure:
! updates fxyze
      call dtimer(dtime,itime,-1)
      isign = 1
      call CWFFT3R3(fxyze,isign,mixup,sct,indx,indy,indz,nxeh,nye,nze,  &
     &nxhyz,nxyzh)
      call dtimer(dtime,itime,1)
      time = real(dtime)
      tfft = tfft + time
!
! transform magnetic force to real space with standard procedure:
! updates bxyze
      call dtimer(dtime,itime,-1)
      isign = 1
      call CWFFT3R3(bxyze,isign,mixup,sct,indx,indy,indz,nxeh,nye,nze,  &
     &nxhyz,nxyzh)
      call dtimer(dtime,itime,1)
      time = real(dtime)
      tfft = tfft + time
!
! copy guard cells with standard procedure: updates fxyze, bxyze
      call dtimer(dtime,itime,-1)
      call CCGUARD3L(fxyze,nx,ny,nz,nxe,nye,nze)
      call CCGUARD3L(bxyze,nx,ny,nz,nxe,nye,nze)
      call dtimer(dtime,itime,1)
      time = real(dtime)
      tguard = tguard + time
!
! push particles with standard procedure: updates part, wke
      wke = 0.0
      call dtimer(dtime,itime,-1)
      if (relativity==1) then
         call CGRBPUSH3L(part,fxyze,bxyze,qbme,dt,dth,ci,wke,idimp,np,nx&
     &,ny,nz,nxe,nye,nze,ipbc)
      else
         call CGBPUSH3L(part,fxyze,bxyze,qbme,dt,dth,wke,idimp,np,nx,ny,&
     &nz,nxe,nye,nze,ipbc)
      endif
      call dtimer(dtime,itime,1)
      time = real(dtime)
      tpush = tpush + time
!
! sort particles by cell for standard procedure
      if (sortime > 0) then
         if (mod(ntime,sortime)==0) then
            call dtimer(dtime,itime,-1)
            call CDSORTP3YZL(part,part2,npic,idimp,np,ny1,nyz1)
! exchange pointers
            tpart => part
            part => part2
            part2 => tpart
            call dtimer(dtime,itime,1)
            time = real(dtime)
            tsort = tsort + time
         endif
      endif
!
      if (ntime==0) then
         wt = we + wf + wm
         write (*,*) 'Initial Total Field, Kinetic and Total Energies:'
         write (*,'(3e14.7)') wt, wke, wke + wt
         write (*,*) 'Initial Electrostatic, Transverse Electric and Mag&
     &netic Field Energies:'
         write (*,'(3e14.7)') we, wf, wm
      endif
      ntime = ntime + 1
      go to 500
 2000 continue
!
! * * * end main iteration loop * * *
!
      write (*,*) 'ntime, relativity = ', ntime, relativity
      wt = we + wf + wm
      write (*,*) 'Final Total Field, Kinetic and Total Energies:'
      write (*,'(3e14.7)') wt, wke, wke + wt
      write (*,*) 'Final Electrostatic, Transverse Electric and Magnetic&
     & Field Energies:'
      write (*,'(3e14.7)') we, wf, wm
!
      write (*,*)
      write (*,*) 'deposit time = ', tdpost
      write (*,*) 'current deposit time = ', tdjpost
      tdpost = tdpost + tdjpost
      write (*,*) 'total deposit time = ', tdpost
      write (*,*) 'guard time = ', tguard
      write (*,*) 'solver time = ', tfield
      write (*,*) 'fft time = ', tfft
      write (*,*) 'push time = ', tpush
      write (*,*) 'sort time = ', tsort
      tfield = tfield + tguard + tfft
      write (*,*) 'total solver time = ', tfield
      time = tdpost + tpush + tsort
      write (*,*) 'total particle time = ', time
      wt = time + tfield
      write (*,*) 'total time = ', wt
      write (*,*)
!
      wt = 1.0e+09/(real(nloop)*real(np))
      write (*,*) 'Push Time (nsec) = ', tpush*wt
      write (*,*) 'Deposit Time (nsec) = ', tdpost*wt
      write (*,*) 'Sort Time (nsec) = ', tsort*wt
      write (*,*) 'Total Particle Time (nsec) = ', time*wt
!
      stop
      end program


      SUBROUTINE LDP(G,MG,M,N,H,X,XNORM,W,INDEX,MODE)

C                     T
C     MINIMIZE   1/2 X X    SUBJECT TO   G * X >= H.

C       C.L. LAWSON, R.J. HANSON: 'SOLVING LEAST SQUARES PROBLEMS'
C       PRENTICE HALL, ENGLEWOOD CLIFFS, NEW JERSEY, 1974.

C     PARAMETER DESCRIPTION:

C     G(),MG,M,N   ON ENTRY G() STORES THE M BY N MATRIX OF
C                  LINEAR INEQUALITY CONSTRAINTS. G() HAS FIRST
C                  DIMENSIONING PARAMETER MG
C     H()          ON ENTRY H() STORES THE M VECTOR H REPRESENTING
C                  THE RIGHT SIDE OF THE INEQUALITY SYSTEM

C     REMARK: G(),H() WILL NOT BE CHANGED DURING CALCULATIONS BY LDP

C     X()          ON ENTRY X() NEED NOT BE INITIALIZED.
C                  ON EXIT X() STORES THE SOLUTION VECTOR X IF MODE=1.
C     XNORM        ON EXIT XNORM STORES THE EUCLIDIAN NORM OF THE
C                  SOLUTION VECTOR IF COMPUTATION IS SUCCESSFUL
C     W()          W IS A ONE DIMENSIONAL WORKING SPACE, THE LENGTH
C                  OF WHICH SHOULD BE AT LEAST (M+2)*(N+1) + 2*M
C                  ON EXIT W() STORES THE LAGRANGE MULTIPLIERS
C                  ASSOCIATED WITH THE CONSTRAINTS
C                  AT THE SOLUTION OF PROBLEM LDP
C     INDEX()      INDEX() IS A ONE DIMENSIONAL INTEGER WORKING SPACE
C                  OF LENGTH AT LEAST M
C     MODE         MODE IS A SUCCESS-FAILURE FLAG WITH THE FOLLOWING
C                  MEANINGS:
C          MODE=1: SUCCESSFUL COMPUTATION
C               2: ERROR RETURN BECAUSE OF WRONG DIMENSIONS (N.LE.0)
C               3: ITERATION COUNT EXCEEDED BY NNLS
C               4: INEQUALITY CONSTRAINTS INCOMPATIBLE

      DOUBLE PRECISION G,H,X,XNORM,W,U,V,
     .                 ZERO,ONE,FAC,RNORM,DNRM2,DDOT,DIFF
      INTEGER          INDEX,I,IF,IW,IWDUAL,IY,IZ,J,M,MG,MODE,N,N1
      DIMENSION        G(MG,N),H(M),X(N),W(*),INDEX(M)
      DIFF(U,V)=       U-V
      DATA             ZERO,ONE/0.0D0,1.0D0/

      MODE=2
      IF(N.LE.0)                    GOTO 50

C  STATE DUAL PROBLEM

      MODE=1
      X(1)=ZERO
      CALL DCOPY(N,X(1),0,X,1)
      XNORM=ZERO
      IF(M.EQ.0)                    GOTO 50
      IW=0
      DO 20 J=1,M
          DO 10 I=1,N
              IW=IW+1
   10         W(IW)=G(J,I)
          IW=IW+1
   20     W(IW)=H(J)
      IF=IW+1
      DO 30 I=1,N
          IW=IW+1
   30     W(IW)=ZERO
      W(IW+1)=ONE
      N1=N+1
      IZ=IW+2
      IY=IZ+N1
      IWDUAL=IY+M

C  SOLVE DUAL PROBLEM

      CALL NNLS (W,N1,N1,M,W(IF),W(IY),RNORM,W(IWDUAL),W(IZ),INDEX,MODE)

      IF(MODE.NE.1)                 GOTO 50
      MODE=4
      IF(RNORM.LE.ZERO)             GOTO 50

C  COMPUTE SOLUTION OF PRIMAL PROBLEM

      FAC=ONE-DDOT(M,H,1,W(IY),1)
      IF(DIFF(ONE+FAC,ONE).LE.ZERO) GOTO 50
      MODE=1
      FAC=ONE/FAC
      DO 40 J=1,N
   40     X(J)=FAC*DDOT(M,G(1,J),1,W(IY),1)
      XNORM=DNRM2(N,X,1)

C  COMPUTE LAGRANGE MULTIPLIERS FOR PRIMAL PROBLEM

      W(1)=ZERO
      CALL DCOPY(M,W(1),0,W,1)
      CALL DAXPY(M,FAC,W(IY),1,W,1)

C  END OF SUBROUTINE LDP

   50 END


      SUBROUTINE PLAMAT
C THIS ROUTINE RETURNS GP ROTATED FOR PLA3 AND PLA4
C
      DIMENSION X(27)
      COMMON /MATIN / MATID,INFLAG,ELTEMP,PLAARG,SINTH,COSTH
      COMMON /MATOUT/ G11,G12,G13,G22,G23,G33 , DUMMY(14)
      COMMON /PLAGP / GP(9) , MIDGP , ELID
C
C  TEST TO SEE IF INCOMING MATERIAL ID IS EQUAL TO MATERIAL ID IN
C  PLAGP.  IF NOT USE REGULAR CALL TO MAT TO GET GP
C
      IF( MIDGP .NE. MATID ) GO TO 10
C
C                           T
C  TRANSFORM G   ,  G  =   U  *  G   * U
C             P      P            P
C
      X(1)  = COSTH**2
      X(2)  = SINTH**2
      X(3)  = COSTH * SINTH
      X(4)  = X(2)
      X(5)  = X(1)
      X(6)  = -X(3)
      X(7)  = 2.0 * X(6)
      X(8)  = -X(7)
      X(9)  = X(1) - X(2)
      CALL GMMATS(GP(1),3,3,0,X( 1),3,3,0,X(19))
      CALL GMMATS(X( 1),3,3,1,X(19),3,3,0,X(10))
      G11 = X(10)
      G12 = X(11)
      G13 = X(12)
      G22 = X(14)
      G23 = X(15)
      G33 = X(18)
      RETURN
   10 INFLAG = 2
      CALL MAT (ELID)
      RETURN
      END


! File VersionID:
!   $Id: reduceva.for 203 2011-10-20 12:00:27Z kroes006 $
! ----------------------------------------------------------------------
      subroutine reduceva (task,swredu,empreva,peva,nrai,
     &     nird,cofred,rsigni,swinco,ldwet,spev,saev,fldaystart,dt,pond)
! ----------------------------------------------------------------------
!     date               : august 2006
!     purpose            : calculates reduction of soil evaporation
! ----------------------------------------------------------------------
      implicit none

! --- global
      integer swredu,task,swinco
      real*8  empreva,peva,nrai,nird,cofred,rsigni,ldwet,spev,saev,dt
      real*8  pond
      logical fldaystart
! ----------------------------------------------------------------------
! --- local
      real*8  saevm1

! ----------------------------------------------------------------------
      goto (1000,2000) task

1000  continue

! === reduction potential soil evaporation on daily basis ==============

      if (pond .gt. 1.0d-10) then
! ---   in case of ponding no reduction ---
        empreva = peva
        ldwet = 0.0d0
        spev = 0.0d0
        saev = 0.0d0
      elseif (swredu.eq.1) then
! ---   reduction with black model ---
        if ((nrai+nird) .gt. rsigni) ldwet = 0.0d0
        ldwet = ldwet + 1.0d0
        empreva = cofred * (sqrt(ldwet)-sqrt(ldwet-1.0d0))
        empreva = min(empreva,peva)
      elseif (swredu.eq.2) then
! ---   reduction with boesten and stroosnijder model ---
        if ((nrai+nird) .lt. peva) then
ckro      if(swinco.ne.3) then
           spev = spev + (peva - (nrai+nird))
ckro      endif
          saevm1 = saev
          if (spev .lt. cofred**2) then
            saev = spev
          else
            saev = cofred * sqrt(spev)
          endif
          empreva = nrai + nird + saev - saevm1
        else
          empreva = peva
          saev = max (0.0d0,saev - (nrai+nird-peva))
          if (saev .lt. (cofred**2)) then
            spev = saev
          else
            spev = (saev/cofred)**2
          endif
        endif
      endif

      return

2000  continue

! === reduction potential soil evaporation for every time step ==============

      if (pond .gt. 1.0d-10) then
! ---   in case of ponding no reduction ---
        empreva = peva
        ldwet = 0.0d0
        spev = 0.0d0
        saev = 0.0d0
      elseif (swredu.eq.1) then
! ---   reduction with black model ---
        if (fldaystart .and. (nrai+nird) .gt. rsigni) ldwet = 0.0d0
        empreva = (cofred * (sqrt(ldwet+dt)-sqrt(ldwet))) / dt
        empreva = min(empreva,peva)
        ldwet = ldwet + dt
      elseif (swredu.eq.2) then
! ---   reduction with boesten and stroosnijder model ---
        if ((nrai+nird) .lt. peva) then
          spev = spev + (peva - (nrai+nird)) * dt
          saevm1 = saev
          if (spev .lt. cofred**2) then
            saev = spev
          else
            saev = cofred * sqrt(spev)
          endif
          empreva = ((nrai + nird)*dt + saev - saevm1) / dt
        else
          empreva = peva
          saev = max (0.0d0,saev - (nrai+nird-peva)*dt)
          if (saev .lt. (cofred**2)) then
            spev = saev
          else
            spev = (saev/cofred)**2
          endif
        endif
      endif

      return
      end


      SUBROUTINE ADI(A,B,C,D,E,F,G,U,JMAX,K,ALPHA,BETA,EPS)
      IMPLICIT REAL*8(A-H,O-Z)
      PARAMETER(JJ=100,KK=6,NRR=32,MAXITS=100,ZERO=0.D0,TWO=2.D0,HALF=.5
     *D0)
      DIMENSION A(JMAX,JMAX),B(JMAX,JMAX),C(JMAX,JMAX),D(JMAX,JMAX),
     *    E(JMAX,JMAX),F(JMAX,JMAX),G(JMAX,JMAX),U(JMAX,JMAX),
     *    AA(JJ),BB(JJ),CC(JJ),RR(JJ),UU(JJ),PSI(JJ,JJ),
     *    ALPH(KK),BET(KK),R(NRR),S(NRR,KK)
      IF(JMAX.GT.JJ)PAUSE 'Increase JJ'
      IF(K.GT.KK-1)PAUSE 'Increase KK'
      K1=K+1
      NR=2**K
      ALPH(1)=ALPHA
      BET(1)=BETA
      DO 11 J=1,K
        ALPH(J+1)=SQRT(ALPH(J)*BET(J))
        BET(J+1)=HALF*(ALPH(J)+BET(J))
11    CONTINUE
      S(1,1)=SQRT(ALPH(K1)*BET(K1))
      DO 13 J=1,K
        AB=ALPH(K1-J)*BET(K1-J)
        DO 12 N=1,2**(J-1)
          DISC=SQRT(S(N,J)**2-AB)
          S(2*N,J+1)=S(N,J)+DISC
          S(2*N-1,J+1)=AB/S(2*N,J+1)
12      CONTINUE
13    CONTINUE
      DO 14 N=1,NR
        R(N)=S(N,K1)
14    CONTINUE
      ANORMG=ZERO
      DO 16 J=2,JMAX-1
        DO 15 L=2,JMAX-1
          ANORMG=ANORMG+ABS(G(J,L))
          PSI(J,L)=-D(J,L)*U(J,L-1)+(R(1)-E(J,L))*U(J,L)
     *        -F(J,L)*U(J,L+1)
15      CONTINUE
16    CONTINUE
      NITS=MAXITS/NR
      DO 27 KITS=1,NITS
        DO 24 N=1,NR
          IF(N.EQ.NR)THEN
            NEXT=1
          ELSE
            NEXT=N+1
          ENDIF
          RFACT=R(N)+R(NEXT)
          DO 19 L=2,JMAX-1
            DO 17 J=2,JMAX-1
              AA(J-1)=A(J,L)
              BB(J-1)=B(J,L)+R(N)
              CC(J-1)=C(J,L)
              RR(J-1)=PSI(J,L)-G(J,L)
17          CONTINUE
            CALL TRIDAG(AA,BB,CC,RR,UU,JMAX-2)
            DO 18 J=2,JMAX-1
              PSI(J,L)=-PSI(J,L)+TWO*R(N)*UU(J-1)
18          CONTINUE
19        CONTINUE
          DO 23 J=2,JMAX-1
            DO 21 L=2,JMAX-1
              AA(L-1)=D(J,L)
              BB(L-1)=E(J,L)+R(N)
              CC(L-1)=F(J,L)
              RR(L-1)=PSI(J,L)
21          CONTINUE
            CALL TRIDAG(AA,BB,CC,RR,UU,JMAX-2)
            DO 22 L=2,JMAX-1
              U(J,L)=UU(L-1)
              PSI(J,L)=-PSI(J,L)+RFACT*UU(L-1)
22          CONTINUE
23        CONTINUE
24      CONTINUE
        ANORM=ZERO
        DO 26 J=2,JMAX-1
          DO 25 L=2,JMAX-1
            RESID=A(J,L)*U(J-1,L)+(B(J,L)+E(J,L))*U(J,L)
     *          +C(J,L)*U(J+1,L)+D(J,L)*U(J,L-1)
     *          +F(J,L)*U(J,L+1)+G(J,L)
            ANORM=ANORM+ABS(RESID)
25        CONTINUE
26      CONTINUE
        IF(ANORM.LT.EPS*ANORMG)RETURN
27    CONTINUE
      PAUSE 'MAXITS exceeded'
      END


MODULE m_pwintsl
CONTAINS
  SUBROUTINE pwint_sl(stars,atoms,sym,zsl1,zsl2, volsl,volintsl, cell,nmtsl1, kv, x)
    !     ******************************************************************
    !     calculate the integral of a star function over the layer
    !     interstial region of a film                Yury Koroteev
    !                                   from  pwint.F  by  c.l.fu
    !     ******************************************************************
    USE m_spgrot
    USE m_constants,ONLY: tpi_const
    USE m_types
    IMPLICIT NONE
    TYPE(t_sym),INTENT(IN)     :: sym
    TYPE(t_stars),INTENT(IN)   :: stars
    TYPE(t_cell),INTENT(IN)    :: cell
    TYPE(t_atoms),INTENT(IN)   :: atoms
    !     ..
    !     .. Scalar Arguments ..
    REAL,    INTENT (IN) :: zsl1,zsl2,volsl,volintsl
    COMPLEX, INTENT (OUT):: x
    !     ..
    !     .. Array Arguments ..
    INTEGER, INTENT (IN) :: kv(3)
    INTEGER, INTENT (IN) :: nmtsl1(atoms%ntype)
    !     ..
    !     .. Local Scalars ..
    COMPLEX s1,sfs
    REAL arg,g,s,srmt,gm,gp,zslm,zslp
    INTEGER ig2d,ig3d,n,nn,nat
    !     ..
    !     .. Local Arrays ..
    COMPLEX ph(sym%nop)
    INTEGER kr(3,sym%nop)
    !     ..
    ig3d = stars%ig(kv(1),kv(2),kv(3))
    !
    !     -----> interstitial contributions
    !
    IF (ig3d.EQ.0) THEN
       x = (0.,0.)
       RETURN
    END IF
    IF (ig3d.EQ.1) THEN
       x = CMPLX(volintsl,0.0)
       RETURN
    ELSE
       ig2d = stars%ig2(ig3d)
       IF (ig2d.EQ.1) THEN
          zslm = 0.5*(zsl2 - zsl1)
          zslp = 0.5*(zsl2 + zsl1)
          g = kv(3)*cell%bmat(3,3)
          gm = g*zslm
          gp = g*zslp
          x = volsl*SIN(gm)/gm*CMPLX(COS(gp),SIN(gp))
       ELSE
          x = (0.0,0.0)
       END IF
    END IF
    !
    !     -----> sphere contributions
    !
    s = stars%sk3(ig3d)
    nat = 1
    DO n = 1,atoms%ntype
       srmt = s*atoms%rmt(n)
       CALL spgrot(sym%nop,sym%symor,sym%mrot,sym%tau,sym%invtab, kv, kr,ph)
       sfs = (0.0,0.0)
       DO  nn = 1,sym%nop
          arg = tpi_const* dot_product(real(kr(:,nn)),atoms%taual(:,nat))
          sfs = sfs + CMPLX(COS(arg),SIN(arg))*ph(nn)
       ENDDO
       sfs = sfs/sym%nop
       !
       !     -----3*ji(gr)/gr term
       !
       s1 = 3.* (SIN(srmt)/srmt-COS(srmt))/ (srmt*srmt)
       x = x - atoms%volmts(n)*nmtsl1(n)*s1*sfs
       nat = nat + atoms%neq(n)
    ENDDO
    !
  END SUBROUTINE pwint_sl
END MODULE m_pwintsl


        REAL FUNCTION EXTCOR(WAVE,EBV)
	REAL WAVE, EBV
C
C      MEAN GALACTIC CURVE (Seaton,M. 1979, MNRAS,187, 73p)
C      THE METHOD EMPLOYED IS LINEAR INTERPOLATION.

       REAL MAG1, M, X(18), MAG(18)
       REAL DY, DX, B, Z

C      Data for mean galactic with x less than 2.7
       DATA X /1.0,1.1,1.2,1.3,1.4,1.5,1.6,1.7,1.8,1.9,2.0,2.1,2.2,
     &  2.3,2.4,2.5,2.6,2.7/
       DATA MAG /1.36,1.64,1.84,2.04,2.24,2.44,2.66,2.88,3.14,3.36,
     &  3.56,3.77,3.96,4.15,4.26,4.40,4.52,4.64/

       Z = 10000. / WAVE

C      GAK modification for a Herschel 36 w/o bump from Fitzpatrick and Massa
C      1988, ApJ, 328, 734.  Weak bump relative to Seaton, slightly stronger
C      FUV upturn.
C	mag1 = 3.14 + 1.680 + 0.055 * Z
C	if ( z .ge. 5.9 )
C     &    mag1=mag1+0.312*(0.5392*(Z-5.9)**2+0.0564*(z-5.9)**3)
C       extcor = 10. ** ( -0.4 * EBV * MAG1)
C       return

C	GAK modification for Theta1 Ori C from Fitspatrick and Mass (1988).
C	This star has weak bump and weak UV upturn relative to Seaton curve.
C	drude = z**2 / ( (z**2 - 4.635**2)**2 + (0.846 * z)**2)
C	mag1 = 3.14 + 1.251 + 0.033 * Z + 1.331 * drude
C	if ( z .ge. 5.9 )
C     &    mag1=mag1+0.186*(0.5392*(Z-5.9)**2+0.0564*(z-5.9)**3)
C       extcor = 10. ** ( -0.4 * EBV * MAG1)
C       return

            MAG1 = 0.0
            IF( Z .LE. 1.0 ) GO TO 90

            IF( Z .GE. 2.7 ) GO TO 30

              DO 10 I = 1,18
   10               IF (X(I).GT. Z) GOTO 20
   20         DY = MAG(I) - MAG(I - 1)
              DX = X(I) - X(I - 1)
              M = DY / DX
              B = MAG(I) - M * X(I)
              MAG1 = M * Z + B
            GO TO 90

   30             IF( Z .GE. 3.65 ) GO TO 50
            MAG1=1.56+1.048*Z+1.01/((Z-4.60)**2+0.280)
            GO TO 90

   50             IF( Z .GE. 7.14 ) GO TO 70
            MAG1=2.29+0.848*Z+1.01/((Z-4.60)**2+0.280)
            GO TO 90

   70             MAG1=16.17-3.20*Z+0.2975*Z**2
              GO TO 90

   90             EXTCOR = 10. ** ( -.4 * MAG1 * EBV )

       RETURN
       END


	FUNCTION XPADC(F)
C
C	THIS FUNCTION RETURNS THE GAIN OF THE DC CHANNEL OF THE WIND X PREAMP
C	THE FUNCTION ITSELF RETURNS THE MAGNITUDE OF THE GAIN, AND THE PHASE
C	AND THE COMPLEX GAIN ARE RETURNED IN A COMMON BLOCK
C
	COMMON /GAINBLK/ PHASE,CGAIN        		  ! PHASE IS IN RADIANS
	COMMON /COMPBLK/ CVAR(5)
C
	COMPLEX CGAIN,Y1,Z1,Y2,Z2
	DATA R9,C9,R10,CINP /5.E8,23.6E-12,5.E8,4.37E-12/
	DATA R33,C16 /2.2E+03,1.203E-9/
	DATA RCOMP,CCOMP /22.1E3,47.E-12/
	DATA TWOPI /6.2831853/
C
C	C16 = 1.203E-9                             ! ADJUSTING EX
C	C9  = 23.6E-12                            ! ADJUSTING EX
C	CINP = 4.37E-12                          ! ADJUSTING EX
C
C	C16 = CVAR(1)
C	C9 = CVAR(2)
C	CINP = CVAR(3)
C
	W = TWOPI*F
	CGAIN = 1.
C	DIVISION OF SIGNAL BEFORE FOLLOWER
	Y1 = CMPLX(1./R9,W*C9)
	Y2 = CMPLX(1./R10,W*CINP)
	Z1 = 1./Y1
	Z2 = 1./Y2
	CGAIN = CGAIN*Z2/(Z1+Z2)
C	EFFECT OF OUTPUT RC
	WC16 = 1./(W*C16)
C	PRINT*,'W,Z1,WC16',W,Z1,WC16
C	PRINT*,'F,CGAIN,PHASE
	CGAIN = CGAIN*CMPLX(0.,-WC16)/CMPLX(R33,-WC16)
C
C	EFFECT OF INPUT BOARD
C
	WCC = W*CCOMP
	Z1 = CMPLX(0.,-1./WCC)
	Z2 = CMPLX(RCOMP,-1./WCC)
	Z3 = Z1/(Z1+Z2)
C*****************   effect of compensation
	CGAIN = CGAIN*Z3*Z3
C*************
C
	GNIP = AIMAG(CGAIN)
	GNRP = CGAIN
	PHASE = ATAN2(GNIP,GNRP)
	XPADC = CABS(CGAIN)
	RETURN
	END
	FUNCTION XPAAC(F)
C
C	THIS FUNCTION RETURNS THE GAIN OF THE AC CHANNEL OF THE WIND X PREAMP
C	THE FUNCTION ITSELF RETURNS THE MAGNITUDE OF THE GAIN, AND THE PHASE
C	AND THE COMPLEX GAIN ARE RETURNED IN A COMMON BLOCK
C
	COMMON /GAINBLK/ PHASE,CGAIN        		  ! PHASE IS IN RADIANS
	COMMON /COMPBLK/ CVAR(5)
C
C	COMPONENT DESIGNATIONS ARE SAME AS SCHEMATIC
C
	COMPLEX CGAIN,Y1,Z1,Y2,Z2,Y3,Z3,OPAMPIN
	DATA R9,C9,R10,CINP /5.E8,23.6E-12,5.E8,4.37E-12/
	DATA C29,R43,C12,R28/ 1.E-7,47.E+3,15.E-9,100.E+3/
	DATA R29,C13,R12,C26/ 470.,3.49E-9,10.E3,86.9E-9/
	DATA C15,R32,C27,R11/ 0.,10.E3,470.E-12,1.5E3/
	DATA C25,R39,C30/829.E-9,330.,29.9E-9/
	DATA TWOPI /6.2831853/
C
C	TO BE CHANGED FOR Y,Z:  R11,R32,C27,R9,C9,R10
C
C
C	C30 = 30.9E-9                     ! ADJUSTING EX
C	C13 = 3.7E-9                     ! ADJUSTING EX
C
C	C30 = CVAR(1)
C	C26 = CVAR(2)
C	C25 = CVAR(3)
C	C13 = CVAR(4)
C
	W = TWOPI*F
	CGAIN = 1.
C
C	DIVISION OF SIGNAL BEFORE FOLLOWER
C
	Y1 = CMPLX(1./R9,W*C9)
	Y2 = CMPLX(1./R10,W*CINP)
	Z1 = 1./Y1
	Z2 = 1./Y2
	CGAIN = CGAIN*Z2/(Z1+Z2)
C
C	CGAIN = 3.2
C
C	EFFECT OF OUTPUT OP AMP
C
C	FILTERING BEFORE INPUT
	Z1 = R28                 	! LAST LOAD BEFORE OP AMP
	WC12 = W*C12
	Z2 = CMPLX(R28,-1./WC12)        !  LAST RC
	Y1 = 1./CMPLX(R43,0.) + 1./Z2   !  LAST RC IN PARALLEL WITH R43
	WC29 = W*C29
	Z3 = 1./Y1 + CMPLX(0.,-1./WC29) !  LOAD ON FOLLOWER
	OPAMPIN = CGAIN*(Z1/Z2)*(1./Y1/Z3)
C
C	OP AMP GAIN
C
C	Z3 FROM NEG. INPUT TO GROUND
	WC13 = W*C13
	Z1 = CMPLX(R29,-1./WC13)
	WC26 = W*C26
	Z2 = CMPLX(R12,-1./WC26)
	Y1 = 1./Z1 + 1./Z2                  ! Y FROM NEG INPUT TO GROUND
	Z3 = 1./Y1                          ! Z FROM NEG INPUT TO GROUND
C	Z2 FROM OUTPUT TO NEG INPUT
	WC27 = W*C27
	Z1 = CMPLX(R11,-1./WC27)
	WC15 = W*C15
	Y1 = CMPLX(1./R32,WC15)
	Y2 = Y1 + 1./Z1
	Z2 = 1./Y2
	CGAIN = OPAMPIN*(Z3 + Z2)/Z3
C
C	FILTERING AFTER OP AMP OUTPUT
C
	WC30 = W*C30
	Z1 = CMPLX(R39,-1./WC30)
	WC25 = W*C25
	Z2 = CMPLX(0.,-1./WC25)
	CGAIN = CGAIN*CMPLX(0.,-1./WC30)/(Z2+Z1)
C
	GNIP = AIMAG(CGAIN)
	GNRP = CGAIN
	PHASE = ATAN2(GNIP,GNRP)
	XPAAC = CABS(CGAIN)
	RETURN
	END
	FUNCTION YPADC(F)
C
C	THIS FUNCTION RETURNS THE GAIN OF THE DC CHANNEL OF THE WIND Y PREAMP
C	THE FUNCTION ITSELF RETURNS THE MAGNITUDE OF THE GAIN, AND THE PHASE
C	AND THE COMPLEX GAIN ARE RETURNED IN A COMMON BLOCK
C
	COMMON /GAINBLK/ PHASE,CGAIN        		  ! PHASE IS IN RADIANS
C
C	DONE AND CHECKED
C
	COMPLEX CGAIN,Y1,Z1,Y2,Z2
	DATA R9,C9,R10,CINP /5.E9,24.5E-12,5.E9,4.757E-12/
	DATA R33,C16 /2.2E+03,1.185E-9/
	DATA R1COMP,R2COMP,CCOMP /0.,100.E3,10.E-12/
	DATA TWOPI /6.2831853/
C
C	C16 = 1.185E-9
C	C9  = 24.5E-12
C	CINP = 4.757E-12
C
C
C	C16 = CVAR(1)                             ! ADJUSTING EY
C	C9  = CVAR(2)                             ! ADJUSTING EY
C	CINP = CVAR(3)                            ! ADJUSTING EY
C
	W = TWOPI*F
	CGAIN = 1.
C	DIVISION OF SIGNAL BEFORE FOLLOWER
	Y1 = CMPLX(1./R9,W*C9)
	Y2 = CMPLX(1./R10,W*CINP)
	Z1 = 1./Y1
	Z2 = 1./Y2
	CGAIN = CGAIN*Z2/(Z1+Z2)
C	EFFECT OF OUTPUT RC
	WC16 = 1./(W*C16)
C	PRINT*,'W,Z1,WC16',W,Z1,WC16
C	PRINT*,'F,CGAIN,PHASE
	CGAIN = CGAIN*CMPLX(0.,-WC16)/CMPLX(R33,-WC16)
C
C	EFFECT OF INPUT BOARD
C
	WCC = W*CCOMP
	Z1 = CMPLX(0.,-1./WCC)
	Z2 = CMPLX(R2COMP,-1./WCC)
	Z3 = Z1/(Z1+Z2)
C*****************
C	CGAIN = CGAIN*Z3*Z3
C*************
C
	GNIP = AIMAG(CGAIN)
	GNRP = CGAIN
	PHASE = ATAN2(GNIP,GNRP)
	YPADC = CABS(CGAIN)
	RETURN
	END
	FUNCTION YPAAC(F)
C
C	THIS FUNCTION RETURNS THE GAIN OF THE AC CHANNEL OF THE WIND Y PREAMP
C	THE FUNCTION ITSELF RETURNS THE MAGNITUDE OF THE GAIN, AND THE PHASE
C	AND THE COMPLEX GAIN ARE RETURNED IN A COMMON BLOCK
C
	COMMON /GAINBLK/ PHASE,CGAIN        		  ! PHASE IS IN RADIANS
C
C	COMPONENT DESIGNATIONS ARE SAME AS SCHEMATIC
C
	COMPLEX CGAIN,Y1,Z1,Y2,Z2,Y3,Z3,OPAMPIN
	DATA R9,C9,R10,CINP /5.E9,24.5E-12,5.E9,4.757E-12/
	DATA C29,R43,C12,R28/ 1.E-7,47.E+3,15.E-9,100.E+3/
	DATA R29,C13,R12,C26/ 470.,3.437E-9,10.E3,98.23E-9/
	DATA C15,R32,C27,R11/ 0.,33.E3,150.E-12,4.7E3/
	DATA C25,R39,C30/1401.E-9,330.,30.61E-9/
	DATA TWOPI /6.2831853/
C
C	TO BE CHANGED FOR Y,Z:  R11,R32,C27,R9,C9,R10
C
C	DONE AND CHECKED
C
C	C30 = CVAR(1) = 30.61 E-9
C	C26 = CVAR(2) = 98.23 E-9
C	C25 = CVAR(3) = 1401. E-6
C	C13 = CVAR(4) = 3.437 E-9
C
	W = TWOPI*F
	CGAIN = 1.
C
C	DIVISION OF SIGNAL BEFORE FOLLOWER
C
	Y1 = CMPLX(1./R9,W*C9)
	Y2 = CMPLX(1./R10,W*CINP)
	Z1 = 1./Y1
	Z2 = 1./Y2
	CGAIN = CGAIN*Z2/(Z1+Z2)
C
C	CGAIN = 3.2
C
C	EFFECT OF OUTPUT OP AMP
C
C	FILTERING BEFORE INPUT
	Z1 = R28                 	! LAST LOAD BEFORE OP AMP
B	WC12 = W*C12
	Z2 = CMPLX(R28,-1./WC12)        !  LAST RC
	Y1 = 1./CMPLX(R43,0.) + 1./Z2   !  LAST RC IN PARALLEL WITH R43
	WC29 = W*C29
	Z3 = 1./Y1 + CMPLX(0.,-1./WC29) !  LOAD ON FOLLOWER
	OPAMPIN = CGAIN*(Z1/Z2)*(1./Y1/Z3)
C
C	OP AMP GAIN
C
C	Z3 FROM NEG. INPUT TO GROUND
	WC13 = W*C13
	Z1 = CMPLX(R29,-1./WC13)
	WC26 = W*C26
	Z2 = CMPLX(R12,-1./WC26)
	Y1 = 1./Z1 + 1./Z2                  ! Y FROM NEG INPUT TO GROUND
	Z3 = 1./Y1                          ! Z FROM NEG INPUT TO GROUND
C	Z2 FROM OUTPUT TO NEG INPUT
	WC27 = W*C27
	Z1 = CMPLX(R11,-1./WC27)
	WC15 = W*C15
	Y1 = CMPLX(1./R32,WC15)
	Y2 = Y1 + 1./Z1
	Z2 = 1./Y2
	CGAIN = OPAMPIN*(Z3 + Z2)/Z3
C
C	FILTERING AFTER OP AMP OUTPUT
C
	WC30 = W*C30
	Z1 = CMPLX(R39,-1./WC30)
	WC25 = W*C25
	Z2 = CMPLX(0.,-1./WC25)
	CGAIN = CGAIN*CMPLX(0.,-1./WC30)/(Z2+Z1)
C
	GNIP = AIMAG(CGAIN)
	GNRP = CGAIN
	PHASE = ATAN2(GNIP,GNRP)
	YPAAC = CABS(CGAIN)
	RETURN
	END
	FUNCTION ZPADC(F)
C
C	THIS FUNCTION RETURNS THE GAIN OF THE DC CHANNEL OF THE WIND Z PREAMP
C	THE FUNCTION ITSELF RETURNS THE MAGNITUDE OF THE GAIN, AND THE PHASE
C	AND THE COMPLEX GAIN ARE RETURNED IN A COMMON BLOCK
C
C	TO BE CHANGED FOR Y,Z:  R11,R32,C27,R9,C9,R10
C	DONE AND TESTED
C
	COMMON /GAINBLK/ PHASE,CGAIN        		  ! PHASE IS IN RADIANS
C	COMMON /COMPBLK/ CVAR(5)
C
	COMPLEX CGAIN,Y1,Z1,Y2,Z2
	DATA R9,C9,R10,CINP /18.E6,84.E-12,2.E8,4.99E-12/
	DATA R33,C16 /2.2E+03,1.202E-9/
	DATA RCOMP,CCOMP /22.1E3,47.E-12/
	DATA TWOPI /6.2831853/
C
C	C16 = 1.203E-9                             ! ADJUSTING EX
C	C9  = 23.6E-12                            ! ADJUSTING EX
C	CINP = 4.99E-12                          ! ADJUSTING EZ
C
	C16 = CVAR(1)
	C9 = CVAR(2)
	CINP = CVAR(3)
C
	W = TWOPI*F
	CGAIN = 1.
C	DIVISION OF SIGNAL BEFORE FOLLOWER
	Y1 = CMPLX(1./R9,W*C9)
	Y2 = CMPLX(1./R10,W*CINP)
	Z1 = 1./Y1
	Z2 = 1./Y2
	CGAIN = CGAIN*Z2/(Z1+Z2)
C	EFFECT OF OUTPUT RC
	WC16 = 1./(W*C16)
C	PRINT*,'W,Z1,WC16',W,Z1,WC16
C	PRINT*,'F,CGAIN,PHASE
	CGAIN = CGAIN*CMPLX(0.,-WC16)/CMPLX(R33,-WC16)
C
C	EFFECT OF INPUT BOARD
C
	WCC = W*CCOMP
	Z1 = CMPLX(0.,-1./WCC)
	Z2 = CMPLX(RCOMP,-1./WCC)
	Z3 = Z1/(Z1+Z2)
C*****************
C	CGAIN = CGAIN*Z3*Z3
C*************
C
	GNIP = AIMAG(CGAIN)
	GNRP = CGAIN
	PHASE = ATAN2(GNIP,GNRP)
	ZPADC = CABS(CGAIN)
	RETURN
	END
	FUNCTION ZPAAC(F)
C
C	THIS FUNCTION RETURNS THE GAIN OF THE AC CHANNEL OF THE WIND Z PREAMP
C	THE FUNCTION ITSELF RETURNS THE MAGNITUDE OF THE GAIN, AND THE PHASE
C	AND THE COMPLEX GAIN ARE RETURNED IN A COMMON BLOCK
C
	COMMON /GAINBLK/ PHASE,CGAIN        		  ! PHASE IS IN RADIANS
C	COMMON /COMPBLK/ CVAR(5)
C
C	COMPONENT DESIGNATIONS ARE SAME AS SCHEMATIC
C
	COMPLEX CGAIN,Y1,Z1,Y2,Z2,Y3,Z3,OPAMPIN
	DATA R9,C9,R10,CINP /18.E6,84.E-12,2.E8,4.99E-12/
	DATA C29,R43,C12,R28/ 1.E-7,47.E+3,15.E-9,100.E+3/
	DATA R29,C13,R12,C26/ 470.,3.448E-9,10.E3,92.E-9/
	DATA C15,R32,C27,R11/ 0.,33.E3,150.E-12,4.7E3/
	DATA C25,R39,C30/703.E-9,330.,32.89E-9/
	DATA TWOPI /6.2831853/
C
C	DONE AND CHECKED
C
C 	C30 = CVAR(1)
C	C26 = CVAR(2)
C	C25 = CVAR(3)
C	C13 = CVAR(4)
C
	W = TWOPI*F
	CGAIN = 1.
C
C	DIVISION OF SIGNAL BEFORE FOLLOWER
C
	Y1 = CMPLX(1./R9,W*C9)
	Y2 = CMPLX(1./R10,W*CINP)
	Z1 = 1./Y1
	Z2 = 1./Y2
	CGAIN = CGAIN*Z2/(Z1+Z2)
C
C	CGAIN = 3.2
C
C	EFFECT OF OUTPUT OP AMP
C
C	FILTERING BEFORE INPUT
	Z1 = R28                 	! LAST LOAD BEFORE OP AMP
	WC12 = W*C12
	Z2 = CMPLX(R28,-1./WC12)        !  LAST RC
	Y1 = 1./CMPLX(R43,0.) + 1./Z2   !  LAST RC IN PARALLEL WITH R43
	WC29 = W*C29
	Z3 = 1./Y1 + CMPLX(0.,-1./WC29) !  LOAD ON FOLLOWER
	OPAMPIN = CGAIN*(Z1/Z2)*(1./Y1/Z3)
C
C	OP AMP GAIN
C
C	Z3 FROM NEG. INPUT TO GROUND
	WC13 = W*C13
	Z1 = CMPLX(R29,-1./WC13)
	WC26 = W*C26
	Z2 = CMPLX(R12,-1./WC26)
	Y1 = 1./Z1 + 1./Z2                  ! Y FROM NEG INPUT TO GROUND
	Z3 = 1./Y1                          ! Z FROM NEG INPUT TO GROUND
C	Z2 FROM OUTPUT TO NEG INPUT
	WC27 = W*C27
	Z1 = CMPLX(R11,-1./WC27)
	WC15 = W*C15
	Y1 = CMPLX(1./R32,WC15)
	Y2 = Y1 + 1./Z1
	Z2 = 1./Y2
	CGAIN = OPAMPIN*(Z3 + Z2)/Z3
C
C	FILTERING AFTER OP AMP OUTPUT
C
	WC30 = W*C30
	Z1 = CMPLX(R39,-1./WC30)
	WC25 = W*C25
	Z2 = CMPLX(0.,-1./WC25)
	CGAIN = CGAIN*CMPLX(0.,-1./WC30)/(Z2+Z1)
C
	GNIP = AIMAG(CGAIN)
	GNRP = CGAIN
	PHASE = ATAN2(GNIP,GNRP)
	ZPAAC = CABS(CGAIN)
	RETURN
	END


      SUBROUTINE MB02CX( TYPET, P, Q, K, A, LDA, B, LDB, CS, LCS,
     $                   DWORK, LDWORK, INFO )
C
C     SLICOT RELEASE 5.7.
C
C     Copyright (c) 2002-2020 NICONET e.V.
C
C     PURPOSE
C
C     To bring the first blocks of a generator in proper form.
C     The columns / rows of the positive and negative generators
C     are contained in the arrays A and B, respectively.
C     Transformation information will be stored and can be applied
C     via SLICOT Library routine MB02CY.
C
C     ARGUMENTS
C
C     Mode Parameters
C
C     TYPET   CHARACTER*1
C             Specifies the type of the generator, as follows:
C             = 'R':  A and B are the first blocks of the rows of the
C                     positive and negative generators;
C             = 'C':  A and B are the first blocks of the columns of the
C                     positive and negative generators.
C             Note:   in the sequel, the notation x / y means that
C                     x corresponds to TYPET = 'R' and y corresponds to
C                     TYPET = 'C'.
C
C     Input/Output Parameters
C
C     P       (input)  INTEGER
C             The number of rows / columns in A containing the positive
C             generators.  P >= 0.
C
C     Q       (input)  INTEGER
C             The number of rows / columns in B containing the negative
C             generators.  Q >= 0.
C
C     K       (input)  INTEGER
C             The number of columns / rows in A and B to be processed.
C             Normally, the size of the first block.  P >= K >= 0.
C
C     A       (input/output)  DOUBLE PRECISION array, dimension
C             (LDA, K) / (LDA, P)
C             On entry, the leading P-by-K upper / K-by-P lower
C             triangular part of this array must contain the rows /
C             columns of the positive part in the first block of the
C             generator.
C             On exit, the leading P-by-K upper / K-by-P lower
C             triangular part of this array contains the rows / columns
C             of the positive part in the first block of the proper
C             generator.
C             The lower / upper trapezoidal part is not referenced.
C
C     LDA     INTEGER
C             The leading dimension of the array A.
C             LDA >= MAX(1,P),    if TYPET = 'R';
C             LDA >= MAX(1,K),    if TYPET = 'C'.
C
C     B       (input/output)  DOUBLE PRECISION array, dimension
C             (LDB, K) / (LDB, Q)
C             On entry, the leading Q-by-K / K-by-Q part of this array
C             must contain the rows / columns of the negative part in
C             the first block of the generator.
C             On exit, the leading Q-by-K / K-by-Q part of this array
C             contains part of the necessary information for the
C             Householder transformations.
C
C     LDB     INTEGER
C             The leading dimension of the array B.
C             LDB >= MAX(1,Q),    if TYPET = 'R';
C             LDB >= MAX(1,K),    if TYPET = 'C'.
C
C     CS      (output)  DOUBLE PRECISION array, dimension (LCS)
C             On exit, the leading 2*K + MIN(K,Q) part of this array
C             contains necessary information for the SLICOT Library
C             routine MB02CY (modified hyperbolic rotation parameters
C             and scalar factors of the Householder transformations).
C
C     LCS     INTEGER
C             The length of the array CS.  LCS >= 2*K + MIN(K,Q).
C
C     Workspace
C
C     DWORK   DOUBLE PRECISION array, dimension (LDWORK)
C             On exit, if  INFO = 0,  DWORK(1)  returns the optimal
C             value of LDWORK.
C             On exit, if  INFO = -12,  DWORK(1)  returns the minimum
C             value of LDWORK.
C
C     LDWORK  INTEGER
C             The length of the array DWORK.  LDWORK >= MAX(1,K).
C             For optimum performance LDWORK should be larger.
C
C     Error Indicator
C
C     INFO    INTEGER
C             = 0:  succesful exit;
C             < 0:  if INFO = -i, the i-th argument had an illegal
C                   value;
C             = 1:  the reduction algorithm failed. The matrix
C                   associated with the generator is not (numerically)
C                   positive definite.
C
C     METHOD
C
C     If  TYPET = 'R',  a QR decomposition of B is first computed.
C     Then, the elements below the first row of each column i of B
C     are annihilated by a Householder transformation modifying the
C     first element in that column. This first element, in turn, is
C     then annihilated by a modified hyperbolic rotation, acting also
C     on the i-th row of A.
C
C     If  TYPET = 'C',  an LQ decomposition of B is first computed.
C     Then, the elements on the right of the first column of each row i
C     of B are annihilated by a Householder transformation modifying the
C     first element in that row. This first element, in turn, is
C     then annihilated by a modified hyperbolic rotation, acting also
C     on the i-th column of A.
C
C     CONTRIBUTOR
C
C     D. Kressner, Technical Univ. Chemnitz, Germany, June 2000.
C
C     REVISIONS
C
C     V. Sima, Research Institute for Informatics, Bucharest, July 2000,
C     February 2004.
C
C     KEYWORDS
C
C     Elementary matrix operations, Householder transformation, matrix
C     operations, Toeplitz matrix.
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION  ZERO, ONE
      PARAMETER         ( ZERO = 0.0D0, ONE = 1.0D0 )
C     .. Scalar Arguments ..
      CHARACTER         TYPET
      INTEGER           INFO, K, LDA, LDB, LCS, LDWORK, P, Q
C     .. Array Arguments ..
      DOUBLE PRECISION  A(LDA, *), B(LDB, *), CS(*), DWORK(*)
C     .. Local Scalars ..
      LOGICAL           ISROW
      INTEGER           I, IERR
      DOUBLE PRECISION  ALPHA, BETA, C, MAXWRK, S, TAU
C     .. External Functions ..
      LOGICAL           LSAME
      EXTERNAL          LSAME
C     .. External Subroutines ..
      EXTERNAL          DAXPY, DGELQF, DGEQRF, DLARF, DLARFG, DSCAL,
     $                  MA02FD, XERBLA
C     .. Intrinsic Functions ..
      INTRINSIC         MAX, MIN
C
C     .. Executable Statements ..
C
C     Decode the scalar input parameters.
C
      INFO  = 0
      ISROW = LSAME( TYPET, 'R' )
C
C     Check the scalar input parameters.
C
      IF ( .NOT.( ISROW .OR. LSAME( TYPET, 'C' ) ) ) THEN
         INFO = -1
      ELSE IF ( P.LT.0 ) THEN
         INFO = -2
      ELSE IF ( Q.LT.0 ) THEN
         INFO = -3
      ELSE IF ( K.LT.0 .OR. K.GT.P ) THEN
         INFO = -4
      ELSE IF ( LDA.LT.1 .OR. ( ISROW .AND. LDA.LT.P ) .OR.
     $                   ( .NOT.ISROW .AND. LDA.LT.K ) ) THEN
         INFO = -6
      ELSE IF ( LDB.LT.1 .OR. ( ISROW .AND. LDB.LT.Q ) .OR.
     $                   ( .NOT.ISROW .AND. LDB.LT.K ) ) THEN
         INFO = -8
      ELSE IF ( LCS.LT.2*K + MIN( K, Q ) ) THEN
         INFO = -10
      ELSE IF ( LDWORK.LT.MAX( 1, K ) ) THEN
         DWORK(1) = MAX( 1, K )
         INFO = -12
      END IF
C
C     Return if there were illegal values.
C
      IF ( INFO.NE.0 ) THEN
         CALL XERBLA( 'MB02CX', -INFO )
         RETURN
      END IF
C
C     Quick return if possible.
C
      IF ( MIN( Q, K ).EQ.0 ) THEN
         DWORK(1) = ONE
         RETURN
      END IF
C
      IF ( ISROW ) THEN
C
C        The generator is row wise stored.
C
C        Step 0: Do QR decomposition of B.
C
         CALL DGEQRF ( Q, K, B, LDB, CS(2*K+1), DWORK(1), LDWORK, IERR )
         MAXWRK = DWORK(1)
C
         DO 10  I = 1, K
C
C           Step 1: annihilate the i-th column of B.
C
            IF ( Q.GT.1 ) THEN
               CALL DLARFG( MIN( I, Q ), B(1,I), B(2,I), 1, TAU )
               ALPHA  = B(1,I)
               B(1,I) = ONE
               IF ( K.GT.I )
     $            CALL DLARF( 'Left', MIN( I, Q ), K-I, B(1,I), 1, TAU,
     $                        B(1,I+1), LDB, DWORK )
               B(1,I) = ALPHA
            ELSE
               ALPHA = B(1,I)
               TAU   = ZERO
            END IF
C
C           Step 2: annihilate the top entry of the column.
C
            BETA = A(I,I)
            CALL MA02FD( BETA, ALPHA, C, S, IERR )
            IF ( IERR.NE.0 ) THEN
C
C              Error return:  The matrix is not positive definite.
C
               INFO = 1
               RETURN
            END IF
C
            CS(I*2-1) = C
            CS(I*2)   = S
            CALL DSCAL( K-I+1, ONE/C, A(I,I), LDA )
            CALL DAXPY( K-I+1,  -S/C, B(1,I), LDB, A(I,I), LDA )
            CALL DSCAL( K-I+1,     C, B(1,I), LDB )
            CALL DAXPY( K-I+1,    -S, A(I,I), LDA, B(1,I), LDB )
            B(1,I) = TAU
   10    CONTINUE
C
      ELSE
C
C        The generator is column wise stored.
C
C        Step 0: Do LQ decomposition of B.
C
         CALL DGELQF ( K, Q, B, LDB, CS(2*K+1), DWORK(1), LDWORK, IERR )
         MAXWRK = DWORK(1)
C
         DO 20  I = 1, K
C
C           Step 1: annihilate the i-th row of B.
C
            IF ( Q.GT.1 ) THEN
               CALL DLARFG( MIN( I, Q ), B(I,1), B(I,2), LDB, TAU )
               ALPHA  = B(I,1)
               B(I,1) = ONE
               IF ( K.GT.I )
     $            CALL DLARF( 'Right', K-I, MIN( I, Q ), B(I,1), LDB,
     $                        TAU, B(I+1,1), LDB, DWORK )
               B(I,1) = ALPHA
            ELSE
               ALPHA = B(I,1)
               TAU   = ZERO
            END IF
C
C           Step 2: annihilate the left entry of the row.
C
            BETA = A(I,I)
            CALL MA02FD( BETA, ALPHA, C, S, IERR )
            IF ( IERR.NE.0 ) THEN
C
C              Error return:  The matrix is not positive definite.
C
               INFO = 1
               RETURN
            END IF
C
            CS(I*2-1) = C
            CS(I*2)   = S
            CALL DSCAL( K-I+1, ONE/C, A(I,I), 1 )
            CALL DAXPY( K-I+1,  -S/C, B(I,1), 1, A(I,I), 1 )
            CALL DSCAL( K-I+1,     C, B(I,1), 1 )
            CALL DAXPY( K-I+1,    -S, A(I,I), 1, B(I,1), 1 )
            B(I,1) = TAU
   20    CONTINUE
C
      END IF
C
      DWORK(1) = MAXWRK
C
      RETURN
C
C *** Last line of MB02CX ***
      END


      SUBROUTINE MF_TMTRX

c     Computation of M matrix elements as defined by Budden in Proc.
c     Roy. Soc. (London), A227, pp. 516-537 (1955).  Those combinations
c     of M matrix elements used in the T matrix which do not include
c     use of THETA are the final output of this routine.  The dummy
c     indexing on L is used in view of possible storage (as functions
c     of height) and re-use of these combinations for different values
c     of THETA.

      parameter     (mxeigen=50)

      character*  8  archive,prgm_id
      character* 20  xmtr_id,path_id
      character* 40  prfl_id
      character* 80  case_id
      character*120  file_id
      integer        pflag,pindex
      real           lat,lon,lub
      complex        eigen

      common/lwpc_in/archive,file_id(3),prgm_id,
     &               case_id,prfl_id,xmtr_id,path_id,
     &               freq,tlat,tlon,bearng,rhomx,rlat,rlon,rrho,pflag,
     &               lat,lon,rho,azim,dip,bfield,sigma,epsr,beta,hprime,
     &               hofwr,topht,botht,pindex
     &      /lwpc_mf/ranger(2),rangei(2),atnmax,lub,h,
     &               eigen(mxeigen),nreigen
     &      /lwpc_pr/hten(51),algen(51,3),nrhten,ihten,
     &               htnu(51),algnu(51,3),nrhtnu,ihtnu,
     &               charge(3),ratiom(3),nrspec,lu_prf,
     &               select_hgts(2),hgts(3)

      real           nu
      complex        g,q,theta,c,s,csq,ssq,
     &               m11,m21,m31,m12,m22,m32,m13,m23,m33,t11ovs,t44ovs,
     &               t12ovs,t34ovs,t14a,t31,t42,t32mc2,t41m1,
     &               capd,u,usq,usqd,yud,ysqd,ta,tb,
     &               m13d,m31d,m23d,m32d,m2332d,m1331d,m2331d,m3213d

      common/mf_drcs/dcl,dcm,dcn,ec,g,q
     &      /mf_hgts/rtol,xintrp,htntrp,d,z0,zz
     &      /mf_mode/theta,c,s,csq,ssq,omega,wavenr,ideriv
     &      /mf_mmtx/m11,m21,m31,m12,m22,m32,m13,m23,m33,ht
     &      /mf_tmtx/t11ovs,t44ovs,t12ovs,t34ovs,t14a,t31,t42,t32mc2,
     &               t41m1

      dimension      en(3),nu(3)

      data           cx/3.182357e09/,cy/1.758796e7/,re/6369.427/

      dclsq=dcl**2
      dcmsq=dcm**2
      dcnsq=dcn**2

      call PRFL_EN NU (ht,en,nu)

      yud= (0.,0.)
      ysqd=(0.,0.)
      usqd=(0.,0.)
      do n=1,nrspec

         coeffx=cx*(charge(n)/omega)**2/ratiom(n)
         y=cy*bfield/omega*charge(n)/ratiom(n)
         ysq=y**2

         x=coeffx*en(n)
         z=nu(n)/omega
         u=CMPLX(1.,-z)
         usq=u*u
         capd=-x/(u*(usq-ysq))
         usqd=usqd+usq*capd
         yud =yud +y*u*capd
         ysqd=ysqd+ysq*capd
      end do

      crvtrm=2./re*(ht-h)

      m11=usqd-dclsq*ysqd+crvtrm
      m22=usqd-dcmsq*ysqd+crvtrm
      m33=usqd-dcnsq*ysqd+crvtrm
      ta=CMPLX(0.,dcn)*yud
      tb=dcl*dcm*ysqd
      m21=+ta-tb
      m12=-ta-tb
      ta=CMPLX(0.,dcm)*yud
      tb=dcl*dcn*ysqd
      m13=+ta-tb
      m31=-ta-tb
      ta=CMPLX(0.,dcl)*yud
      tb=dcm*dcn*ysqd
      m32=+ta-tb
      m23=-ta-tb

      capd=(1.,0.)/((1.,0.)+m33)
      m13d=m13*capd
      m31d=m31*capd
      m23d=m23*capd
      m32d=m32*capd
      m2332d=m32*m23d
      m1331d=m31*m13d
      m2331d=m31*m23d
      m3213d=m32*m13d

      t11ovs=-m31d
      t44ovs=-m13d
      t12ovs=m32d
      t34ovs=m23d
      t14a=m33*capd
      t31=m2331d-m21
      t42=m3213d-m12
      t32mc2=m22-m2332d
      t41m1=m11-m1331d
      RETURN
      END      ! MF_T MTRX


      subroutine ptlcc(c1,c2,n)
C............. n -   c o kacate  h x  p m x
      dimension c1(3),c2(3)
       common/gfgmc/p1(2),p2(2),p3(2),p4(2),p5(2),p6(2),p7(2),p8(2)
      delx=c2(1)-c1(1)
      dely=c2(2)-c1(2)
        d=sqrt(delx*delx+dely*dely)
      r1=abs(c1(3))
      r2=abs(c2(3))
      st=dely/d
      ct=delx/d
       if(d-abs(r1-r2)) 8,6,1
C.............bhe hee kacah e
  1    s=sqrt(d*d-(r1-r2)*(r1-r2))
      th=atan2(s,r1-r2)
      x1=r1*cos(th)
      h1=r1*sin(th)
      x2=r2*cos(th)+d
      h2=r2*sin(th)
      p1(1)=x1*ct-h1*st+c1(1)
      p1(2)=x1*st+h1*ct+c1(2)
      p2(1)=x2*ct-h2*st+c1(1)
      p2(2)=x2*st+h2*ct+c1(2)
      p3(1)=x1*ct+h1*st+c1(1)
      p3(2)=x1*st-h1*ct+c1(2)
      p4(1)=x2*ct+h2*st+c1(1)
      p4(2)=x2*st-h2*ct+c1(2)
      if(d-(r1+r2)) 4,3,2
  2       d1=(d*r1)/(r1+r2)
        d2=d-d1
      x3=r1*r1/d1
      h3=sqrt(r1*r1-x3*x3)
       x4=r2*r2/d2
      h4=-sqrt(r2*r2-x4*x4)
        x4=d-x4
       p5(1)=x3*ct-h3*st+c1(1)
       p5(2)=x3*st+h3*ct+c1(2)
       p6(1)=x4*ct-h4*st+c1(1)
      p6(2)=x4*st+h4*ct+c1(2)
      p7(1)=x3*ct+h3*st+c1(1)
       p7(2)=x3*st-h3*ct+c1(2)
      p8(1)=x4*ct+h4*st+c1(1)
      p8(2)=x4*st-h4*ct+c1(2)
      n=4
       goto 11
  3    p5(1)=r1*ct+c1(1)
       p5(2)=r1*st+c1(2)
       p6(1)=p5(1)
       p6(2)=p5(2)
       n=3
      goto 11
  4     n=2
        goto 11
  6     p1(1)=r1*ct+c1(1)
        p1(2)=r1*st+c1(2)
       p2(1)=p1(1)
       p2(2)=p1(2)
        n=1
        goto 11
  8     n=0
  11    return
        end