!	Find location of maximum posterior density of the latent vector.
!	catobsrange is used to relate observed and underlying categories.
!	maxita is used to determine the number of iterations to use to find the maximum posterior density.
!	maxitb is used for subiterations.
!	npred is the number of predictors.
!	numcat provides ranges for underlying observations,
!	numcatobs provides ranges of observations, mask indicates items to use for computations.
!	obsmask is an observation mask that can be used to restrict attention to a portion of the response.
!	beta is the parameter vector.
!	changemin is used for minimum change.
!	linth is the linear component of the log density.
!	lintran is the linear transformation of the latent vector.
!	maxdtheta is the maximum permitted change in the approximation of the maximum in one step.
!	quadth is the quadratic component of the log density.
!	resp is the response.
!	tau is used for minimum step sizes.
!	tol is used to determine the desired accuracy of the maximization.
!	tolsing is used to determine the tolerance for the Cholesky decomposition.
!	nhchol is the modified Cholesky decomposition of the negative hessian.
!	theta is the maximum.

subroutine maxpost(catobsrange,maxita,maxitb,npred,numcat,numcatobs,resp,obsmask,beta,changemin,&
	linth,lintran,maxdtheta,quadth,tau,tol,tolsing,&
	nhchol,theta)
implicit none
interface

	function chol(sym,tolsing)
!	chol is used to compute a modified Cholesky decomposition of the n by n matrix sym.
!	The singularity tolerance is tolsing.
		implicit none
		real(kind=8),intent(in)::sym(:,:),tolsing
	 	real(kind=8)::chol(size(sym,1),size(sym,1))
	end function chol

!	Obtain conditional covariance matrix of item scale parameters for an observation.
!	catobsrange contains the range of underlying categories per observed category.
!	numcatobs is a vector with the number of observed  categories per item.
!	resp is the observation vector.
!	The items presented are indicated by mask.
!	condmeans contains the conditional means.
!	The underlying item conditional probabilities are in condprobcat.
!	The scale parameters are in scales.
	function condcovmat(catobsrange,numcatobs,resp,mask,condmeans,condprobcat,scales)
		implicit none
		integer,intent(in)::numcatobs(:),catobsrange(:,:),resp(:)
		logical,intent(in)::mask(:)
		real(kind=8),intent(in)::condmeans(:,:),condprobcat(:),scales(:,:)
		real(kind=8)::condcovmat(size(scales,1),size(scales,1),size(resp))!	Obtain conditional covariance matrix of item scale parameters for an observation resp.

	end function condcovmat
!	Obtain conditional mean item scale parameters.
!	catobsrange contains the range of underlying categories per observed category.
!	numcatobs is a vector with the number of observed categories per item.
!	The observation is resp.
!	The items presented are indicated by mask.
!	The underlying conditional item probabilities are in condprobcat.
!	scales is the matrix of scale parameters.
	function condmean(catobsrange,numcatobs,resp,mask,condprobcat,scales)
		implicit none
		integer,intent(in)::catobsrange(:,:),numcatobs(:),resp(:)
		logical,intent(in)::mask(:)
		real(kind=8),intent(in)::condprobcat(:),scales(:,:)
		real(kind=8)::condmean(size(scales,1),size(resp))
	end function condmean

!	condprobvec is used to compute observed item conditional probabilities of underlying item categories given
!	observed item categories.
!	catobsrange provides ranges of underlying item categories that correspond to observed item categories.
!	numcatobs provides the number of observed categories per item.
!	resp is the item response.
!	mask indicates which items were presented.
!	probcat is the vector of underlying category probabilities.
!	probcatobs is the vector of observed category probabilities.
	function condprobvec(catobsrange,numcatobs,resp,mask,probcat,probcatobs)
		implicit none
		integer,intent(in)::catobsrange(:,:),numcatobs(:),resp(:)
		logical,intent(in)::mask(:)
		real(kind=8),intent(in)::probcat(:),probcatobs(:)
		real(kind=8)::condprobvec(size(probcat))
	end function condprobvec

!	Obtain covariance matrix of item scale parameters for an observation.
!	numcat is a vector with the number of underlying categories per category.
!	The items presented are indicated by mask.
!	means contains the corresponding means.
!	The underlying item probabilities are in probcat.
!	scales contains the scale parameters.
	function covmat(numcat,mask,means,probcat,scales)
		implicit none
		integer,intent(in)::numcat(:)
		logical,intent(in)::mask(:)
		real(kind=8),intent(in)::means(:,:),probcat(:),scales(:,:)
		real(kind=8)::covmat(size(scales,1),size(scales,1),size(mask))
	end function covmat

!

!	Find the gradient of the conditional log posterior.
!	mask indicates which items are present.
!	condmeans is the vector of conditional means of scale factors.
!	linth is the linear component of the log density.
!	lintran is the linear transformation of the latent vector.
!	means is the vector of means of scale factors.
!	quadth is the quadratic component of the log density.
!	theta is the value of the latent vector.
	function gradtheta(mask,condmeans,linth,lintran,means,quadth,theta)
		implicit none
		logical,intent(in)::mask(:)
		real(kind=8),intent(in)::condmeans(:,:),linth(:),lintran(:,:),means(:,:),quadth(:,:),theta(:)
		real(kind=8)::gradtheta(size(theta))
	end function gradtheta

!	Compute inverse for n by n matrix with modified Cholesky
!	decomposition tri.
	function invert(tri)
		implicit none
		real(kind=8),intent(in)::tri(:,:)
		real(kind=8)::invert(size(tri,1),size(tri,1))
	end function invert

!	Obtain mean item scale parameters for an observation.
!	numcat is a vector with the number of
!		underlying categories per item.
!	The items presented are indicated by mask.
!	The underlying item probabilities are in probcat.
!	scales contains the scale parameters.
	function mean(numcat,mask,probcat,scales)
		implicit none
		integer,intent(in)::numcat(:)
		logical,intent(in)::mask(:)
		real(kind=8),intent(in)::probcat(:),scales(:,:)
		real(kind=8)::mean(size(scales,1),size(mask))
	end function mean

!	Find the negative hessian of the conditional log posterior of an observation
!	relative to the latent vector theta.
!	mask indicates which items are present.
!	condcovs is the arrayr of conditional covariance matrics of scale factors.
!	covs is the array of covariance matrices of scale factors.
!	lintran is the linear transformation of the latent vector.
!	quadth is the matrix parameter for the log density.

	function nhesstheta(mask,condcovs,covs,lintran,quadth)
		implicit none
		logical,intent(in)::mask(:)
		real(kind=8),intent(in)::condcovs(:,:,:),covs(:,:,:),lintran(:,:),quadth(:,:)
		real(kind=8)::nhesstheta(size(quadth,1),size(quadth,1))
	end function nhesstheta

!	Find a substitute negative hessian nhessth of the conditional log posterior of an observation
!	relative to the latent vector theta.
!	mask indicates which items are present.
!	condmeans is the vector of conditional means of scale factors.
!	gradth is the gradient.
!	lintran is the linear transformation of the latent vector.
!	means is the vector of means of scale factors.
!	quadth is the matrix of parameters used in the log density.
	function nhessthsub(mask,condmeans,gradth,lintran,means,quadth)
		implicit none
		logical,intent(in)::mask(:)
		real(kind=8),intent(in)::condmeans(:,:),gradth(:),lintran(:,:),means(:,:),quadth(:,:)
		real(kind=8)::nhessthsub(size(means,1),size(means,1))
	end function nhessthsub

!	probvec is used to compute underlying item probabilities.
!   	numcat indicates the number of underlying categories per item.
!	mask indicates which items were presented.
!	locations provides location parameters and scales provides scale factors.
!	theta is the value of the latent vector.
	function probvec(numcat,mask,locations,scales,theta)
		implicit none
		integer,intent(in)::numcat(:)
		logical,intent(in)::mask(:)
		real(kind=8),intent(in)::locations(:),scales(:,:),theta(:)
		real(kind=8)::probvec(size(locations))
	end function probvec

!	probvecobs is used to compute observed item probabilities given the latent vector.
!	catobsrange is the table of ranges of underlying categories per observed category.
!	numcatobs provides the number of observed categories per item.
!	resp is the response vector.
!	mask indicates which items were presented.
!	probcat is the vector of underlying item probabilities.
	function probvecobs(catobsrange,numcatobs,resp,mask,probcat)
		implicit none
		integer,intent(in)::catobsrange(:,:),numcatobs(:),resp(:)
		logical,intent(in)::mask(:)
		real(kind=8),intent(in)::probcat(:)
		real(kind=8)::probvecobs(size(mask))
	end function probvecobs

!		This program uses the modified Cholesky decomposition
!		in lu to solve the equation lusolve = b.
	function solve(lu,b)
		implicit none

		real(kind=8),intent(in)::lu(:,:)
		real(kind=8),intent(in)::b(:)
		real(kind=8)::solve(size(b))
	end function solve
end interface
integer,intent(in)::catobsrange(:,:),maxita,maxitb,npred,numcat(:),numcatobs(:),resp(:)
logical,intent(in)::obsmask(:)
real(kind=8),intent(in)::beta(:),changemin,linth(:),lintran(:,:),maxdtheta,quadth(:,:),tau,tol,tolsing
real(kind=8),intent(inout)::theta(:)
real(kind=8),intent(out)::nhchol(:,:)

!	dimlatin is the dimension of the latent vector.
!	dimlatout is the dimension of the transformed latent vector.
!	ita counts main iterations.
!	itb counts subiterations.
!	item is an item counter.
!	ncat is the total number of underlying categories.
!	nitems is the number of items.

!	nscale is the pointer for scale parameters.
!	nscale1 is the pointer for the last scale parameter.
!	row is a row counter.

integer::dimlatin,dimlatout,ita,itb,item,ncat,nitems,&
	nscale,nscale1,row
!	Data mask.
logical::mask(size(obsmask))
!	change is a change in logcondprob.
!	condcovs is used to find conditional covariance  matrices of scale parameters.
!	condmeans is used to find conditional means of scale parameters.
!	condprobcat is used for conditional probabilities.
!	covs  is used to find covariance matrices of scale parameters.
!	covth is the covariance matrix of the latent vector.
!	der is a directional derivative.
!	gradth is the gradient of the logarithm of the posterior.
!	lintheta is for linear parameters for the log density.
!	locations is for location parameters.
!	logcondprob is a log conditional probability plus log density.
!	maxthetastep is the maximum norm of thetastep.
!	means is used to find means of scale parameters.
!	meanth is the mean of the latent vector.
!	newtheta is the transformed value of the latent vector.
!	nhchol is a Cholesky decomposition of -2*quadth.
!	nhessth is the negative heessian of the logarithm of the posterior.
!	oldlogcondprob is the previous value of logcondprob.
!	oldtheta is a previous approximation of the location of the maximum.
!	probcat is used for underlying marginal conditional probabilities.
!	probcatobs is used for observed marginal conditional probabilities.
!	quadtheta is for quadratic parameters for the log density.
!	scales is for scale parameters.
!	step is a step size.
!	stepmin is a minimum step size.
!	thetastep is the proposed change in the approximation of the location of the maximum.

real(kind=8)::change,condcovs(size(lintran,1),size(lintran,1),size(obsmask)),&
	condmeans(size(lintran,1),size(obsmask)),condprobcat(sum(numcat)),&
	covs(size(lintran,1),size(lintran,1),size(obsmask)),&
	der,gradth(size(theta)),&
	locations(sum(numcat)),logcondprob,&
	maxthetastep,means(size(lintran,1),size(obsmask)),&
	newtheta(size(lintran,1)),nhessth(size(theta),size(theta)),&
	oldlogcondprob,oldtheta(size(theta)),&
	probcat(sum(numcat)),probcatobs(size(obsmask)),scales(size(lintran,1),sum(numcat)),&
	step,stepmin,thetastep(size(theta))

!	Set up parameter arrays for simplified processing.
ncat=sum(numcat)
nitems=size(obsmask)

dimlatin=size(theta)
dimlatout=size(lintran,1)

!	Item scale parameters.
nscale=ncat+1
nscale1=nscale+size(scales)-1
locations=beta(1:ncat)
scales=reshape(beta(nscale:nscale1),(/dimlatout,ncat/))

!	Mask
mask=.false.
do item=1,nitems
	if(resp(item)>=0.and.resp(item)<numcatobs(item))mask(item)=.true.
end do
mask=mask.and.obsmask

! 	Location maximum of likelihood contribution for examinee k.

! 	Probabilities.

!	Individual probabilities
newtheta=matmul(lintran,theta)
probcat=probvec(numcat,mask,locations,scales,newtheta)
probcatobs=probvecobs(catobsrange,numcatobs,resp,mask,probcat)
logcondprob=sum(log(probcatobs),mask)+dot_product(linth+matmul(quadth,theta),theta)

do ita=1,maxita

!	Needed  means and covariance matrices.
	condprobcat=condprobvec(catobsrange,numcatobs,resp,mask,probcat,probcatobs)

	means=mean(numcat,mask,probcat,scales)
	covs=covmat(numcat,mask,means,probcat,scales)

	condmeans=condmean(catobsrange,numcatobs,resp,mask,condprobcat,scales)

	condcovs=condcovmat(catobsrange,numcatobs,resp,mask,condmeans,condprobcat,scales)

!	Gradient and negative hessian.
	gradth=gradtheta(mask,condmeans,linth,lintran,means,quadth,theta)
	nhessth=nhesstheta(mask,condcovs,covs,lintran,quadth)

! 	Step computation.
	nhchol=chol(nhessth,tolsing)

!	If not nonnegative definite, then use Louis approach.
	if(minval((/(nhchol(row,row),row=1,dimlatin)/))<0.0_8)then
		nhessth=nhessthsub(mask,condmeans,gradth,lintran,means,quadth)

		nhchol=chol(nhessth,tolsing)

	end if
	thetastep=solve(nhchol,gradth)

! 	Step reduction if necessary.
	maxthetastep=maxval(abs(thetastep))
	if(maxthetastep==0.0_8)exit
	step=1.0_8
	if(maxthetastep>maxdtheta)step=maxdtheta/maxthetastep
	der=dot_product(gradth,thetastep)
	oldtheta=theta
	oldlogcondprob=logcondprob
	do itb=1,maxita
		theta=oldtheta+step*thetastep

! 	Probabilities.

		newtheta=matmul(lintran,theta)
		probcat=probvec(numcat,mask,locations,scales,newtheta)
		probcatobs=probvecobs(catobsrange,numcatobs,resp,mask,probcat)
		logcondprob=sum(log(probcatobs),mask)+dot_product(linth+matmul(quadth,theta),theta)

!	Test  for adequate progress.

		change=logcondprob-oldlogcondprob
		if(change>step*der*changemin) exit
		stepmin = step*tau
		step = step*der/(2.0_8*(der-change/step))
		if(step<stepmin) step = stepmin
	end do
	if(change<tol) exit
end do
!	Save results.
condprobcat=condprobvec(catobsrange,numcatobs,resp,mask,probcat,probcatobs)
means=mean(numcat,mask,probcat,scales)
covs=covmat(numcat,mask,means,probcat,scales)
condmeans=condmean(catobsrange,numcatobs,resp,mask,condprobcat,scales)
condcovs=condcovmat(catobsrange,numcatobs,resp,mask,condmeans,condprobcat,scales)
!	Gradient and negative hessian.
gradth=gradtheta(mask,condmeans,linth,lintran,means,quadth,theta)
nhessth=nhesstheta(mask,condcovs,covs,lintran,quadth)

nhchol=chol(nhessth,tolsing)
!	If not nonnegative definite, then use Louis approach.
if(minval((/(nhchol(row,row),row=1,dimlatin)/))<0.0_8)then
	nhessth=nhessthsub(mask,condmeans,gradth,lintran,means,quadth)
	nhchol=chol(nhessth,tolsing)
end if
return
end subroutine maxpost


c
c     cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
      subroutine u_sigma_u(u,ud,usu_x,usu_y,usu_z)
c     ================================================================
c
      implicit   none
c
      complex*16 u(4)
      complex*16 ud(4)
      complex*16 usu_x(4)
      complex*16 usu_y(4)
      complex*16 usu_z(4)
      complex*16 sqrtm1
c
      parameter (sqrtm1=(0.0d0,1.0d0))
c
c     ****************************************************************
c     calculate:
c                     +                   +                   +
c        u * sigma * u ,     u * sigma * u ,     u * sigma * u
c                 x                   y                   z
c     ****************************************************************
c
      usu_x(1)=u(3)*ud(1)+u(1)*ud(2)
      usu_x(2)=u(4)*ud(1)+u(2)*ud(2)
      usu_x(3)=u(3)*ud(3)+u(1)*ud(4)
      usu_x(4)=u(4)*ud(3)+u(2)*ud(4)
c
      usu_y(1)=(u(3)*ud(1)-u(1)*ud(2))*sqrtm1
      usu_y(2)=(u(4)*ud(1)-u(2)*ud(2))*sqrtm1
      usu_y(3)=(u(3)*ud(3)-u(1)*ud(4))*sqrtm1
      usu_y(4)=(u(4)*ud(3)-u(2)*ud(4))*sqrtm1
c
      usu_z(1)=u(1)*ud(1)-u(3)*ud(2)
      usu_z(2)=u(2)*ud(1)-u(4)*ud(2)
      usu_z(3)=u(1)*ud(3)-u(3)*ud(4)
      usu_z(4)=u(2)*ud(3)-u(4)*ud(4)
c
      return
      end


*> \brief \b ZGELQT3 recursively computes a LQ factorization of a general real or complex matrix using the compact WY representation of Q.
*
*  =========== DOCUMENTATION ===========
*
* Online html documentation available at
*            http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZGELQT3 + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
*  Definition:
*  ===========
*
*       RECURSIVE SUBROUTINE ZGELQT3( M, N, A, LDA, T, LDT, INFO )
*
*       .. Scalar Arguments ..
*       INTEGER   INFO, LDA, M, N, LDT
*       ..
*       .. Array Arguments ..
*       COMPLEX*16   A( LDA, * ), T( LDT, * )
*       ..
*
*
*> \par Purpose:
*  =============
*>
*> \verbatim
*>
*> ZGELQT3 recursively computes a LQ factorization of a complex M-by-N
*> matrix A, using the compact WY representation of Q.
*>
*> Based on the algorithm of Elmroth and Gustavson,
*> IBM J. Res. Develop. Vol 44 No. 4 July 2000.
*> \endverbatim
*
*  Arguments:
*  ==========
*
*> \param[in] M
*> \verbatim
*>          M is INTEGER
*>          The number of rows of the matrix A.  M =< N.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*>          N is INTEGER
*>          The number of columns of the matrix A.  N >= 0.
*> \endverbatim
*>
*> \param[in,out] A
*> \verbatim
*>          A is COMPLEX*16 array, dimension (LDA,N)
*>          On entry, the complex M-by-N matrix A.  On exit, the elements on and
*>          below the diagonal contain the N-by-N lower triangular matrix L; the
*>          elements above the diagonal are the rows of V.  See below for
*>          further details.
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*>          LDA is INTEGER
*>          The leading dimension of the array A.  LDA >= max(1,M).
*> \endverbatim
*>
*> \param[out] T
*> \verbatim
*>          T is COMPLEX*16 array, dimension (LDT,N)
*>          The N-by-N upper triangular factor of the block reflector.
*>          The elements on and above the diagonal contain the block
*>          reflector T; the elements below the diagonal are not used.
*>          See below for further details.
*> \endverbatim
*>
*> \param[in] LDT
*> \verbatim
*>          LDT is INTEGER
*>          The leading dimension of the array T.  LDT >= max(1,N).
*> \endverbatim
*>
*> \param[out] INFO
*> \verbatim
*>          INFO is INTEGER
*>          = 0: successful exit
*>          < 0: if INFO = -i, the i-th argument had an illegal value
*> \endverbatim
*
*  Authors:
*  ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \ingroup doubleGEcomputational
*
*> \par Further Details:
*  =====================
*>
*> \verbatim
*>
*>  The matrix V stores the elementary reflectors H(i) in the i-th row
*>  above the diagonal. For example, if M=5 and N=3, the matrix V is
*>
*>               V = (  1  v1 v1 v1 v1 )
*>                   (     1  v2 v2 v2 )
*>                   (     1  v3 v3 v3 )
*>
*>
*>  where the vi's represent the vectors which define H(i), which are returned
*>  in the matrix A.  The 1's along the diagonal of V are not stored in A.  The
*>  block reflector H is then given by
*>
*>               H = I - V * T * V**T
*>
*>  where V**T is the transpose of V.
*>
*>  For details of the algorithm, see Elmroth and Gustavson (cited above).
*> \endverbatim
*>
*  =====================================================================
      RECURSIVE SUBROUTINE ZGELQT3( M, N, A, LDA, T, LDT, INFO )
*
*  -- LAPACK computational routine --
*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
*     .. Scalar Arguments ..
      INTEGER   INFO, LDA, M, N, LDT
*     ..
*     .. Array Arguments ..
      COMPLEX*16   A( LDA, * ), T( LDT, * )
*     ..
*
*  =====================================================================
*
*     .. Parameters ..
      COMPLEX*16   ONE, ZERO
      PARAMETER ( ONE = (1.0D+00,0.0D+00) )
      PARAMETER ( ZERO = (0.0D+00,0.0D+00))
*     ..
*     .. Local Scalars ..
      INTEGER   I, I1, J, J1, M1, M2, IINFO
*     ..
*     .. External Subroutines ..
      EXTERNAL  ZLARFG, ZTRMM, ZGEMM, XERBLA
*     ..
*     .. Executable Statements ..
*
      INFO = 0
      IF( M .LT. 0 ) THEN
         INFO = -1
      ELSE IF( N .LT. M ) THEN
         INFO = -2
      ELSE IF( LDA .LT. MAX( 1, M ) ) THEN
         INFO = -4
      ELSE IF( LDT .LT. MAX( 1, M ) ) THEN
         INFO = -6
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'ZGELQT3', -INFO )
         RETURN
      END IF
*
      IF( M.EQ.1 ) THEN
*
*        Compute Householder transform when M=1
*
         CALL ZLARFG( N, A, A( 1, MIN( 2, N ) ), LDA, T )
         T(1,1)=CONJG(T(1,1))
*
      ELSE
*
*        Otherwise, split A into blocks...
*
         M1 = M/2
         M2 = M-M1
         I1 = MIN( M1+1, M )
         J1 = MIN( M+1, N )
*
*        Compute A(1:M1,1:N) <- (Y1,R1,T1), where Q1 = I - Y1 T1 Y1^H
*
         CALL ZGELQT3( M1, N, A, LDA, T, LDT, IINFO )
*
*        Compute A(J1:M,1:N) =  A(J1:M,1:N) Q1^H [workspace: T(1:N1,J1:N)]
*
         DO I=1,M2
            DO J=1,M1
               T(  I+M1, J ) = A( I+M1, J )
            END DO
         END DO
         CALL ZTRMM( 'R', 'U', 'C', 'U', M2, M1, ONE,
     &               A, LDA, T( I1, 1 ), LDT )
*
         CALL ZGEMM( 'N', 'C', M2, M1, N-M1, ONE, A( I1, I1 ), LDA,
     &               A( 1, I1 ), LDA, ONE, T( I1, 1 ), LDT)
*
         CALL ZTRMM( 'R', 'U', 'N', 'N', M2, M1, ONE,
     &               T, LDT, T( I1, 1 ), LDT )
*
         CALL ZGEMM( 'N', 'N', M2, N-M1, M1, -ONE, T( I1, 1 ), LDT,
     &                A( 1, I1 ), LDA, ONE, A( I1, I1 ), LDA )
*
         CALL ZTRMM( 'R', 'U', 'N', 'U', M2, M1 , ONE,
     &               A, LDA, T( I1, 1 ), LDT )
*
         DO I=1,M2
            DO J=1,M1
               A(  I+M1, J ) = A( I+M1, J ) - T( I+M1, J )
               T( I+M1, J )= ZERO
            END DO
         END DO
*
*        Compute A(J1:M,J1:N) <- (Y2,R2,T2) where Q2 = I - Y2 T2 Y2^H
*
         CALL ZGELQT3( M2, N-M1, A( I1, I1 ), LDA,
     &                T( I1, I1 ), LDT, IINFO )
*
*        Compute T3 = T(J1:N1,1:N) = -T1 Y1^H Y2 T2
*
         DO I=1,M2
            DO J=1,M1
               T( J, I+M1  ) = (A( J, I+M1 ))
            END DO
         END DO
*
         CALL ZTRMM( 'R', 'U', 'C', 'U', M1, M2, ONE,
     &               A( I1, I1 ), LDA, T( 1, I1 ), LDT )
*
         CALL ZGEMM( 'N', 'C', M1, M2, N-M, ONE, A( 1, J1 ), LDA,
     &               A( I1, J1 ), LDA, ONE, T( 1, I1 ), LDT )
*
         CALL ZTRMM( 'L', 'U', 'N', 'N', M1, M2, -ONE, T, LDT,
     &               T( 1, I1 ), LDT )
*
         CALL ZTRMM( 'R', 'U', 'N', 'N', M1, M2, ONE,
     &               T( I1, I1 ), LDT, T( 1, I1 ), LDT )
*
*
*
*        Y = (Y1,Y2); L = [ L1            0  ];  T = [T1 T3]
*                         [ A(1:N1,J1:N)  L2 ]       [ 0 T2]
*
      END IF
*
      RETURN
*
*     End of ZGELQT3
*
      END


C  PROGRAM GRAFIMG
C  6 MAR 1995  ...CRI...  MSTP S/W CONVERSION (VICAR PORTING)
	INCLUDE 'VICMAIN_FOR'
	SUBROUTINE MAIN44

	IMPLICIT NONE

	INTEGER	UNITIN
	INTEGER	SL, SS, NL, NS
	REAL BUFFER(1024), IMAGE(256,256), X, Y, Z
	REAL ZMINIMG, ZMAXIMG, ZMIN, ZMAX, LTICK, STICK, ZTICK
	REAL XSCALE, YSCALE, ZSCALE, ZTOP, ZBTM
	INTEGER	LINE, SAMP, STATUS, COUNT, NLI, NSI
        INTEGER WRGR, PUTGR,CLGR
        INTEGER SUBSAM, SUBLIN, GS, GL
        INTEGER GRIDL, GRIDS, TYPE, LINETK, SAMPTK, ZTK
	CHARACTER*3 ZTICKS
	CHARACTER*4 CUBE, LTICKS
	CHARACTER*5 MODE, STICKS
	LOGICAL MAKECUBE, COMB, FIT

	COMMON /OUTCOM/ XSCALE, YSCALE, ZSCALE, IMAGE

        CALL IFMESSAGE('GRAFIMG version 06-MAR-95')

C OPEN THE INPUT IMAGE FILE

	CALL XVUNIT (UNITIN, 'INP', 1, STATUS,' ')
	CALL XVOPEN (UNITIN,STATUS,'IO_ACT','SA','OPEN_ACT',
     +               'SA','U_FORMAT','REAL',' ')

C GET SOME INPUT PARAMETERS

	CALL XVSIZE (SL,SS,NL,NS,NLI,NSI)
        CALL XVP('ZMIN',ZMIN,COUNT)
        CALL XVP('ZMAX',ZMAX,COUNT)
        CALL XVP('ZTOP',ZTOP,COUNT)
        CALL XVP('ZBTM',ZBTM,COUNT)
        CALL XVP('SINC',SUBSAM,COUNT)
        CALL XVP('LINC',SUBLIN,COUNT)
        CALL XVP('LTICKINC',LTICK,COUNT)
        CALL XVP('STICKINC',STICK,COUNT)
        CALL XVP('ZTICKINC',ZTICK,COUNT)

C ARE WE GOING TO DRAW ANY TICK MARKS ?
C   LINE

	LINETK = 0
	CALL XVP ('LTICKS',LTICKS,COUNT)
	IF (LTICKS(1:3).EQ.'TOP') THEN
	    LINETK = 1
	ELSEIF (LTICKS(1:3).EQ.'BTM') THEN
	    LINETK = 2
	ELSEIF (LTICKS(1:4).EQ.'BOTH') THEN
	    LINETK = 3
	ENDIF

C   SAMPLE

	SAMPTK = 0
	CALL XVP ('STICKS',STICKS,COUNT)
	IF (STICKS(1:4).EQ.'LEFT') THEN
	    SAMPTK = 1
	ELSEIF (STICKS(1:5).EQ.'RIGHT') THEN
	    SAMPTK = 2
	ELSEIF (STICKS(1:4).EQ.'BOTH') THEN
	    SAMPTK = 3
	ENDIF

C   Z AXIS

	ZTK = 0
	CALL XVP ('ZTICKS',ZTICKS,COUNT)
	IF (ZTICKS(1:2).EQ.'TL') THEN
	    ZTK = 1
	ELSEIF (ZTICKS(1:2).EQ.'TR') THEN
	    ZTK = 2
	ELSEIF (ZTICKS(1:2).EQ.'BL') THEN
	    ZTK = 3
	ELSEIF (ZTICKS(1:2).EQ.'BR') THEN
	    ZTK = 4
	ELSEIF (ZTICKS(1:3).EQ.'ALL') THEN
	    ZTK = 5
	ENDIF

C FIND OUT IF WE ARE TO PUT A CUBE AROUND THE GRID

	FIT = .FALSE.
	MAKECUBE = .FALSE.
	CALL XVP ('CUBE',CUBE,COUNT)
	IF (CUBE(1:4).EQ.'CUBE') MAKECUBE = .TRUE.
	IF (CUBE(1:3).EQ.'FIT') THEN
	    MAKECUBE = .TRUE.
	    FIT = .TRUE.
	ENDIF

C NOW TEST TO MAKE SURE THAT NO GREATER THAN A 256 X 256 MESH IS USED

        GS = ( NS - 1 ) / SUBSAM + 1
        GL = ( NL - 1 ) / SUBLIN + 1

C RESET IF GREATER THAN A 256 X 256 MESH WAS REQUESTED

        IF( GS .GT. 256 ) THEN
	    SUBSAM = NS / 256  +  1
	    GS = ( NS - 1 ) / SUBSAM + 1
        ENDIF
        IF( GL .GT. 256 ) THEN
	    SUBLIN = NL / 256 +  1
	    GL = ( NL - 1 ) / SUBLIN + 1
        ENDIF

C	IF (NS .GT. 256 .OR. NL .GT. 256)  CALL MABEND('REGION TOO LARGE')

	ZMINIMG=999999.
	ZMAXIMG=-999999.
	DO GRIDL = 1, GL
            LINE = SL + (GRIDL - 1)*SUBLIN
	    CALL XVREAD (UNITIN, BUFFER, STATUS,
     +			'LINE',LINE, 'SAMP',SS, 'NSAMPS',NS,' ')
	    DO GRIDS = 1, GS
                SAMP = 1 + (GRIDS - 1)*SUBSAM
		IMAGE(GRIDS,GRIDL) = BUFFER(SAMP)
		IF (IMAGE(GRIDS,GRIDL).LT.ZMINIMG) ZMINIMG=IMAGE(GRIDS,GRIDL)
		IF (IMAGE(GRIDS,GRIDL).GT.ZMAXIMG) ZMAXIMG=IMAGE(GRIDS,GRIDL)
	    ENDDO
	ENDDO

	CALL XVCLOSE (UNITIN, STATUS,' ')

	CALL XVP ('XSCALE', XSCALE, COUNT)
	CALL XVP ('YSCALE', YSCALE, COUNT)
	CALL XVP ('ZSCALE', ZSCALE, COUNT)

	TYPE = 1
	COMB = .FALSE.
	CALL XVP ('MODE',MODE,COUNT)
	IF (MODE(1:4).EQ.'BOTH') TYPE = 1
	IF (MODE(1:4).EQ.'XONL') TYPE = 2
	IF (MODE(1:4).EQ.'YONL') TYPE = 3
	IF (MODE(1:4).EQ.'PREV') TYPE = 4
	IF (MODE(1:4).EQ.'DOTS') TYPE = 5

C		Preview and dots
	IF (MODE(1:4).EQ.'PRDT') THEN
	    COMB = .TRUE.
	    TYPE = 5
	ENDIF

	STATUS = WRGR (1, 1, 3)
        IF (STATUS.NE.1) CALL SIGNALGR(1,STATUS,1)

	IF (TYPE.NE.4) THEN
	 IF ((TYPE.EQ.1).OR.(TYPE.EQ.2).OR.(TYPE.EQ.5)) THEN
	  DO LINE = 1, GL, 2
	    DO SAMP = 1, GS
	      IF((IMAGE(LINE,SAMP).LT.ZMIN).OR.
     +         (IMAGE(LINE,SAMP).GT.ZMAX))THEN
		    STATUS = PUTGR (1, 0.0, 0.0, 0.0)
                    IF (STATUS.NE.1) CALL SIGNALGR(1,STATUS,1)
	      ELSE
		    CALL OUTGRAF (LINE, SAMP)
		    IF (TYPE.EQ.5) THEN
                      STATUS =  PUTGR (1, 0.0, 0.0, 0.0)
                      IF (STATUS.NE.1) CALL SIGNALGR(1,STATUS,1)
                    endif
	      ENDIF
	    ENDDO
	    STATUS =  PUTGR (1, 0.0, 0.0, 0.0)
            IF (STATUS.NE.1) CALL SIGNALGR(1,STATUS,1)
	    IF (LINE .LT. GL) THEN
	        DO SAMP = GS, 1, -1
	          IF((IMAGE(LINE,SAMP).LT.ZMIN).OR.
     +		     (IMAGE(LINE,SAMP).GT.ZMAX)) THEN
		    STATUS = PUTGR (1, 0.0, 0.0, 0.0)
                    IF (STATUS.NE.1) CALL SIGNALGR(1,STATUS,1)
		  ELSE
		    CALL OUTGRAF (LINE+1, SAMP)
		    IF (TYPE.EQ.5) THEN
                      STATUS = PUTGR (1, 0.0, 0.0, 0.0)
                      IF (STATUS.NE.1) CALL SIGNALGR(1,STATUS,1)
                    endif
		  ENDIF
	        ENDDO
	        STATUS =  PUTGR (1, 0.0, 0.0, 0.0)
                IF (STATUS.NE.1) CALL SIGNALGR(1,STATUS,1)
	    ENDIF
	  ENDDO
	END IF

	IF (COMB) TYPE = 4	! Preview as well as dots

	IF ((TYPE.EQ.1).OR.(TYPE.EQ.3)) THEN
	  DO SAMP = 1, GS, 2
	    DO LINE = 1, GL
	        IF((IMAGE(LINE,SAMP).LT.ZMIN).OR.
     +		     (IMAGE(LINE,SAMP).GT.ZMAX)) THEN
		    STATUS = PUTGR (1, 0.0, 0.0, 0.0)
                    IF (STATUS.NE.1) CALL SIGNALGR(1,STATUS,1)
		ELSE
		    CALL OUTGRAF (LINE, SAMP)
		ENDIF
	    ENDDO
	    STATUS =  PUTGR (1, 0.0, 0.0, 0.0)
            IF (STATUS.NE.1) CALL SIGNALGR(1,STATUS,1)
	    IF (SAMP .LT. GS) THEN
	        DO LINE = GL, 1, -1
	          IF((IMAGE(LINE,SAMP).LT.ZMIN).OR.
     +		     (IMAGE(LINE,SAMP).GT.ZMAX)) THEN
		    STATUS =  PUTGR (1, 0.0, 0.0, 0.0)
                    IF (STATUS.NE.1) CALL SIGNALGR(1,STATUS,1)
		  ELSE
		    CALL OUTGRAF (LINE, SAMP+1)
		  ENDIF
	        ENDDO
	        STATUS =  PUTGR (1, 0.0, 0.0, 0.0)
                IF (STATUS.NE.1) CALL SIGNALGR(1,STATUS,1)
	    ENDIF
	  ENDDO
	 ENDIF
	ENDIF

C PREVIEW MODE (PROFILE AROUND EDGE OF GRID)

	IF (TYPE.EQ.4) THEN
C	  Left
	    SAMP = 1
	    DO LINE = 1, GL
	        IF((IMAGE(LINE,SAMP).LT.ZBTM).OR.
     +		     (IMAGE(LINE,SAMP).GT.ZTOP)) THEN
		    STATUS =  PUTGR (1, 0.0, 0.0, 0.0)
                   IF (STATUS.NE.1) CALL SIGNALGR(1,STATUS,1)
		ELSE
		    CALL OUTGRAF (LINE, SAMP)
		ENDIF
	    ENDDO
C	  Bottom
	    LINE = GL
	    DO SAMP = 1, GS
	        IF((IMAGE(LINE,SAMP).LT.ZBTM).OR.
     +		     (IMAGE(LINE,SAMP).GT.ZTOP)) THEN
		  STATUS = PUTGR (1, 0.0, 0.0, 0.0)
                  IF (STATUS.NE.1) CALL SIGNALGR(1,STATUS,1)
		ELSE
		    CALL OUTGRAF (LINE, SAMP)
		ENDIF
	    ENDDO
C	  Right
	    SAMP = GS
	    DO LINE = GL, 1, -1
	        IF((IMAGE(LINE,SAMP).LT.ZBTM).OR.
     +		     (IMAGE(LINE,SAMP).GT.ZTOP)) THEN
		   STATUS = PUTGR (1, 0.0, 0.0, 0.0)
                   IF (STATUS.NE.1) CALL SIGNALGR(1,STATUS,1)
		ELSE
		    CALL OUTGRAF (LINE, SAMP)
		ENDIF
	    ENDDO
C	  Top
	    LINE = 1
	    DO SAMP = GS, 1, -1
	        IF((IMAGE(LINE,SAMP).LT.ZBTM).OR.
     +		     (IMAGE(LINE,SAMP).GT.ZTOP)) THEN
		   STATUS = PUTGR (1, 0.0, 0.0, 0.0)
                   IF (STATUS.NE.1) CALL SIGNALGR(1,STATUS,1)
		ELSE
		    CALL OUTGRAF (LINE, SAMP)
		ENDIF
	    ENDDO
	    STATUS =  PUTGR (1, 0.0, 0.0, 0.0)
            IF (STATUS.NE.1) CALL SIGNALGR(1,STATUS,1)
	ENDIF

C PUT THE CUBE AROUND THE DATA

	IF (MAKECUBE) THEN

	    IF (FIT) THEN
		ZBTM = ZMINIMG
		ZTOP = ZMAXIMG
	    ENDIF
	    X = FLOAT(GS) * XSCALE
	    Y = FLOAT(GL) * YSCALE
	    ZBTM = ZBTM * ZSCALE
	    Z = ZSCALE * IMAGE(1,1)
	    STATUS = PUTGR (1, YSCALE, XSCALE, Z)
            IF (STATUS.NE.1) CALL SIGNALGR(1,STATUS,1)
	    STATUS = PUTGR (1, YSCALE, XSCALE, ZBTM)
            IF (STATUS.NE.1) CALL SIGNALGR(1,STATUS,1)
   	    STATUS = PUTGR (1, YSCALE, X, ZBTM)
            IF (STATUS.NE.1) CALL SIGNALGR(1,STATUS,1)

	    Z = ZSCALE * IMAGE(GL,1)
	    STATUS = PUTGR (1, YSCALE, X, Z)
            IF (STATUS.NE.1) CALL SIGNALGR(1,STATUS,1)
	    STATUS = PUTGR (1, 0.0, 0.0, 0.0)
            IF (STATUS.NE.1) CALL SIGNALGR(1,STATUS,1)

	    STATUS = PUTGR (1, YSCALE, X, ZBTM)
	    IF (STATUS.NE.1) CALL SIGNALGR(1,STATUS,1)
            STATUS = PUTGR (1, Y, X, ZBTM)
            IF (STATUS.NE.1) CALL SIGNALGR(1,STATUS,1)
	    Z = ZSCALE * IMAGE(GL,GS)
	    STATUS = PUTGR (1, Y, X, Z)
            IF (STATUS.NE.1) CALL SIGNALGR(1,STATUS,1)
	    STATUS = PUTGR (1, 0.0, 0.0, 0.0)
            IF (STATUS.NE.1) CALL SIGNALGR(1,STATUS,1)

	    STATUS = PUTGR (1, Y, X, ZBTM)
            IF (STATUS.NE.1) CALL SIGNALGR(1,STATUS,1)
	    STATUS = PUTGR (1, Y, XSCALE, ZBTM)
            IF (STATUS.NE.1) CALL SIGNALGR(1,STATUS,1)
	    Z = ZSCALE * IMAGE(1,GS)
	    STATUS = PUTGR (1, Y, XSCALE, Z)
            IF (STATUS.NE.1) CALL SIGNALGR(1,STATUS,1)
	    STATUS = PUTGR (1, 0.0, 0.0, 0.0)
            IF (STATUS.NE.1) CALL SIGNALGR(1,STATUS,1)

	    STATUS =  PUTGR (1, Y, XSCALE, ZBTM)
            IF (STATUS.NE.1) CALL SIGNALGR(1,STATUS,1)
	    STATUS = PUTGR (1, YSCALE, XSCALE, ZBTM)
            IF (STATUS.NE.1) CALL SIGNALGR(1,STATUS,1)
	    STATUS = PUTGR (1, 0.0, 0.0, 0.0)
            IF (STATUS.NE.1) CALL SIGNALGR(1,STATUS,1)

	  IF (ZTOP.NE.0.0) THEN

	    Z = ZSCALE * IMAGE(1,1)
	    ZTOP = ZTOP * ZSCALE
	    STATUS = PUTGR (1, YSCALE, XSCALE, Z)
            IF (STATUS.NE.1) CALL SIGNALGR(1,STATUS,1)
	    STATUS = PUTGR (1, YSCALE, XSCALE, ZTOP)
            IF (STATUS.NE.1) CALL SIGNALGR(1,STATUS,1)
	    STATUS = PUTGR (1, YSCALE, X, ZTOP)
            IF (STATUS.NE.1) CALL SIGNALGR(1,STATUS,1)

	    Z = ZSCALE * IMAGE(GL,1)
	    STATUS = PUTGR (1, YSCALE, X, Z)
            IF (STATUS.NE.1) CALL SIGNALGR(1,STATUS,1)
	    STATUS = PUTGR (1, 0.0, 0.0, 0.0)
            IF (STATUS.NE.1) CALL SIGNALGR(1,STATUS,1)

	    STATUS =  PUTGR (1, YSCALE, X, ZTOP)
            IF (STATUS.NE.1) CALL SIGNALGR(1,STATUS,1)
	    STATUS = PUTGR (1, Y, X, ZTOP)
            IF (STATUS.NE.1) CALL SIGNALGR(1,STATUS,1)
	    Z = ZSCALE * IMAGE(GL,GS)
	    STATUS =  PUTGR (1, Y, X, Z)
            IF (STATUS.NE.1) CALL SIGNALGR(1,STATUS,1)
	    STATUS = PUTGR (1, 0.0, 0.0, 0.0)
            IF (STATUS.NE.1) CALL SIGNALGR(1,STATUS,1)

	    STATUS = PUTGR (1, Y, X, ZTOP)
            IF (STATUS.NE.1) CALL SIGNALGR(1,STATUS,1)
	    STATUS = PUTGR (1, Y, XSCALE, ZTOP)
            IF (STATUS.NE.1) CALL SIGNALGR(1,STATUS,1)
	    Z = ZSCALE * IMAGE(1,GS)
	    STATUS =  PUTGR (1, Y, XSCALE, Z)
            IF (STATUS.NE.1) CALL SIGNALGR(1,STATUS,1)
	    STATUS = PUTGR (1, 0.0, 0.0, 0.0)
            IF (STATUS.NE.1) CALL SIGNALGR(1,STATUS,1)

	    STATUS = PUTGR (1, Y, XSCALE, ZTOP)
            IF (STATUS.NE.1) CALL SIGNALGR(1,STATUS,1)
	    STATUS = PUTGR (1, YSCALE, XSCALE, ZTOP)
            IF (STATUS.NE.1) CALL SIGNALGR(1,STATUS,1)
	    STATUS = PUTGR (1, 0.0, 0.0, 0.0)
            IF (STATUS.NE.1) CALL SIGNALGR(1,STATUS,1)

	  ENDIF
	ENDIF

	STATUS = CLGR (1)
        IF (STATUS.NE.1) CALL SIGNALGR(1,STATUS,1)

	RETURN
	END

	SUBROUTINE OUTGRAF (LINE, SAMP)
	IMPLICIT NONE
	INTEGER	LINE, SAMP, PUTGR,status
	REAL	IMAGE(256,256)
	REAL	X, Y, Z, XSCALE, YSCALE, ZSCALE
	COMMON /OUTCOM/ XSCALE, YSCALE, ZSCALE, IMAGE

	X = XSCALE*FLOAT(SAMP)
	Y = YSCALE*FLOAT(LINE)
	Z = ZSCALE*IMAGE(SAMP,LINE)
        STATUS = PUTGR (1, Y, X, Z)
        IF (STATUS.NE.1) CALL SIGNALGR(1,STATUS,1)

	RETURN
	END


!--------------------------------------------------------------------------------
! Copyright (c) 2016 Peter Grünberg Institut, Forschungszentrum Jülich, Germany
! This file is part of FLEUR and available as free software under the conditions
! of the MIT license as expressed in the LICENSE file in more detail.
!--------------------------------------------------------------------------------

      MODULE m_visp5_0
      CONTAINS
      SUBROUTINE visp5_0(
     >             nmzxyd,nmzxy,delz,m,ivfft1,ivfft2,l,
     >             rxy,ani1,ani2,z1,amat,
     >             pvac,pint,tpi,jspd,val,
     <             vis_help)

      USE m_qsf
      USE m_angle
      IMPLICIT NONE

c---- this subroutine generates the gz=0 components of the
c---- \tilde\tilde{V} potential on the
c --- uniform grid in the unit cell \tilde{\Omega} for further 2-
c---- dimensional fast fourier transform
c---- for the further understanding look at the vvacxy_4.F
c----                           Y.Mokrousov

      INTEGER, INTENT (IN) :: nmzxyd,nmzxy,m,ivfft1,ivfft2,jspd,l
      REAL,    INTENT (IN) :: ani1,ani2,delz,z1,tpi
      COMPLEX, INTENT (IN) :: val
      REAL,    INTENT (IN) :: amat(3,3)
      COMPLEX, INTENT (IN) :: rxy(nmzxyd)
      COMPLEX, INTENT (IN) :: pvac(nmzxyd)
      COMPLEX, INTENT (IN) :: pint(nmzxyd)
      COMPLEX, INTENT (OUT)::
     &            vis_help(0:ivfft1-1,0:ivfft2-1)

      INTEGER imz,ix,iy,im,mult
      REAL    x,y,r,phi,zf,q

      mult = (-1)**(l+1)

      DO ix = 0,ivfft1 - 1
         DO iy = 0,ivfft2 - 1
             x = ix*ani1
             IF (x.GT.0.5) x = x - 1.
             y = iy*ani2
             IF (y.GT.0.5) y = y - 1.
             r = sqrt((x*amat(1,1) + y*amat(1,2))**2 +
     +                (x*amat(2,1) + y*amat(2,2))**2)
             phi = angle(x*amat(1,1) + y*amat(1,2),
     >                   x*amat(2,1) + y*amat(2,2))
            IF (r.GT.z1) THEN

               zf = (r-z1)/delz + 1.0
               im = zf
               q = zf - im
               vis_help(ix,iy) = (0.5* (q-1.)*
     *              (q-2.)*(pvac(im) + pint(im)) -
     +              q* (q-2.)*(pvac(im+1) +
     +              pint(im+1)) +
     +              0.5*q* (q-1.)*(pvac(im+2) +
     +              pint(im+2)))*
     *              exp(cmplx(0.,mult*m*phi))

            ELSE

               vis_help(ix,iy) = val*exp(cmplx(0.,mult*m*phi))*
     *                ((r**m)/(z1**m))

c------ here the contribution from the zero-fouirer component of
c------ the charge density is coming

            END IF
         END DO                 ! ix
      END DO                    ! iy

      END SUBROUTINE visp5_0
      END MODULE m_visp5_0


!-------------------------------------------------------------------------------
! Copyright (c) 2019 FrontISTR Commons
! This software is released under the MIT License, see LICENSE.txt
!-------------------------------------------------------------------------------
!> \brief  This module provides functions for creep calculation
module mCreep
  use hecmw_util
  use mMaterial
  use m_ElasticLinear

  implicit none

contains

  !> This subroutine calculates stiffness for elastically isotropic
  !>     materials with isotropic creep
  subroutine iso_creep(matl, sectType, stress, strain, extval,plstrain,            &
      dtime,ttime,stiffness, temp)
    type( tMaterial ), intent(in)    :: matl      !< material properties
    integer, intent(in)              :: sectType  !< not used currently
    real(kind=kreal), intent(in)     :: stress(6) !< Piola-Kirchhoff stress
    real(kind=kreal), intent(in)     :: strain(6) !< strain
    real(kind=kreal), intent(in)     :: extval(:) !< plastic strain
    real(kind=kreal), intent(in)     :: plstrain  !< plastic strain increment
    real(kind=kreal), intent(in)     :: ttime     !< total time at the start of the current increment
    real(kind=kreal), intent(in)     :: dtime     !< time length of the increment
    real(kind=kreal), intent(out)    :: stiffness(6,6) !< stiffness
    real(kind=kreal), optional       :: temp      !> temprature

    integer :: i, j
    logical :: ierr
    real(kind=kreal) :: ina(1), outa(3)
    real(kind=kreal) :: xxn, aa

    real(kind=kreal) :: c3,e,un,G,stri(6),p,dstri,c4,c5,f,df, eqvs

    aa = 0.0d0
    xxn = 0.0d0
    !
    !     elastic
    !
    call calElasticMatrix( matl, sectTYPE, stiffness )
    if( dtime==0.d0 .or. all(stress==0.d0) ) return
    !
    !     elastic constants
    !
    if( present(temp) ) then
      ina(1) = temp
      call fetch_TableData( MC_ISOELASTIC, matl%dict, outa(1:2), ierr, ina )
    else
      call fetch_TableData( MC_ISOELASTIC, matl%dict, outa(1:2), ierr )
    endif
    if( ierr ) then
      stop "error in isotropic elasticity definition"
    else
      e=outa(1)
      un=outa(2)
    endif

    !      Norton
    if( matl%mtype==NORTON ) then         ! those with no yield surface
      if( present( temp ) ) then
        ina(1) = temp
        call fetch_TableData( MC_NORTON, matl%dict, outa, ierr, ina )
      else
        call fetch_TableData( MC_NORTON, matl%dict, outa, ierr )
      endif
      xxn=outa(2)
      aa=outa(1)*((ttime+dtime)**(outa(3)+1.d0)-ttime**(outa(3)+1.d0))/(outa(3)+1.d0)
    endif

    G=0.5d0*e/(1.d0+un)
    !
    !     creep
    !
    stri(:)=stress(:)
    p=-(stri(1)+stri(2)+stri(3))/3.d0
    do i=1,3
      stri(i)=stri(i)+p
    enddo
    !
    dstri=dsqrt(1.5d0*(stri(1)*stri(1)+stri(2)*stri(2)+stri(3)*stri(3)+    &
      2.d0*(stri(4)*stri(4)+stri(5)*stri(5)+stri(6)*stri(6))) )
    !
    !     unit trial vector
    !
    stri(:)=stri(:)/dstri

    eqvs = dstri
    if( eqvs<1.d-10 ) eqvs=1.d-10
    f=aa*eqvs**xxn
    df=xxn*f/eqvs
    !
    !     stiffness matrix
    !
    c3=6.d0*G*G
    c4=c3*plstrain/(dstri+3.d0*G*plstrain)
    c3=c4-c3*df/(3.d0*G*df+1.d0)
    c5=c4/3.d0

    do i=1,6
      do j=1,6
        stiffness(i,j) = stiffness(i,j) +c3*stri(i)*stri(j)
      enddo
    enddo
    do i=1,3
      stiffness(i,i) = stiffness(i,i) - c4
      do j=1,3
        stiffness(i,j) = stiffness(i,j) +c5
      enddo
    enddo
    do i=4,6
      stiffness(i,i) = stiffness(i,i) - c4/2.d0
    enddo

  end subroutine

  !> This subroutine calculates stresses and creep status for an elastically isotropic
  !>     material with isotropic creep
  subroutine update_iso_creep(matl, sectType, strain, stress, extval,plstrain,                &
      dtime,ttime,temp)
    type( tMaterial ), intent(in)    :: matl      !< material properties
    integer, intent(in)              :: sectType  !< not used currently
    real(kind=kreal), intent(in)     :: strain(6) !< strain
    real(kind=kreal), intent(inout)  :: stress(6) !< Piola-Kirchhoff stress
    real(kind=kreal), intent(inout)  :: extval(:) !< plastic strain
    real(kind=kreal), intent(out)    :: plstrain  !< plastic strain increment
    real(kind=kreal), intent(in)     :: ttime     !< total time at the start of the current increment
    real(kind=kreal), intent(in)     :: dtime     !< time length of the increment
    real(kind=kreal), optional       :: temp      !> temprature

    integer :: i
    logical :: ierr
    real(kind=kreal) :: ina(1), outa(3)
    real(kind=kreal) :: xxn, aa

    real(kind=kreal) :: e,un,G,dg,ddg,stri(6),p,dstri,f,df, eqvs

    aa = 0.0d0
    xxn = 0.0d0

    if( dtime==0.d0 ) return
    !
    !     elastic constants
    !
    if( present(temp) ) then
      ina(1) = temp
      call fetch_TableData( MC_ISOELASTIC, matl%dict, outa(1:2), ierr, ina )
    else
      call fetch_TableData( MC_ISOELASTIC, matl%dict, outa(1:2), ierr )
    endif
    if( ierr ) then
      stop "error in isotropic elasticity definition"
    else
      e=outa(1)
      un=outa(2)
    endif

    !      Norton
    if( matl%mtype==NORTON ) then         ! those with no yield surface
      if( present( temp ) ) then
        ina(1) = temp
        call fetch_TableData( MC_NORTON, matl%dict, outa, ierr, ina )
      else
        call fetch_TableData( MC_NORTON, matl%dict, outa, ierr )
      endif
      if( ierr ) then
        stop "error in isotropic elasticity definition"
      else
        xxn=outa(2)
        aa=outa(1)*((ttime+dtime)**(outa(3)+1.d0)-ttime**(outa(3)+1.d0))/(outa(3)+1.d0)
      endif
    endif

    G=0.5d0*e/(1.d0+un)

    !
    !     creep
    !
    stri(:)=stress(:)
    p=-(stri(1)+stri(2)+stri(3))/3.d0
    do i=1,3
      stri(i)=stri(i)+p
    enddo
    !
    dstri=dsqrt(1.5d0*(stri(1)*stri(1)+stri(2)*stri(2)+stri(3)*stri(3)+    &
      2.d0*(stri(4)*stri(4)+stri(5)*stri(5)+stri(6)*stri(6))) )
    !
    !     determination of the consistency parameter
    !
    dg=0.d0
    do
      if( matl%mtype==NORTON ) then
        eqvs = dstri-3.d0*G*dg
        f=aa*eqvs**xxn
        df=xxn*f/eqvs
        ddg = (f-dg)/(3.d0*G*df+1.d0)
        dg = dg+ddg
        if((ddg<dg*1.d-6).or.(ddg<1.d-12)) exit
      endif
    enddo

    stri(:) = stri(:)-3.d0*G*dg*stri(:)/dstri
    stress(1:3) = stri(1:3)-p
    stress(4:6) = stri(4:6)

    !
    !     state variables
    !
    plstrain= dg
    extval(1)=eqvs

  end subroutine

  !> Update viscoplastic state
  subroutine updateViscoState( gauss )
    use mMechGauss
    type(tGaussStatus), intent(inout) :: gauss  ! status of curr gauss point

    gauss%fstatus(2) = gauss%fstatus(2)+gauss%plstrain
  end subroutine

end module


module eqsam_v03d

  implicit none

  public

contains

subroutine eqsam_v03d_sub(yi,yo,nca,nco,iopt,loop,imax,ipunit,in)
!
use cmn_precision, only: r8
use cmn_parameters, only: AVOGNR, R_ATM, R_UNIV, J2kcal
implicit none
!___________________________________________________________________________________________________________________________________
!      Written by Swen Metzger 3/11/99. Modified 2002, 2003.
!
!      Department of Atmospheric Chemistry, Max-Planck-Institute for Chemistry.
!      email: metzger@mpch-mainz.mpg.de
!      http://www.mpch-mainz.mpg.de/~metzger
!
!      COPYRIGHT 1999-2003
!
!      purpose
!      -------
!      EQSAM (EQuilibrium Simplified Aerosol Model) is a new and computationally efficient thermodynamic
!      aerosol composition model that allows to calculate the gas/aerosol equilibrium partitioning,
!      including aerosol water, sufficiently fast and accurate for global (or even regional) modeling.
!      EQSAM is based on a number of parameterizations, including single solute molalities and activity
!      coefficients (AC). The thermodynamic framework (domains and subdomains, internally mixed aerosols)
!      is the same as of more sophisticated thermodynamic equilibrium models (EQMs), e.g. of ISORROPIA
!      (Nenes et al., 1998). Details are given in the references below (and the references therein).
!
!      The main assumption on which EQSAM/EQMs are based is thermodynamical and chemical equilibrium.
!      From this assumption it directly follows that the aerosol water activity (aw) equals the ambient
!      relative humidity (RH), if the water vapor pressure is sufficiently larger than the partial vapor
!      pressure of the aerosol compounds. This is approximately true for tropospheric aerosols. Given the
!      large amount of water vapor present, water vapor and aerosol water equilibrate relatively faster
!      compared to all other aerosol compounds. This is subsequently also true for single aerosol compounds.
!      The water activity of single solutes must also equal RH under this assumption. Therefore, the so
!      called ZSR-relation is (and can be) used to calculate the aerosol associated water mass (simply
!      from the sum of all water mass fractions that are derived from measured single solute molalities).
!
!      In contrast to other EQMs, EQSAM utilizes the fact that the RH fixes the water activity
!      (under the above assumptions) and the consequence that any changes in RH also causes changes in
!      the aerosol water mass and, hence, aerosol activity (including activity coefficients). Thus, an decrease
!      (increase) in RH decrease (increases) the aerosol water mass (and water activity). This can change the
!      aerosol composition, e.g. due to condensation (evaporation/crystallization), because the vapor pressure
!      above the aerosol reduces (increases). In turn, a vapor pressure reduction (increase) due to changes
!      in the aerosol composition is compensated by an associated condensation (evaporation) of water vapor
!      to maintain the aerosol molality to remain constant (because aw=RH). Furthermore, the aerosol water
!      mainly depends on the aerosol mass and the type of solute, so that parameterizations of single solute
!      molalities and activity coefficients can be defined, only depending on the type of solute and RH.
!      The advantage of using such parameterizations is that the entire aerosol equilibrium composition
!      can be solved analytically, i.e. non-iteratively, which considerably reduces the amount of CPU time
!      that is usually need for aerosol thermodynamic calculations (especially if an EQM is incorporated in
!      an aerosol dynamical model that is in turn embedded in a high resolution regional or global model).
!
!      However, EQSAM should still be regarded as a starting point for further developments. There is still
!      room for improvements. For instance, this code is not yet numerically optimized (vectorized) and a
!      number of improvements with respect to an explicit treatment of additional equilibrium reactions,
!      missing (or only implicit) dissociation, and a basic parameterization of the water uptake.
!
!      Note that EQSAM was originally developed to calculate the gas/aerosol equilibrium partitioning of the
!      ammonium-sulfate-nitrate-water system for climate models, excluding solid compounds.
!      This version (eqsam_v03d.f90) is extended with respect to sea salt. Solids/hysteresis are treated in a
!      simplified manner. Results of a box model comparison with ISORROPIA will be available from the web page.
!      Please also note that the water uptake is based on additional (unpublished) parameterizations for single
!      solute molalities, which are derived from tabulated measurements used in ISORROPIA. Note further that
!      this extended version (eqsam_v03d.f90) is not yet published. A publication is in progress.
!
! ToDo:
!     Split ion-pairs into ions for water parameterizations (since info is actually available)
!     Include uptake/dissociation of NH3, HNO3, HCl (mainly to get pH right at near neutral conditions)
!     Extension to K+,Ca++,Mg++, CO2/(CO3)2--/HCO3-,SOA,etc.. (maybe not)
!     Vectorization. Translation of hardcoded formulas in array syntax.
!     I/O Interface and program structure clean up.
!     EQSAM info webpage.
!
! Version History:
!
!  eqsam_v03d.f90 (MPI-CH, June 2003):
!   - gama parameterizations now according to Metzger 2002 (JGR Appendix)
!   - improved pH calculations (still restricted to strong acids)
!   - removed bug that lead to too high nitrate formation at dry and cold regions (UT/LS)
!   - removed bug in solid/hysteresis calculations
!     (both bugs introduced in eqsam_v03b.f90 by cleaning up eqsam_v02a.f90)
!
!  eqsam_v03c.f90 (MPI-CH, April 2003):
!   - more accurate paramterizations of single solute molalities (Na, Cl species)
!   - cleanded up RHD subdomain structure
!   - improved water uptake (Na, Cl species)
!
!  eqsam_v03b.f90 (MPI-CH, March 2003):
!                 System extended to HCl,Cl-/Na+.
!                 Parameterization (fit) of additional HNO3 uptake removed.
!                 Instead, complete analytical solution of equilibrium reactions, based on the AC-RH relationship.
!  eqsam_v03.f90  (IMAU, October 1999):
!                 Test version (included in TM3).
!  eqsam_v02a.f90 (IMAU, April 2000):
!                 Box model version.
!  eqsam_v02.f90  (IMAU, October 1999):
!                 TM3 version.
!                 Version including solids and additional HNO3 uptake on acidic aerosols (parameterized).
!  eqsam_v01b.f90 (MPI-CH, January 2003):
!                 Same as eqsam_v01a.f90 (additional lines though uncommented for test purposes only).
!  eqsam_v01a.f90 (IMAU, April 2000):
!                 Box model version.
!  eqsam_v01.f90  (IMAU, October 1999):
!                 TM3 version.
!                 First and most basic version (without solids) for better vectorization (for global modeling).
!                 System: NH3,NH4+/H2SO4+,HSO4-,SO4--/HNO3,NO3-, H2O
!                 based on equilibrium / internal mixture assumption / aw=rh / ZSR-relation
!                 parameterization of activcity coefficients (AC), i.e. an AC-RH relationship
!
!
!      interface
!      ---------
!      call  eqsam_v03d(yi,yo,nca,nco,iopt,loop,imax,ipunit,in)
!
!      yi = input  array (imax, nca)
!      yo = output array (imax, nco)
!      imax = max loop (e.g. time steps)
!      nca >= 11
!      nc0 >= 35
!      iopt = 1 metastable
!      iopt = 2 solids
!      iopt = 3 hysteresis (metastable/solids) for online calculations
!      iopt = 31 hysteresis lower branch
!      iopt = 32 hysteresis upper branch
!      ipunit = I/O unit (can be skipped)
!      in = array        (can be skipped)
!
!      method
!      ------
!      equilibrium / internal mixture assumption / aw=rh
!      System: NH3,NH4+/H2SO4+,HSO4-,SO4--/HNO3,NO3-, HCl,Cl-/Na+, H2O
!              (K+,Ca++,Mg++)
!      external
!      --------
!      program    eqmd.f90    (driver only needed for the box model version)
!      subroutine gribio.f90  (provides diagnostics output in grib/binary/ascii format)
!
!      references
!      ---------
!      Swen Metzger Ph.D Thesis, University Utrecht, 2000.
!         http://www.library.uu.nl/digiarchief/dip/diss/1930853/inhoud.htm
!
!      Metzger, S. M., F. J. Dentener, J. Lelieveld, and S. N. Pandis,
!         GAS/AEROSOL PARTITIONING I: A COMPUTATIONALLY EFFICIENT MODEL,
!         J Geophys. Res., 107, D16, 10.1029/2001JD001102, 2002
!         http://www.agu.org/journals/jd/jd0216/2001JD001102/index.html
!      Metzger, S. M., F. J. Dentener, A. Jeuken, and M. Krol, J. Lelieveld,
!         GAS/AEROSOL PARTITIONING II: GLOBAL MODELING RESULTS,
!         J Geophys. Res., 107, D16, 10.1029/2001JD001103, 2002.
!         http://www.agu.org/journals/jd/jd0216/2001JD001103/index.html
!___________________________________________________________________________________________________________________________________
real(r8),parameter                        :: RH_HIST_DW=1.50_r8          ! mean value for mixture of wet (2) and dry (1) gridboxes (needed for HYSTERESIS)
real(r8),parameter                        :: T0=298.15_r8, T1=298.0_r8, &
                                             AVO=AVOGNR, &
                                             R=R_ATM,  &                ! in cu.m*atm/deg/mole (82.0567e-6_r8)
                                             r_kcal  = R_UNIV/J2kcal ! Ideal gas constant [1.986e-3_r8 kcal K-1.mole-1]
real(r8),parameter                        :: RHMAX=0.99_r8, RHMIN=0.0001_r8 ! restrict to max / min RH
real(r8),parameter                        :: MWNH4=18._r8, MWSO4=96._r8, MWNO3=62._r8, MWCl=35.5_r8 ! mole mass of species considered
real(r8),parameter                        :: MWNa=23._r8,MWCa=40.1_r8,MWN=14._r8, MWS=32.1_r8
real(r8),parameter                        :: MWH20=55.51_r8*18.01_r8, ZERO=0._r8
real(r8),parameter                        :: GF1=0.25_r8, GF2=0.50_r8, GF3=0.40_r8, GF4=1.00_r8, K=2._r8           ! exponents of AC-RH functions
!______________________________________________
integer,parameter                         :: NPAIR=10
!
integer                                   :: ii,il,IHYST
integer,intent(in)                        :: nca,nco,imax,loop,ipunit
integer,intent(inout)                     :: iopt
!______________________________________________
integer,dimension(6),intent(in)           :: in
!______________________________________________
real(r8)                                  :: T0T,TT,RH,PX,RHD,KAN,KAC,ZIONIC,RH_HIST,GAMA,GG,GF,GFN
real(r8)                                  :: X00,X01,X02,X03,X04,X05,X08,X09,X10,X11
real(r8)                                  :: X0,X1,X2,X3,X4,X5,X6,XK10,XK6
real(r8)                                  :: ZFLAG,ZKAN,ZKAC,PH,COEF,HPLUS,AKW,XKW,MOLAL
real(r8)                                  :: TNH4,TSO4,TNO3,TNa,TCl,TPo,TCa,TMg
real(r8)                                  :: PNH4,PSO4,PNO3,PCl,PNa,GNO3,GNH3,GSO4,GHCl
real(r8)                                  :: ASO4,ANO3,ANH4,ACl,ANa,SNH4,SSO4,SNO3,SCl,SNa
real(r8)                                  :: WH2O,PM,PMs,PMt,RINC,DON,RATIONS,GR,NO3P,NH4P
!_______________________________________________
real(r8),dimension(imax,nca),intent(in)   :: yi
real(r8),dimension(imax,nco),intent(out)  :: yo
real(r8),dimension(8)                     :: w1,w2
real(r8),dimension(8)                     :: RHDA,RHDE,RHDX,RHDZ    ! RHD / MRHD arrays for different aerosol types
real(r8),dimension(NPAIR)                 :: M0,MW,NW,ZW            ! arrays of ion pairs
!
! salt solutes:
!   1 = NACl,  2 = (NA)2SO4, 3 = NANO3,  4 = (NH4)2SO4,  5 = NH4NO3, 6 = NH4CL,   7 = 2H-SO4
!   8 = NH4HSO4,   9 = NAHSO4, 10 = (NH4)3H(SO4)2
!
! mole mass of the salt solute
DATA MW(1:NPAIR)/ 58.5_r8, 142._r8,  88._r8, 132._r8, 80._r8, 53.5_r8, 98._r8, 115._r8, 120._r8, 247._r8/
! square of max. dissocation number (not consistent)
DATA NW(1:NPAIR)/  2._r8,    2.5_r8,  2.5_r8,  2.5_r8, 3.5_r8, 1._r8,   4.5_r8,  2._r8,   2._r8,   2.5_r8/
! exponents of water activity functions/
DATA ZW(1:NPAIR)/  0.67_r8,  1._r8,   1._r8,   1._r8,  1._r8,  1._r8,   0.5_r8,  1._r8,   1._r8,   1._r8/
!
! RHD / MRHD values as of ISORROPIA / SCAPE (T=298.15K)
DATA RHDA(1:8)/0.32840_r8, 0.4906_r8, 0.6183_r8, 0.7997_r8, 0.67500_r8, 0.5000_r8, 0.4000_r8, 0.0000_r8/
! Temp. coeff.
DATA RHDE(1:8)/-1860.0_r8, -431.0_r8, 852.00_r8, 80.000_r8, 262.000_r8, 3951.0_r8, 384.00_r8, 0.0000_r8/
!___________________________________________________________________________________________________________________________________
IHYST=2
IF(IOPT.EQ.31) THEN      ! SOLID HYSTORY
   IHYST=1
   IOPT=3
ELSE IF(IOPT.EQ.32) THEN  ! WET   HISTORY
   IHYST=2
   IOPT=3
END IF

!write(ipunit,*)'eqsam_v03d ...'
!print*,'                                                          '
!print*,'              EQuilibrium Simplified Aerosol Model (EQSAM)'
!print*,'                        for global modeling               '
!print*,'                                 by                       '
!print*,'                         Swen Metzger, MPI-CH             '
!print*,'                         Copyright 1999-2003              '
!print*,'                    >> metzger@mpch-mainz.mpg.de <<       '
!print*,'                     last change:  04. June, 2003         '
!print*,'                           (version 3.0d)                 '
!print*,'                   gas/aerosol calculations assuming      '
!print*,'                  System: NH3,NH4+/H2SO4+,HSO4-,SO4--     '
!print*,'                      HNO3,NO3-, HCl,Cl-/Na+, H2O         '
!if(iopt.eq.1) then
!print*,'                         metastable aeorsols              '
!elseif(iopt.eq.2) then
!print*,'                            solid aeorsols                '
!elseif(iopt.eq.3) then
!print*,'                             hysteresis                   '
!print*,'                         (metastable/solids)              '
!if(IHYST.eq.1) then
!print*,'                            solid hystory                 '
!elseif(IHYST.eq.2) then
!print*,'                             wet hystory                  '
!endif
!endif
!print*,'                                                          '
!print*,'loop over ',loop,' data sets'
!print*,'   '
!___________________________________________________________________________________________________________________________________
! init/reset
yo=0._r8
w1=0._r8
w2=0._r8
!___________________________________________________________________________________________________________________________________
do il=1,loop

! get old relative humidity to calculate aerosol hysteresis (online only)

   RH_HIST = 2._r8                                                                                ! WET HISTORY (DEFAULT)
   IF(IHYST.EQ.1 .OR. IOPT.EQ.2)  RH_HIST = 1._r8                                                      ! SET TO SOLIDS

!  meteorology
   TT = yi(il,1)                    ! T                      [K]
   RH = yi(il,2)                    ! RH                     [0-1]
   PX = yi(il,11)                   ! p                      [hPa]
!
! gas+aerosol:
   w1(1) = yi(il,6)                 ! Na+ (ss  + xsod) (a)   [umol/m^3 air]
   w1(2) = yi(il,4)                 ! H2SO4    + SO4-- (p)   [umol/m^3 air]
   w1(3) = yi(il,3)                 ! NH3  (g) + NH4+  (p)   [umol/m^3 air]
   w1(4) = yi(il,5)                 ! HNO3 (g) + NO3-  (p)   [umol/m^3 air]
   w1(5) = yi(il,7)                 ! HCl  (g) + Cl-   (p)   [umol/m^3 air]
   w1(6) = yi(il, 8)                ! K+   (p) from Dust     [umol/m^3 air]
   w1(7) = yi(il, 9)                ! Ca++ (p) from Dust     [umol/m^3 air]
   w1(8) = yi(il,10)                ! Mg++ (p) from Dust     [umol/m^3 air]
!______________________________________________

   zflag=1._r8

   w1=w1*1.0e-6_r8                     ! [mol/m^3 air]

   TNa   = w1(1)                    ! total input sodium   (g+p)
   TSO4  = w1(2)                    ! total input sulfate  (g+p)
   TNH4  = w1(3)                    ! total input ammonium (g+p)
   TNO3  = w1(4)                    ! total input nitrate  (g+p)
   TCl   = w1(5)                    ! total input chloride (g+p)
   TPo   = w1(6)                    ! total input potasium (g+p)
   TCa   = w1(7)                    ! total input calcium  (g+p)
   TMg   = w1(8)                    ! total input magnesium(g+p)

! SULFATE RICH

      if((w1(1)+w1(3)+w1(6)+2._r8*(w1(7)+w1(8))).le.(2._r8*w1(2))) then
          zflag=3._r8
      end if

! SULFATE VERY RICH CASE if (NH4+Na+K+2(Ca+Mg))/SO4 < 1

      if((w1(1)+w1(3)+w1(6)+2._r8*(w1(7)+w1(8))).le.w1(2)) then
          zflag=4._r8
      end if

! SULFATE NEUTRAL CASE

      if((w1(1)+w1(3)+w1(6)+2._r8*(w1(7)+w1(8))).gt.(2._r8*w1(2))) then
          zflag=2._r8
      end if

! SULFATE POOR AND CATION POOR CASE

      if((w1(1)+w1(6)+2._r8*(w1(7)+w1(8))).gt.(2._r8*w1(2))) then
          zflag=1._r8
      end if

      IF ( RH .LT. RHMIN ) RH=RHMIN
      IF ( RH .GT. RHMAX ) RH=RHMAX

! CALCULATE TEMPERATURE DEPENDENCY FOR SOME RHDs

      RHDX(:)=RHDA(:)*exp(RHDE(:)*(1._r8/TT-1._r8/T0))
      RHDZ(:)=RHDX(:)

! ACCOUNT FOR VARIOUS AMMOMIUM/SODIUM SULFATE SALTS ACCORDING TO MEAN VALUE AS OF ISORROPIA

      GG=2._r8                         ! (Na)2SO4 / (NH4)2SO4 IS THE PREFFERED SPECIES FOR SULFATE DEFICIENT CASES
      IF(ZFLAG.EQ.3._r8) THEN
         IF(RH.LE.RHDZ(7)) THEN       ! ACCOUNT FOR MIXTURE OF (NH4)2SO4(s) & NH4HSO4(s) & (NH4)3H(SO4)2(s)
            GG=1.677_r8                !                        (Na)2SO4 &  NaHSO4
!           GG=1.5
         ELSE IF(RH.GT.RHDZ(7).AND.RH.LE.RHDZ(5)) THEN ! MAINLY (Na)2SO4 / (NH4)2SO4(s) & (NH4)3H(SO4)2(s)
            GG=1.75_r8
!           GG=1.5
         ELSE IF(RH.GE.RHDZ(5)) THEN   ! (NH4)2SO4(S) & NH4HSO4(S) & SO4-- & HSO4-
            GG=1.5_r8                  !  (Na)2SO4 &  NaHSO4
         END IF
      END IF
      IF(ZFLAG.EQ.4._r8) GG=1._r8       ! IF SO4 NEUTRALIZED, THEN ONLY AS NaHSO4 / NH4HSO4(S) OR  HSO4- / H2SO4

      RHD=RH
      IF(IOPT.EQ.2.OR.RH_HIST.LT.RH_HIST_DW) THEN   ! GET RHD FOR SOLIDS / HYSTERESIS
!
! GET LOWEST DELIQUESCENCE RELATIVE HUMIDITIES ACCORDING TO THE CONCENTRATION DOMAIN (APROXIMATION)
! BASED ON RHD / MRHD ISORROPIA/SCAPE
!
      w2(:)=1._r8
      do ii=1,8
         if(w1(ii).le.1.e-12_r8) w2(ii)=0._r8  ! skip compound in RHD calculation if value is concentration is zero or rather small
      end do

! GET LOWEST RHD ACCORDING TO THE CONCENTRATION DOMAIN

! zflag=1. (cation rich)  ...
! 1. sea salt      aerosol          : RHDX(1)=MgCl2
! 2. mineral dust  aerosol          : RHDX(2)=Ca(NO3)2
!
! zflag=2. (sulfate neutral) ...
! 3. ammonium + nitrate             : RHDX(3)= NH4NO3
! 4. ammonium + sulfate             : RHDX(4)=(NH4)2SO4
! 5. ammonium + sulfate mixed salt  : RHDX(5)=(NH4)3H(SO4)2, (NH4)2SO4
! 6. ammonium + nitrate  + sulfate  : RHDX(6)=(NH4)2SO4, NH4NO3, NA2SO4, NH4CL
!
! zflag=3. (sulfate poor) ...
! 7. ammonium + sulfate  (1:1,1.5)  : RHDX(7)= NH4HSO4
!
! zflag=4. (sulfate very poor) ...
! 8. sulfuric acid                  : RHDX(8)= H2SO4

   IF(ZFLAG.EQ.1._r8)THEN

      RHD=W2(1)+W2(5)                     ! Na+  dependency
      IF(RHD.EQ.0._r8)  RHDX(1)=1._r8
      RHD=W2(6)+W2(7)+W2(8)               ! K+/Ca++/Mg++ dependency (incl. ss)
      IF(RHD.EQ.0._r8)  RHDX(2)=1._r8

      RHD=MINVAL(RHDX(1:2))

   ELSE IF(ZFLAG.EQ.2._r8)THEN

      RHD=W2(3)*W2(4)                     ! NH4+ & NO3-  dependency
      IF(RHD.EQ.0._r8)  RHDX(3)=1._r8
      RHD=W2(2)+W2(3)                     ! NH4+ & SO4-- dependency
      IF(GG.NE.2._r8)   RHD=0.               ! account only for pure (NH4)2SO4
      IF(RHD.EQ.0._r8)  RHDX(4)=1._r8
      RHD=W2(2)+W2(3)                     ! NH4+ & SO4-- dependency
      IF(RHD.EQ.0._r8)  RHDX(5)=1._r8
      RHD=W2(2)+W2(3)+W2(4)+W2(5)         ! (NH4)2SO4, NH4NO3, NA2SO4, NH4CL dependency
      IF(RHD.EQ.0._r8)  RHDX(6)=1._r8

!     RHD=MINVAL(RHDX(3:4))
      RHD=MINVAL(RHDX(3:6))

   ELSE IF(ZFLAG.EQ.3._r8)THEN

      RHD=W2(2)+W2(3)                     ! NH4+ & SO4-- dependency
      IF(RHD.EQ.0._r8)  RHDX(7)=1._r8
      RHD=RHDX(7)

   ELSE IF(ZFLAG.EQ.4._r8)THEN

      RHD=W2(2)                           ! H2SO4 dependency (assume no dry aerosol)
      IF(RHD.EQ.0._r8)  RHDX(8)=1._r8

      RHD=RHDX(8)

   END IF ! ZFLAG
   END IF ! SOLIDS

! GET WATER ACTIVITIES ACCORDING TO METZGER, 2000.
! FUNCTION DERIVED FROM ZSR RELATIONSHIP DATA (AS USED IN ISORROPIA)

      M0(:) = ((NW(:)*MWH20/MW(:)*(1._r8/RH-1._r8)))**ZW(:)

! CALCULATE TEMPERATURE DEPENDENT EQUILIBRIUM CONSTANTS

      T0T=T0/TT
      COEF=1._r8+LOG(T0T)-T0T

! EQUILIBRIUM CONSTANT NH4NO3(s) <==> NH3(g) + HNO3(g) [atm^2] (ISORROPIA)

!Changed 20111116, RBS:      XK10 = 5.746e-17
      XK10 = 3.000e-17_r8
      XK10= XK10 * EXP(-74.38_r8*(T0T - 1._r8) + 6.120_r8*COEF)
      KAN = XK10 / (R*TT) / (R*TT)

! EQUILIBRIUM CONSTANT  NH4CL(s) <==> NH3(g) + HCL(g) [atm^2] (ISORROPIA)

      XK6  = 1.086e-16_r8
      XK6 = XK6 * EXP(-71.00_r8*(T0T - 1._r8) + 2.400_r8*COEF)
      KAC = XK6 / (R*TT) / (R*TT)

!
! CALCULATE AUTODISSOCIATION CONSTANT (KW) FOR WATER H2O <==> H(aq) + OH(aq) [mol^2/kg^2] (ISORROPIA)

      XKW  = 1.010e-14_r8
      XKW = XKW *EXP(-22.52_r8*(T0T - 1._r8) + 26.920_r8*COEF)

! GET MEAN MOLAL IONIC ACTIVITY COEFF ACCORDING TO METZGER, 2002.

      GAMA=0._r8
      IF(RH.GE.RHD) GAMA=(RH**ZFLAG/(1000._r8/ZFLAG*(1._r8-RH)+ZFLAG))
      GAMA = GAMA**GF1            ! ONLY GAMA TYPE OF NH4NO3, NaCl, etc. NEEDED SO FAR

      GAMA=0._r8
      GFN=K*K                      ! K=2, i.e. condensation of 2 water molecules per 1 mole ion pair
      GF=GFN*GF1                   ! = GFN[=Nw=4] * GF1[=(1*1^1+1*1^1)/2/Nw=1/4] = 1
                                   ! ONLY GAMA TYPE OF NH4NO3, NH4Cl, etc. needed so far

      IF(RH.GE.RHD) GAMA=RH**GF/((GFN*MWH20*(1._r8/RH-1._r8)))**GF1

      GAMA = min(GAMA,1._r8)        ! FOCUS ON 0-1 SCALE
      GAMA = max(GAMA,0._r8)
      GAMA = (1._r8-GAMA)**K        ! transplate into aqueous phase equillibrium and account for
                                   ! enhanced uptake of aerosol precursor gases with increasing RH
                                   ! (to match the results of ISORROPIA)

! CALCULATE RHD DEPENDENT EQ: IF RH <  RHD => NH4NO3(s) <==> NH3 (g) + HNO3(g) (ISORROPIA)
!                             IF RH >> RHD => HNO3  (g)   -> NO3 (aq)

      X00  = MAX(ZERO,MIN(TNa,GG*TSO4))       ! MAX SODIUM   SULFATE
      X0   = MAX(ZERO,MIN(TNH4,GG*TSO4-X00))  ! MAX AMMOMIUM SULFATE
      X01  = MAX(ZERO,MIN(TNa-X00, TNO3))     ! MAX SODIUM   NITRATE
      X1   = MAX(ZERO,MIN(TNH4-X0,TNO3-X01))  ! MAX AMMOMIUM NITRATE
!
      X02  = MAX(ZERO,MIN(TNa-X01-X00,TCl))   ! MAX SODIUM   CHLORIDE
      X03  = MAX(ZERO,MIN(TNH4-X0-X1,TCl-X02))! MAX AMMOMIUM CHLORIDE

      X2   = MAX(TNH4-X1-X0-X03,ZERO)         ! INTERIM RESIDUAL NH3
      X3   = MAX(TNO3-X1-X01,ZERO)            ! INTERIM RESIDUAL HNO3
      X04  = MAX(TSO4-(X0+X00)/GG,ZERO)       ! INTERIM RESIDUAL H2SO4
      X05  = MAX(TCl-X03-X02,ZERO)            ! INTERIM RESIDUAL HCl
!     X06  = MAX(TNa-X02-X01-X00,ZERO)        ! INTERIM RESIDUAL Na (should be zero for electro-neutrality in input data)
!
      ZKAN=2._r8
      IF(RH.GE.RHD) ZKAN=ZKAN*GAMA

      X4   = X2 + X3
      X5   = SQRT(X4*X4+KAN*ZKAN*ZKAN)
      X6   = 0.5_r8*(-X4+X5)
      X6   = MIN(X1,X6)

      GHCl = X05                              ! INTERIM RESIDUAl HCl
      GNH3 = X2 + X6                          ! INTERIM RESIDUAl NH3
      GNO3 = X3 + X6                          ! RESIDUAl HNO3
      GSO4 = X04                              ! RESIDUAl H2SO4
      PNa  = X02 + X01 + X00                  ! RESIDUAl Na (neutralized)

      ZKAC=2._r8
      IF(RH.GE.RHD) ZKAC=ZKAC*GAMA

      X08   = GNH3 + GHCl
      X09   = SQRT(X08*X08+KAC*ZKAC*ZKAC)
      X10   = 0.5_r8*(-X08+X09)
      X11   = MIN(X03,X10)

      GHCl = GHCl + X11                       ! RESIDUAL HCl
      GNH3 = GNH3 + X11                       ! RESIDUAL NH3

! GO SAVE ...

      IF(GHCl.LT.0._r8)   GHCl=0._r8
      IF(GSO4.LT.0._r8)   GSO4=0._r8
      IF(GNH3.LT.0._r8)   GNH3=0._r8
      IF(GNO3.LT.0._r8)   GNO3=0._r8
      IF(PNa.LT.0._r8)    PNa=0._r8
      IF(GSO4.GT.TSO4) GSO4=TSO4
      IF(GNH3.GT.TNH4) GNH3=TNH4
      IF(GNO3.GT.TNO3) GNO3=TNO3
      IF(GHCl.GT.TCl)  GHCl=TCl
      IF(PNa.GT.TNa)   PNa=TNa
!     IF(PNa.LT.TNa)   print*,il,' PNa.LT.TNa => no electro-neutrality in input data! ',PNa,TNa

! DEFINE AQUEOUSE PHASE (NO SOLID NH4NO3 IF NO3/SO4>1, TEN BRINK, ET AL., 1996, ATMOS ENV, 24, 4251-4261)

!     IF(TSO4.EQ.ZERO.AND.TNO3.GT.ZERO.OR.TNO3/TSO4.GE.1.) RHD=RH

!     IF(IOPT.EQ.2.AND.RH.LT.RHD.OR.IOPT.EQ.2.AND.RH_HIST.LT.RH_HIST_DW) THEN        ! SOLIDS / HYSTERESIS
      IF(RH_HIST.EQ.1._r8.AND.RH.LT.RHD) THEN        ! SOLIDS / HYSTERESIS

       ! EVERYTHING DRY, ONLY H2SO4 (GSO4) REMAINS IN THE AQUEOUSE PHASE

         ANH4 = 0._r8
         ASO4 = 0._r8
         ANO3 = 0._r8
         ACl  = 0._r8
         ANa  = 0._r8

      ELSE  !  SUPERSATURATED SOLUTIONS NO SOLID FORMATION

         ASO4 = TSO4 - GSO4
         ANH4 = TNH4 - GNH3
         ANO3 = TNO3 - GNO3
         ACl  = TCl  - GHCl
         ANa  = PNa

      END IF ! SOLIDS / HYSTERESIS

! CALCULATE AEROSOL WATER [kg/m^3(air)]
!
! salt solutes:
!   1 = NACl,  2 = (NA)2SO4, 3 = NANO3,  4 = (NH4)2SO4,  5 = NH4NO3, 6 = NH4CL,   7 = 2H-SO4
!   8 = NH4HSO4,   9 = NAHSO4, 10 = (NH4)3H(SO4)2
!
      IF(ZFLAG.EQ.1._r8) WH2O = ASO4/M0( 2) + ANO3/M0(3) + ACl/M0(6)  !sulfate poor
      IF(ZFLAG.EQ.2._r8) WH2O = ASO4/M0( 9) + ANO3/M0(5) + ACl/M0(6)  !sulfate neutral
      IF(ZFLAG.EQ.3._r8) WH2O = ASO4/M0( 8) + ANO3/M0(5) + ACl/M0(6)  !sulfate rich
      IF(ZFLAG.EQ.4._r8) WH2O = ASO4/M0( 8) + GSO4/M0(7)              !sulfate very rich

! CALCULATE AQUEOUS PHASE PROPERTIES

!     PH    = 9999.
      PH    = 7._r8
      MOLAL = 0._r8
      HPLUS = 0._r8
      ZIONIC= 0._r8

      IF(WH2O.GT.0._r8) THEN

         ! CALCULATE AUTODISSOCIATION CONSTANT (KW) FOR WATER

         AKW=XKW*RH*WH2O*WH2O                         ! H2O <==> H+ + OH- with kw [mol^2/kg^2]
         AKW=AKW**0.5_r8                               ! [OH-] = [H+] [mol]

         ! Calculate hydrogen molality [mol/kg], i.e. H+ of the ions:
         !                                   Na+, NH4+, NO3-, Cl-, SO4--, HH-SO4- [mol/kg(water)]
         !                                   with [OH-] = kw/[H+]

         HPLUS = (-ANa/WH2O-ANH4/WH2O+ANO3/WH2O+ACl/WH2O+GG*ASO4/WH2O+GG*GSO4/WH2O+ &
            SQRT(( ANa/WH2O+ANH4/WH2O-ANO3/WH2O-ACl/WH2O-GG*ASO4/WH2O-GG*GSO4/WH2O)**2+XKW/AKW*WH2O))/2._r8

         ! Calculate pH

         !PH=-ALOG10(HPLUS)                             ! aerosol pH
         !++alfgr changed to
         PH=-1._r8*log10(HPLUS)

         ! Calculate ionic strength [mol/kg]

         ZIONIC=0.5_r8*(ANa+ANH4+ANO3+ACl+ASO4*GG*GG+GSO4*GG*GG+XKW/AKW*WH2O*WH2O)
         ZIONIC=ZIONIC/WH2O                                           ! ionic strength [mol/kg]
!        ZIONIC=min(ZIONIC,200.0)                                     ! limit for output
!        ZIONIC=max(ZIONIC,0.0)

      END IF ! AQUEOUS PHASE
!
!-------------------------------------------------------
! calculate diagnostic output consistent with other EQMs ...
!
      ASO4 = ASO4 + GSO4                                     ! assuming H2SO4 remains aqueous

      TNa   = TNa  * 1.e6_r8                                    ! total input sodium   (g+p)  [umol/m^3]
      TSO4  = TSO4 * 1.e6_r8                                    ! total input sulfate  (g+p)  [umol/m^3]
      TNH4  = TNH4 * 1.e6_r8                                    ! total input ammonium (g+p)  [umol/m^3]
      TNO3  = TNO3 * 1.e6_r8                                    ! total input nitrate  (g+p)  [umol/m^3]
      TCl   = TCl  * 1.e6_r8                                    ! total input chloride (g+p)  [umol/m^3]
      TPo   = TPo  * 1.e6_r8                                    ! total input potasium (g+p)  [umol/m^3]
      TCa   = TCa  * 1.e6_r8                                    ! total input calcium  (g+p)  [umol/m^3]
      TMg   = TMg  * 1.e6_r8                                    ! total input magnesium(g+p)  [umol/m^3]
!
! residual gas:
      GNH3 = GNH3 * 1.e6_r8                                     ! residual NH3
      GSO4 = GSO4 * 1.e6_r8                                     ! residual H2SO4
      GNO3 = GNO3 * 1.e6_r8                                     ! residual HNO3
      GHCl = GHCl * 1.e6_r8                                     ! residual HCl

! total particulate matter (neutralized)
      PNH4=TNH4-GNH3                                         ! particulate ammonium   [umol/m^3]
      PNO3=TNO3-GNO3                                         ! particulate nitrate    [umol/m^3]
      PCl =TCl -GHCl                                         ! particulate chloride   [umol/m^3]
      PNa =TNa                                               ! particulate sodium     [umol/m^3]
      PSO4=TSO4                                              ! particulate sulfate    [umol/m^3]

! liquid matter
      ASO4 = ASO4 * 1.e6_r8                                     ! aqueous phase sulfate  [umol/m^3]
      ANH4 = ANH4 * 1.e6_r8                                     ! aqueous phase ammonium [umol/m^3]
      ANO3 = ANO3 * 1.e6_r8                                     ! aqueous phase nitrate  [umol/m^3]
      ACl  = ACl  * 1.e6_r8                                     ! aqueous phase chloride [umol/m^3]
      ANa  = ANa  * 1.e6_r8                                     ! aqueous phase sodium   [umol/m^3]

! solid matter
      SNH4=PNH4-ANH4                                         ! solid phase ammonium   [umol/m^3]
      SSO4=PSO4-ASO4                                         ! solid phase sulfate    [umol/m^3]
      SNO3=PNO3-ANO3                                         ! solid phase nitrate    [umol/m^3]
      SCl =PCl -ACl                                          ! solid phase chloride   [umol/m^3]
      SNa =PNa -ANa                                          ! solid phase sodium     [umol/m^3]

! GO SAVE ...

      IF(SNH4.LT.0._r8)   SNH4=0._r8
      IF(SSO4.LT.0._r8)   SSO4=0._r8
      IF(SNO3.LT.0._r8)   SNO3=0._r8
      IF(SCl.LT.0._r8)    SCl=0._r8
      IF(SNa.LT.0._r8)    SNa=0._r8

      PM=SNH4+SSO4+SNO3+SNH4+SCl+SNa+ANH4+ASO4+ANO3+ACl+ANa  ! total PM [umol/m^3]
      PMs=SNH4*MWNH4+SSO4*MWSO4+SNO3*MWNO3+SCl*MWCl+SNa*MWNa ! dry particulate matter (PM)     [ug/m^3]
      PMt=PMs+ANH4*MWNH4+ASO4*MWSO4+ANO3*MWNO3+ACl*MWCl+  &
          ANa*MWNa                                           ! total (dry + wet) PM, excl. H20 [ug/m^3]

      WH2O = WH2O * 1.e9_r8                                     ! convert aerosol water from [kg/m^3] to [ug/m^3]
      IF(WH2O.LT.1.e-3_r8) WH2O=0._r8

! UPDATE HISTORY RH FOR HYSTERESIS (ONLINE CALCULATIONS ONLY)

      RH_HIST=2._r8                                           ! wet
      IF(WH2O.EQ.0.) RH_HIST=1._r8                            ! dry

      RINC = 1._r8
      IF(PMt.GT.0._r8)   RINC = (WH2O/PMt + 1._r8)**(1._r8/3._r8)  ! approx. radius increase due to water uptake
      IF(RINC.EQ.0._r8)  RINC = 1._r8

      RATIONS = 0._r8
      IF(PSO4.GT.0._r8) RATIONS = PNO3/PSO4                   ! nitrate / sulfate mol ratio

      GR = 0._r8
      IF(GNO3.GT.0._r8) GR = GNH3/GNO3                        ! gas ratio = residual NH3 / residual HNO3   [-]

      DON = 0._r8
      IF((PNO3+2._r8*PSO4).GT.0._r8) DON = 100._r8*PNH4/(PNO3+2._r8*PSO4)! degree of neutralization by ammonia : ammonium / total nitrate + sulfate  [%]

      NO3P = 0._r8
      IF(TNO3.GT.0._r8) NO3P = 100._r8*PNO3/TNO3               ! nitrate  partitioning = nitrate  / total nitrate    [%]

      NH4P = 0._r8
      IF(TNH4.GT.0._r8) NH4P = 100._r8*PNH4/TNH4               ! ammonium partitioning = ammonium / total ammonium   [%]
!
! store aerosol species for diagnostic output:
!______________________________________________________________
! Input values:
      yo(il, 1) = TT   - 273.15_r8                                     ! T                                    [degC]
      yo(il, 2) = RH   * 100.00_r8                                     ! RH                                      [%]
      yo(il, 3) = TNH4                                                ! total input ammonium (g+p)       [umol/m^3]
      yo(il, 4) = TSO4                                                ! total input sulfate  (g+p)       [umol/m^3]
      yo(il, 5) = TNO3                                                ! total input nitrate  (g+p)       [umol/m^3]
      yo(il, 6) = TNa                                                 ! total input sodium   (p)         [umol/m^3]
      yo(il,33) = TCl                                                 ! total input chloride (g+p)       [umol/m^3]
      yo(il, 7) = TPo                                                 ! total input potasium (p)         [umol/m^3]
      yo(il,34) = TCa                                                 ! total input calcium  (p)         [umol/m^3]
      yo(il,35) = TMg                                                 ! total input magnesium(p)         [umol/m^3]
      yo(il,25) = PX                                                  ! atmospheric pressure                  [hPa]
! Output values:
      yo(il, 8) = GHCL                                                ! residual HCl   (g)               [umol/m^3]
      yo(il, 9) = GNO3                                                ! residual HNO3  (g)               [umol/m^3]
      yo(il,10) = GNH3                                                ! residual NH3   (g)               [umol/m^3]
      yo(il,11) = GSO4                                                ! residual H2SO4 (aq)              [umol/m^3]
      yo(il,12) = WH2O                                                ! aerosol Water  (aq)                [ug/m^3]
      yo(il,13) = PH                                                  ! aerosol pH                            [log]
      yo(il,14) = ZFLAG                                               ! concnetration domain [1=SP,2=SN,3=SR,4=SVR]
      yo(il,15) = PM                                                  ! total particulate matter         [umol/m^3]
      yo(il,16) = SNH4                                                ! solid ammonium (s)               [umol/m^3]
      yo(il,17) = SNO3                                                ! solid nitrate  (s)               [umol/m^3]
      yo(il,18) = SSO4                                                ! solid sulfate  (s)               [umol/m^3]
      yo(il,19) = PNH4                                                ! particulate ammonium (p=a+s)     [umol/m^3]
      yo(il,20) = PNO3                                                ! particulate nitrate  (p=a+s)     [umol/m^3]
      yo(il,21) = PSO4                                                ! particulate sulfate  (p=a+s)     [umol/m^3]
      yo(il,22) = RATIONS                                             ! mol ratio Nitrate/Sulfate (p)           [-]
      yo(il,23) = GAMA                                                ! activity coefficient (e.g. NH4NO3)           [-]
      yo(il,24) = ZIONIC                                              ! ionic strength (aq)                [mol/kg]
      yo(il,26) = PMt                                                 ! total PM (liquids & solids)        [ug/m^3]
      yo(il,27) = PMs                                                 ! total PM (solid)                   [ug/m^3]
      yo(il,28) = RINC                                                ! radius increase (H2O/PMt+1)**(1/3)      [-]
      yo(il,29) = SCl                                                 ! solid chloride (s)               [umol/m^3]
      yo(il,30) = SNa                                                 ! solid sodium (s)                 [umol/m^3]
      yo(il,31) = PCl                                                 ! particulate chloride (p=a+s)     [umol/m^3]
      yo(il,32) = PNa                                                 ! particulate sodium (p=a+s)       [umol/m^3]
end do
!

end subroutine eqsam_v03d_sub

end module eqsam_v03d


￼
!\end{comment}
!\begin{sourcecode}
subroutine fg_bump(     p,      & ! modelled data
                        eps,     & ! thresholding parameter for computing absolute value
                        p0,     & ! observed data
                        q0,     & !
                        q0freq, & ! ga ussian filter in the frequency doimain
                        J,      & ! misfit
                        gp,     & ! gradient of J w.r.t. p
                        n1pow2, & ! # length after zero padding
                        n2pow2, & ! # length after zero padding
                        n1,     & ! # lengths before zero padding
                        n2,     & !
                        n3,     & !
                        ) !\end{sourcecode}
!\begin{comment}
implicit none
real, intent(in)                        :: p(n1*n2*n3), eps,  p0(n1*n2*n3)
real, intent(in)                        :: q0freq(n1pow2*n2pow2), q0(n1*n2*n3)
real, intent(out)                       :: gp(n1*n2*n3)
integer, intent(in)                     :: n1, n2, n3, n1pow2, n2pow2
real      , intent(out)                 :: J
integer, intent(in)                     :: i3save
real, intent(inout)                     :: saved(n1*n2*n3*5)

integer                                 :: i2, i3, ap1, ap2, i1, aphat1, aphat2
real                                    :: Jtemp

complex, allocatable                    :: pbump(:,:), p0bump(:,:), dJdpbump(:,:)
complex, allocatable                    :: temp2dcomplex(:,:)
real, allocatable                       :: temp1D(:)

! gradient w.r.t p
gp = rzero_de

! functional output to zero
J = rzero_de

! allocate temporary arrays in f-k domain
allocate(p0bump(n1pow2, n2pow2), pbump(n1pow2, n2pow2))

! other temp
allocate(temp1D(n1))

! other temp for gradient
allocate(dJdpbump(n1pow2, n2pow2))

! loop over sources (can be parallized)
do i3 = 1, n3
        ! initialize f-k domain
        p0bump = cmplx(rzero_de, rzero_de)
        pbump = cmplx(rzero_de, rzero_de)

        ! zero padding p and p0
        do i2 = 1, n2
                ap1 = 1 + (i2-1) * n1 + (i3-1) * n1 * n2;
                ap2 =   (i2) * n1 + (i3-1) * n1 * n2 ;

                ! absolute value of the observed and modeled data
                ! after applying weighting q0
                temp1D = q0(ap1:ap2) * sqrt((p0(ap1:ap2))**2 + eps);

                ! zero padding and truncating function
                call nlag_npow2_pad_truncate(x = temp1D, &
                         xpow2_complex = p0bump(:,i2), nplags = n1-1, nnlags = 0,&
                        npow2 = n1pow2, flag = 1)

                temp1D = q0(ap1:ap2) * sqrt(( p(ap1:ap2))**2 + eps);
                call nlag_npow2_pad_truncate(x = temp1D, &
                                 xpow2_complex = pbump(:,i2), &
                                nplags = n1-1, nnlags=0, npow2 = n1pow2, flag = 1)
        enddo

        ! cfft2 forward
        call cfft2_fftw(p0bump, n1pow2, n2pow2, 1)
        call cfft2_fftw(pbump, n1pow2, n2pow2, 1)

        ! functional -- q0freq helps to choose low frequencies
        Jtemp = rzero_de;
        ! multiplication with q0 will apply blurring
        do i2 = 1, n2pow2
                do i1 = 1, n1pow2
                        Jtemp = Jtemp + real(q0freq(i1 + (i2-1)*n1pow2)) * &
                                real((abs(pbump(i1, i2) - p0bump(i1, i2)))**(2.0e0))
                enddo
        enddo
        J = J + Jtemp

        forall(i2=1:n2pow2,i1=1:n1pow2)
                        dJdpbump(i1,i2) = &
                        cmplx(2.0e0, rzero_de) * cmplx(q0freq(i1 + (i2-1)*n1pow2), rzero_de) * &
                        (pbump(i1,i2) - p0bump(i1,i2))
        endforall

        ! inverse cffts
        call cfft2_fftw(dJdpbump, n1pow2, n2pow2, -1)

        ! scaling
        dJdpbump = dJdpbump / cmplx(real(n1pow2),0.0) / cmplx(real(n2pow2),0.0)

        do i2 = 1, n2
                ap1 = 1 + (i2-1) * n1 + (i3-1) * n1 * n2;
                ap2 =   (i2) * n1 + (i3-1) * n1 * n2 ;
                call nlag_npow2_pad_truncate(x = gp(ap1:ap2), &
                         xpow2_complex = dJdpbump(:,i2), nplags = n1-1, &
                        nnlags=0, npow2 = n1pow2, flag = -1)

                do i1 = ap1, ap2
                        gp(i1) =  gp(i1) * p(i1) * q0(i1) * (sqrt((p(i1))**2 + eps))**(-1.e0)
                enddo
        enddo

enddo
if(allocated(temp1D)) deallocate(temp1D)
deallocate(pbump, p0bump)
if(allocated(dJdpbump)) deallocate(dJdpbump)

end subroutine fg_bump


      subroutine nucdev (av,dr,dv,dz,hx,nuc,np,ndor,dr1)
c        * construction of nuclear potential *
c av coefficients of the development at the origin of nuclear potential
c dr  tabulation points
c dv  nuclear potential
c dz  nuclear charge
c hx  exponential step
c nuc index of the nuclear radius
c np  number of tabulation points
c ndor number of the coefficients for development at the origin
c the declared below arguments are saved, dr1 is the first

      implicit double precision (a-h,o-z)
      dimension av(10),dr(251),dv(251),at(251)

c    specify atomic mass and thickness of nuclear shell
c a atomic mass (negative or null for the point charge)
c epai parameter of the fermi density distribution
c (negative or null for uniform distribution), which is
c       cte / (1. + exp((r-rn)/epai) )
c with nuclear radius rn= 2.2677e-05 * (a**(1/3))

c calculate radial mesh
      a = 0.0
      epai = 0.0

      if (a.le.1.0d-01) then
         nuc=1
      else
         a=dz*(a**(1./3.))*2.2677d-05
         b=a/ exp(hx*(nuc-1))
         if (b.le.dr1) then
            dr1=b
         else
            b=log(a/dr1)/hx
            nuc=3+2*int(b/2.0)
            if (nuc.ge.np) call par_stop('dr1 too small')
c           index of atomic radius larger than dimension of dr
            dr1=a*exp(-(nuc-1)*hx)
         endif
      endif

      dr(1)=dr1/dz
      do l=2,np
         dr(l)=dr(1)* exp(hx*(l-1))
      enddo
      if (ndor.lt.5) then
c       * it should be at least 5 development coefficients
         call par_stop
     .     ('stopped in programm nucdev, ndor should be > 4.')
c        stop
      endif
c  calculate nuclear potential on calculated radial mesh
      do i=1,ndor
         av(i)=0.0d00
      enddo
      if (epai.le.0.0) then
         do i=1,np
            dv(i)=-dz/dr(i)
         enddo
         if (nuc.le.1) then
            av(1)=-dz
         else
            av(2)=-3.0d 00*dz/(dr(nuc)+dr(nuc))
            av(4)=-av(2)/(3.0d 00*dr(nuc)*dr(nuc))
            l=nuc-1
            do i=1,l
               dv(i)=av(2)+av(4)*dr(i)*dr(i)
            enddo
         endif
      else
         b= exp(-dr(nuc)/epai)
         b=1.0d 00/(1.0d 00+b)
         av(4)=b
         av(5)=epai*b*(b-1.0d 00)
         if (ndor.gt.5) then
            at(1)=1.0d 00
            at(2)=1.0d 00
            nf=1
            do i=6,ndor
               n=i-4
               nf=n*nf
               dv(1)=n*at(1)
               n1=n+1
               dv(n1)=1.0d 00
               do j=2,n
                  dv(j)=(n-j+2)*at(j-1)+(n-j+1)*at(j)
               enddo
               do j=1,n1
                  m=n+1-j
                  l=1
                  if (mod(j,2).eq.0) l=-l
                  av(i)=av(i)+l*dv(j)*(b**m)
                  at(j)=dv(j)
               enddo
               av(i)=b*av(i)*(epai**n)/nf
            enddo
         endif
         do i=1,np
            b=1.0d 00+ exp((dr(i)-dr(nuc))/epai)
            if ((b*av(4)).gt.1.0d+15) go to 51
            dv(i)=dr(i)*dr(i)*dr(i)/b
            l=i
         enddo
 51      continue
         if (l.ge.(np-1)) l=np-2
         k=l+1
         do i=k,np
            dv(i)=0.0d 00
         enddo
         at(1)=0.0d 00
         at(2)=0.0d 00
         k=2
         do i=4,ndor
            k=k+1
            do j=1,2
               at(j)=at(j)+av(i)*(dr(j)**k)/k
            enddo
            av(i)=av(i)/(k*(k-1))
            av(2)=av(2)+av(i)*(dr(1)**k)
         enddo
         a=hx/2.4d+01
         b=a*1.3d+01
         k=l+1
         do i=3,k
            at(i)=at(i-1)+b*(dv(i-1)+dv(i))-a*(dv(i-2)+dv(i+1))
         enddo
         dv(l)=at(l)
         do i=k,np
            dv(i)=dv(l)
         enddo
         e= exp(hx)
         c=1.0d 00/(e*e)
         i=l-1
 83      continue
         dv(i)=dv(i+1)/e+b*(at(i+1)/e+at(i))-a*(at(i+2)*c+at(i-1)*e)
         i=i-1
         if (i .gt. 1) go to 83
         dv(1)=dv(3)*c+hx*(at(1)+4.0d 00*at(2)/e+at(3)*c)/3.0d 00
         av(2)=(av(2)+dv(1))/dr(1)
         a=-dz/dv(l)
         do i=4,ndor
            av(i)=-a*av(i)
         enddo
         av(2)=a*av(2)
         do i=1,np
            dv(i)=a*dv(i)/dr(i)
         enddo
      endif

      return
      end


      subroutine block_b(x,p1,p2,p3,r1,r2)
ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
c     This block corresponds to the reduced diagram
c
c              *P3    * P2
c            *       *
c     ***************
c     MV_r2  MV_r1   *
c                     * |P1| (missing)
c
c     Pz1,PT1 are fixed to reproduce MV_r1 and MV_r2; phi_1 is generated randomly
c
c
c
ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
      implicit none
      include '../../../SubProcesses/phasespace.inc'
c
c     argument
c
      integer p1,p2,p3,r1,r2,n_var,config, local_var
c
c     local
c
      INTEGER IDUM
      DATA IDUM/0/
      SAVE IDUM
      double precision b,c,rho,jac_factor,dem
      double precision pt1_ti,pt1_E1,pz1_ti,pz1_E1,PT1
      double precision  phi_miss,jac_temp,invjac
      real rand
      double precision pz2,pz3,pt2,pt3,E2,E3,cphi13,cphi12
      double precision Ma(2),Mc(2),MinvB(2,2),detB
      double precision sol(2),PT1sol(2),jac_loc
      double precision x(20)
      integer nu,index_sol
c
c     global
c
      double precision momenta(0:3,-max_branches:2*max_particles)  ! records the momenta of external/intermediate legs     (MG order)
      double precision mvir2(-max_branches:2*max_particles)        ! records the sq invariant masses of intermediate particles (MG order)
      common /to_diagram_kin/ momenta, mvir2
      double precision Etot,pztot,misspx,misspy
      common /to_missingP/Etot,pztot,misspx,misspy
      double precision              S,X1,X2,PSWGT,JAC
      common /PHASESPACE/ S,X1,X2,PSWGT,JAC
c
c     external
c
      double precision pt, phi,dot
      external pt,phi,dot
      REAL XRAN1
      EXTERNAL XRAN1
c---
c Begin code
c---
c
c     First generate  phi of the missing particle
c
      jac_loc = 1d0
      call generate_variable(x,2,p1, phi_miss, jac_loc)
c      write(*,*) 'phi, x,nvar',phi_miss,x(n_var),n_var
c
      cphi13=dcos(phi_miss-phi(momenta(0,p3)))
      cphi12=dcos(phi_miss-phi(momenta(0,p2)))
      pz2=momenta(3,p2)
      pz3=momenta(3,p3)
      pt2=pt(momenta(0,p2))
      pt3=pt(momenta(0,p3))
      E2=momenta(0,p2)
      E3=momenta(0,p3)

c     Express the change of variables as
c       | a1 | = | b11 b12 | | P1T | + | C1 | E1
c       | a2 |   | b21 b22 | | P1Z |   | C2 |
c
      Ma(1)=mvir2(r1)-mvir2(p1)-mvir2(p2)
      Ma(2)=mvir2(r2)-mvir2(r1)-mvir2(p3)-
     & 2d0*dot(momenta(0,p2),momenta(0,p3))
c
      detB=-4d0*cphi13*pz2*pt3+4d0*cphi12*pz3*pt2
c
      MinvB(1,1)=-2d0*pz3/detB
      MinvB(1,2)=2d0*pz2/detB
      MinvB(2,1)=2d0*cphi13*pt3/detB
      MinvB(2,2)=-2d0*cphi12*pt2/detB
c
      Mc(1)=2d0*momenta(0,p2)
      Mc(2)=2d0*momenta(0,p3)
c
      PT1_ti=MinvB(1,1)*Ma(1)+MinvB(1,2)*Ma(2)
      Pz1_ti=MinvB(2,1)*Ma(1)+MinvB(2,2)*Ma(2)
      PT1_E1=-MinvB(1,1)*Mc(1)-MinvB(1,2)*Mc(2)
      Pz1_E1=-MinvB(2,1)*Mc(1)-MinvB(2,2)*Mc(2)
c
c     solve the mass shell equation
c
c     E1^2-|P1|^2=m_1^2   <=>   E1^2-b*E1+c=0
c
      jac_factor=1d0
      dem=1d0-PT1_E1**2-Pz1_E1**2

      if (dabs(dem).lt.0.0001d0) then
        momenta(0,p1)=-(Pz1_ti**2+PT1_ti**2+mvir2(p1))/
     &  (2d0*PT1_ti*PT1_E1+2d0*Pz1_ti*Pz1_E1)
        PT1=PT1_ti+PT1_E1*momenta(0,p1)
        if  (momenta(0,p1).le.0d0.or.PT1.le.0d0) then
          jac=-1d0
          return
        endif
      else
        b=-(2d0*PT1_ti*PT1_E1+2d0*Pz1_ti*Pz1_E1)/dem
        c=-(Pz1_ti**2+PT1_ti**2+mvir2(p1))/dem
        rho=b**2-4d0*c

        if (rho.eq.0d0.and.b.lt.0d0) then   ! max 1 sol
          momenta(0,p1)=-b/2d0
          PT1=PT1_ti+PT1_E1*momenta(0,p1)
          if (PT1.le.0d0) then
            jac=-1d0
            momenta(0,p1)=-1d0
            return
          endif
        elseif (rho.gt.b**2)then ! max 1 sol
          momenta(0,p1)=(-b+dsqrt(rho))/2d0
          PT1=PT1_ti+PT1_E1*momenta(0,p1)
          if (PT1.le.0d0) then
            jac=-1d0
            momenta(0,p1)=-1d0
            return
          endif
        elseif (rho.gt.0d0.and.dsqrt(rho).lt.(-b)) then   ! max 2 sol
          sol(1)=(-b+dsqrt(rho))/2d0
          sol(2)=(-b-dsqrt(rho))/2d0
          PT1sol(1)=PT1_ti+PT1_E1*sol(1)
          PT1sol(2)=PT1_ti+PT1_E1*sol(2)
          if (PT1sol(1).gt.0d0.and.PT1sol(2).gt.0d0) then
            index_sol=1
c            call ntuple(rand,0.0,1.0,p1)
             rand=xran1(IDUM)
            if (rand.gt.0.5) index_sol=2
            momenta(0,p1)=sol(index_sol)
            PT1=PT1sol(index_sol)
            jac_factor=2d0
          elseif (PT1sol(1).gt.0d0.and.PT1sol(2).le.0d0) then
            momenta(0,p1)=sol(1)
            PT1=PT1sol(1)
          elseif (PT1sol(2).gt.0d0.and.PT1sol(1).le.0d0) then
            momenta(0,p1)=sol(2)
            PT1=PT1sol(2)
          else
            jac=-1d0
            momenta(0,p1)=-1d0
            return
          endif
        else                                ! 0 sol
          momenta(0,p1)=-1d0
          jac=-1d0
          return
        endif
      endif
c
c     fill the momentum p1
c
      momenta(1,p1)=PT1*dcos(phi_miss)
      momenta(2,p1)=PT1*dsin(phi_miss)
      momenta(3,p1)=pz1_ti+pz1_E1*momenta(0,p1)
c
c     fill momenta r1,r2
c
      do nu=0,3
        momenta(nu,r1)=momenta(nu,p1)+momenta(nu,p2)
        momenta(nu,r2)=momenta(nu,r1)+momenta(nu,p3)
      enddo
c
c     compute missing momentum
c
       misspx=misspx-momenta(1,p1)
       misspy=misspy-momenta(2,p1)
       Etot=Etot+momenta(0,p1)
       pztot=pztot+momenta(3,p1)
c
c     compute the jacobian:
c
      jac_loc=jac_loc*PT1       ! PS weight for the initial set of variable
c
      invjac=-8d0*cphi12*E3*pt2*momenta(3,p1)
     & +8d0*cphi13*E2*pt3*momenta(3,p1)
     & +8d0*E3*pt1*pz2 - 8d0*cphi13*momenta(0,p1)*pt3*pz2
     & -8d0*E2*pt1*pz3 + 8d0*cphi12*momenta(0,p1)*pt2*pz3
         !  the factor 2*E1 has been removed since it factorizes with the factor 1/2E1 in the PS weight

      jac_loc=jac_loc*jac_factor/dabs(invjac)
      jac=jac*jac_loc

      return
      end


*
*     ----------------------------------------------------------------
*        T R E D 2
*     ----------------------------------------------------------------
*
*
      SUBROUTINE TRED2(NM,N,A,D,E,Z)
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
      DIMENSION A(NM,N),D(N),E(N),Z(NM,N)
      DO 100 I = 1, N
         DO 100 J = 1, I
            Z(I,J) = A(I,J)
  100 CONTINUE
      IF (N .EQ. 1) GO TO 320
      DO 300 II = 2, N
         I = N + 2 - II
         L = I - 1
         H = 0.0
         SCALE = 0.0
         IF (L .LT. 2) GO TO 130
         DO 120 K = 1, L
  120    SCALE = SCALE + ABS(Z(I,K))
         IF (SCALE .NE. 0.0) GO TO 140
  130    E(I) = Z(I,L)
         GO TO 290
  140    DO 150 K = 1, L
            Z(I,K) = Z(I,K) / SCALE
            H = H + Z(I,K) * Z(I,K)
  150    CONTINUE
         F = Z(I,L)
         G = -SIGN(SQRT(H),F)
         E(I) = SCALE * G
         H = H - F * G
         Z(I,L) = F - G
         F = 0.0
         DO 240 J = 1, L
            Z(J,I) = Z(I,J) / (SCALE * H)
            G = 0.0
            DO 180 K = 1, J
  180       G = G + Z(J,K) * Z(I,K)
            JP1 = J + 1
            IF (L .LT. JP1) GO TO 220
            DO 200 K = JP1, L
  200       G = G + Z(K,J) * Z(I,K)
  220       E(J) = G / H
            F = F + E(J) * Z(I,J)
  240    CONTINUE
         HH = F / (H + H)
         DO 260 J = 1, L
            F = Z(I,J)
            G = E(J) - HH * F
            E(J) = G
            DO 260 K = 1, J
               Z(J,K) = Z(J,K) - F * E(K) - G * Z(I,K)
  260    CONTINUE
         DO 280 K = 1, L
  280    Z(I,K) = SCALE * Z(I,K)
  290    D(I) = H
  300 CONTINUE
  320 D(1) = 0.0
      E(1) = 0.0
      DO 500 I = 1, N
         L = I - 1
         IF (D(I) .EQ. 0.0) GO TO 380
         DO 360 J = 1, L
            G = 0.0
            DO 340 K = 1, L
  340       G = G + Z(I,K) * Z(K,J)
            DO 360 K = 1, L
               Z(K,J) = Z(K,J) - G * Z(K,I)
  360    CONTINUE
  380    D(I) = Z(I,I)
         Z(I,I) = 1.0
         IF (L .LT. 1) GO TO 500
         DO 400 J = 1, L
            Z(I,J) = 0.0
            Z(J,I) = 0.0
  400    CONTINUE
  500 CONTINUE
      RETURN
      END