      SUBROUTINE STERN (JJA,NST,STG,TAUP)
!
!     STERN GENERATES THE STAR OF REC LATTICE VECTOR KZZ(1,JJA)
!     THE STAR VECTORS ARE STORED IN STG, THE STAR-SIZE IN  NST
!     IZ CONTAINS THE SYMMETRY-MATRICES
!
!
      USE param
      IMPLICIT REAL*8 (A-H,O-Z)
!
!
      COMPLEX*16          TAUP,IMAG
      INTEGER          G,STG,INDEX(48)
      COMMON /SYMETR/  TAU(3,48),KZZ(3,10000),IZ(3,3,48),             &
                       INUM(48),IORD
!
      DIMENSION        STG(3,48),TAUP(48),G(3)
      DATA IMAG        /(0.D0,1.D0)/
!-------------------------------------------------------------------
!
      TPI=2.D0*ACOS(-1.D0)
      G(1)=KZZ(1,JJA)
      G(2)=KZZ(2,JJA)
      G(3)=KZZ(3,JJA)
      NST=0
!
!.....START LOOP OVER ALL SYMMETRY OPERATIONS
      DO 1 I=1,IORD
         TK=0.
         DO 2 J=1,3
         TK=TK+TAU(J,I)*G(J)*TPI
           K=0
           DO 3 L=1,3
           K=IZ(J,L,I)*G(L)+K
3     continue
           STG(J,I)=K
 2      continue
         IF(NST.EQ.0) GOTO 7
!
!........PROOF, IF THE VECTOR STG(J,I) IS A NEW STARMEMBER OR NOT
         DO 4 M=1,NST
            DO 5 J=1,3
               IF(STG(J,M).NE.STG(J,I)) GOTO 4
   5        CONTINUE
!           STG(J,I) IS NOT A NEW STARMEMBER, IT IS EQUIV TO STG(J,M).
!           BUT THE TAUPHASE OF STG(J,I) CAN BE NEW.  THEREFORE THE
!           ALREADY DEFINED PHASE TAUP(M) IS AVERAGED WITH THE PHASE
!           OF STG(J,M)
            TAUP(M)=TAUP(M)+EXP(TK*IMAG)
            INDEX(M)=INDEX(M)+1
            GOTO 1
   4     CONTINUE
!
!........NEW VECTOR FOUND ]]]
   7     NST=NST+1
         DO 6 J=1,3
   6     STG(J,NST)=STG(J,I)
         TAUP(NST)=EXP(TK*IMAG)
         INDEX(NST)=1
   1  CONTINUE
!
      DO 10 I=1,NST
      TAUP(I)=TAUP(I)/INDEX(I)
  10  continue
      RETURN
      END


*###[ ffxdpv:
	subroutine ffxdpv(cd0,cd1,cd2,cd3,cd4,xpi,degree,ier)
***#[*comment:***********************************************************
*									*
*	Compute the scalar and tensor functions D0-D(degree) in the	*
*	Passarino-Veltman scheme, i.e. with basis p1-p3 and d_(mu,nu)).	*
*									*
*	Input:	xpi(13)	(real)		1-4: mi^2, 5-10: p(i-4)^2	*
*					11-13: either 0 or u,v,w	*
*		degree	(integer)	0-4				*
*									*
*	Output:	ier			number of digits lost in the	*
*					least stable result		*
*		cd0	(complex)	D0				*
*	   only when degree>0:						*
*		cd1(3)	(complex)	coeffs of p1,p2,p3		*
*	   only when degree>1:						*
*		cd2(7)	(complex)	..				*
*	   only when degree>2:						*
*		cd3(13)	(complex)	...				*
*	   only when degree>3:						*
*		cd4(22)	(complex)	...				*
*									*
*	Note: at this moment (28-feb-1993) only D1 and D2 are coded.	*
*	I am undecided as yet about whether to include the Ci.		*
*									*
***#]*comment:***********************************************************
*  #[ declarations:
	implicit none
*
*	arguments
*
	integer degree,ier
	DOUBLE PRECISION xpi(13)
	DOUBLE COMPLEX cd0,cd1(3),cd2(7),cd3(13),cd4(22)
*
*	local variables
*
	integer i,j,k,ier0,ier1,inx43(6,4),sgn43(6,4),isgnsa,idotsa
	DOUBLE PRECISION del2pi(4),d0,xmu,absc
	DOUBLE PRECISION h,del3sp(4),del2ij,xpi3(6),dl2pij(6,6)
	DOUBLE COMPLEX cd4pppp(3,3,3,3),cd4ppdel(3,3),cd4deldel,
     +		cd3ppp(3,3,3),cd3pdel(3),cd2pp(3,3),cd2del,
     +		cc0i(4),cb0ij(4,4),ca0i(4),cc
	save inx43,sgn43
*
*	common blocks
*
	include 'ff.h'
*
*	data
*
	data inx43 /2,3,4,6,7,10,
     +		   1,3,4,9,7,8,
     +		   1,2,4,5,10,8,
     +		   1,2,3,5,6,9/
     	data sgn43 /+1,+1,+1,+1,+1,-1,
     + 		    +1,+1,+1,-1,+1,+1,
     + 		    +1,+1,+1,+1,+1,+1,
     + 		    +1,+1,+1,+1,+1,+1/
*
*	statement function
*
	absc(cc) = abs(DBLE(cc)) + abs(DIMAG(cc))
*
*  #] declarations:
*  #[ write input:
	if ( lwrite ) then
	    print *,'ffxdpv: input:'
	    print *,'xpi  = ',xpi
	    print *,'degree ',degree
	endif
*  #] write input:
*  #[ get scalar functions and determinants:
*
	ldot = .TRUE.
	isgnsa = isgnal
*
*	the D0
*
	ier0 = ier
	call ffxd0(cd0,xpi,ier0)
	isgnal = isgnsa
	ier1 = ier0
*
*	the C0s
*
	do 40 i=1,4
	    do 30 j=1,6
		xpi3(j) = xpi(inx43(j,i))
*		distribute dotproducts
		do 25 k=1,6
		    fpij3(k,j) = fpij4(inx43(k,i),inx43(j,i))*
     +		    	sgn43(k,i)*sgn43(j,i)
   25		continue
   30	    continue
	    ier0 = ier
	    idotsa = idot
	    idot = max(idot,3)
	    call ffxc0(cc0i(i),xpi3,ier0)
	    idot = idotsa
	    isgnal = isgnsa
	    ier1 = max(ier1,ier0)
	    del2pi(i) = fdel2
   40	continue
*
*	the B0s
*
	if ( degree .lt. 2 ) goto 80
	do 60 i=1,3
	    do 50 j=i+1,4
		ier0 = ier
		call ffxb0(cb0ij(i,j),x0,x0,xpi(inx(i,j)),xpi(i),
     +			xpi(j),ier0)
		cb0ij(j,i) = cb0ij(i,j)
		ier1 = max(ier1,ier0)
   50	    continue
   60	continue
*
*	the A0s
*
	if ( degree .lt. 3 ) goto 80
	do 70 i=1,4
	    ier0 = ier
	    call ffxa0(ca0i(i),x0,x0,xpi(i),ier0)
	    ier1 = max(ier1,ier0)
   70	continue
   80	continue
	ier = ier1
*
*  #] get scalar functions and determinants:
*  #[ call ffxdi:
	call ffxdi(cd4pppp,cd4ppdel,cd4deldel, cd3ppp,cd3pdel,
     +		cd2pp,cd2del, cd1, dl2pij, cd0,cc0i,cb0ij,ca0i, fdel4s,
     +		fdel3, del2pi, xpi,fpij4, x0,x0, degree, ier)
*  #] call ffxdi:
*  #[ convert to PV conventions:
*
	ier1 = ier
	cd2(1) = cd2pp(1,1) - DBLE(del2pi(1))*cd2del
	if ( lwarn .and. absc(cd2(1)).lt.xloss*absc(cd2pp(1,1)) ) then
	    call ffwarn(229,ier1,absc(cd2(1)),absc(cd2pp(1,1)))
	endif
	cd2(2) = cd2pp(1,2) + DBLE(dl2pij(2,4))*cd2del
	if ( lwarn .and. absc(cd2(2)).lt.xloss*absc(cd2pp(1,2)) ) then
	    ier0 = ier
	    call ffwarn(229,ier0,absc(cd2(2)),absc(cd2pp(1,2)))
	    ier1 = max(ier1,ier0)
	endif
	cd2(3) = cd2pp(1,3) - DBLE(dl2pij(1,4))*cd2del
	if ( lwarn .and. absc(cd2(3)).lt.xloss*absc(cd2pp(1,3)) ) then
	    ier0 = ier
	    call ffwarn(229,ier0,absc(cd2(3)),absc(cd2pp(1,3)))
	    ier1 = max(ier1,ier0)
	endif
	cd2(4) = cd2pp(2,2) - DBLE(xpi(5)*xpi(7)-fpij4(5,7)**2)*cd2del
	if ( lwarn .and. absc(cd2(4)).lt.xloss*absc(cd2pp(2,2)) ) then
	    ier0 = ier
	    call ffwarn(229,ier0,absc(cd2(4)),absc(cd2pp(2,2)))
	    ier1 = max(ier1,ier0)
	endif
	cd2(5) = cd2pp(2,3) + DBLE(dl2pij(1,2))*cd2del
	if ( lwarn .and. absc(cd2(5)).lt.xloss*absc(cd2pp(2,3)) ) then
	    ier0 = ier
	    call ffwarn(229,ier0,absc(cd2(5)),absc(cd2pp(2,3)))
	    ier1 = max(ier1,ier0)
	endif
	cd2(6) = cd2pp(3,3) - DBLE(del2pi(4))*cd2del
	if ( lwarn .and. absc(cd2(6)).lt.xloss*absc(cd2pp(3,3)) ) then
	    ier0 = ier
	    call ffwarn(229,ier0,absc(cd2(6)),absc(cd2pp(3,3)))
	    ier1 = max(ier1,ier0)
	endif
	cd2(7) = DBLE(fdel3)*cd2del
*
*  #] convert to PV conventions:
*  #[ print output:
	if ( lwrite ) then
	    print *,'PV D1 = '
	    print '(6e20.13)',cd1
	    if ( degree .lt. 2 ) return
	    print *,'PV D2 = '
	    print '(6e20.13)',cd2
	endif
*  #] print output:
*###] ffxdpv:
	end
*###[ ffxdpd:
	subroutine ffxdpd(cd0,cd1,cd2,cd3,cd4,xpi,piDpj,del3p,del4s,
     +		info,degree,ier)
***#[*comment:***********************************************************
*									*
*	Compute the scalar and tensor functions D0-D(degree) in the	*
*	Passarino-Veltman scheme, i.e. with basis p1-p3 and d_(mu,nu)).	*
*									*
*	Input:	xpi(13)	     real	1-4: mi^2, 5-10: p(i-4)^2	*
*					11-13: either 0 or u,v,w	*
*		piDpj(10,10) real	dotproducts pi.pj		*
*		del3	     real	det(pi.pj)			*
*		info	     integer	0: piDpj, del3 invalid		*
*					1: piDpj(6:10,6:10) defined	*
*					2: del3p also			*
*					3: rest of piDpj (internal) also*
*					4: del4s = det(si.sj) also	*
*		degree	     integer	0-4: which tensor functions 	*
*									*
*	Output:	see ffxdpv
*									*
***#]*comment:***********************************************************
*  #[ declarations:
	implicit none
*
*	arguments
*
	integer info,degree,ier
	DOUBLE PRECISION xpi(13),piDpj(10,10),del3p,del4s
	DOUBLE COMPLEX cd0,cd1(3),cd2(7),cd3(13),cd4(22)
*
*	local vars
*
	integer i,j
*
*	common
*
	include 'ff.h'
*
*  #] declarations:
*  #[ hide information in common blocks:
*
	idot = info
	if ( idot.ne.0 ) then
	    if ( idot.le.2 ) then
		do 20 i=5,10
		    do 10 j=5,10
			fpij4(j,i) = piDpj(j,i)
   10		    continue
   20		continue
	    elseif ( idot.ge.3 ) then
		do 40 i=1,10
		    do 30 j=1,10
			fpij4(j,i) = piDpj(j,i)
   30		    continue
   40		continue
	    endif
	    if ( abs(idot).ge.2 ) then
		fdel3 = del3p
	    endif
	    if ( abs(idot).ge.4 ) then
		fdel4s = del4s
	    endif
	endif
*
*  #] hide information in common blocks:
*  #[ call ffxdpv:
*
	call ffxdpv(cd0,cd1,cd2,cd3,cd4,xpi,degree,ier)
	idot = 0
*
*  #] call ffxdpv:
*###] ffxdpd:
	end


      SUBROUTINE GTPERP(PTDQ,P,I,J,K,C,D)
      IMPLICIT NONE
      include 'constants.f'
C---Find the vectors perpendicular to P(I) and P(J)
C   C AND D are purely space-like vectors in the P(I)+P(J) CMF,
C   with C in the same plane as P(K) and D perpendicular to it,
C   both having length PTDQ*SQRT(2*DOT(P,I,J))

      DOUBLE PRECISION PTDQ,P(mxpart,4),C(4),D(4),PTF,DIJ,DIK,DJK,DOT
      DOUBLE PRECISION QI(4),QJ(4),EPS4
      INTEGER I,J,K,L
      DIJ=DOT(P,I,J)
      DIK=DOT(P,I,K)
      DJK=DOT(P,J,K)
      PTF=PTDQ/SQRT(DIK*DJK)
      DO L=1,4
        C(L)=PTF*(DIJ*P(K,L)-DJK*P(I,L)-DIK*P(J,L))
        QI(L)=P(I,L)
        QJ(L)=P(J,L)
      ENDDO
      DO L=1,4
        D(L)=EPS4(L,QI,QJ,C)/DIJ
      ENDDO
      END

C-----------------------------------------------------------------------
      DOUBLE PRECISION FUNCTION EPS4(I,A,B,C)
      IMPLICIT NONE
      DOUBLE PRECISION EPS3,A(4),B(4),C(4),AA(3),BB(3),CC(3)
      INTEGER::I,J,K
      INTEGER,PARAMETER::S(4)=(/+1,-1,+1,+1/)
      J=1
      DO K=1,3
        IF (I.EQ.J) J=J+1
        AA(K)=A(J)
        BB(K)=B(J)
        CC(K)=C(J)
        J=J+1
      ENDDO
      EPS4=0d0
      DO J=1,3
        EPS4=EPS4+CC(J)*EPS3(J,AA,BB)
      ENDDO
      EPS4=S(I)*EPS4
      END
C-----------------------------------------------------------------------
      DOUBLE PRECISION FUNCTION EPS3(I,A,B)
      IMPLICIT NONE
      DOUBLE PRECISION A(3),B(3),AA(2),BB(2)
      INTEGER I,J,K
      INTEGER,PARAMETER::S(3)=(/+1,-1,+1/)
      J=1
      DO K=1,2
        IF (I.EQ.J) J=J+1
        AA(K)=A(J)
        BB(K)=B(J)
        J=J+1
      ENDDO
      EPS3=S(I)*(AA(1)*BB(2)-AA(2)*BB(1))
      END
C-----------------------------------------------------------------------


      ! -------------------------------------------------------------
      !
      ! This file contains subroutines for solving the Dyson equation
      ! using the DLR
      !
      ! -------------------------------------------------------------
      !
      ! Copyright (C) 2021 The Simons Foundation
      !
      ! Author: Jason Kaye
      !
      ! -------------------------------------------------------------
      !
      ! libdlr is licensed under the Apache License, Version 2.0 (the
      ! "License"); you may not use this file except in compliance with
      ! the License.  You may obtain a copy of the License at
      !
      !     http://www.apache.org/licenses/LICENSE-2.0
      !
      ! Unless required by applicable law or agreed to in writing,
      ! software distributed under the License is distributed on an "AS
      ! IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either
      ! express or implied.  See the License for the specific language
      ! governing permissions and limitations under the License.
      !
      ! -------------------------------------------------------------

      !> Solve the nonlinear Dyson equation in imaginary time,
      !! with a given expression for the self-energy in terms of the
      !! Green's function.
      !!
      !! This solver uses weighted fixed point iteration to achieve
      !! self-consistency; this is an iteration
      !! G_{n+1} = w*G_n + (1-w)*G_{n-1}, where w is a given weight. The
      !! iteration terminates when the difference between G_{n+1} and
      !! G_n at all of the imaginary time grid points is less than a
      !! given tolerance in absolute value, or when a maximum number of
      !! iterations is reached.
      !!
      !! @param[in]     beta    inverse temperature
      !! @param[in]     r       number of DLR basis functions
      !! @param[in]     dlrit   DLR imaginary time nodes
      !! @param[in]     it2cf   imaginary time grid values ->
      !!                          DLR coefficients transform matrix,
      !!                          stored in LAPACK LU factored format;
      !!                          LU factors
      !! @param[in]     it2cfp  imaginary time grid values ->
      !!                          DLR coefficients transform matrix,
      !!                          stored in LAPACK LU factored format;
      !!                          LU pivots
      !! @param[in]     cf2it   DLR coefficients -> imaginary time grid
      !!                          values transform matrix
      !! @param[in]     phi     tensor taking DLR coefficients of g to
      !!                          matrix of convolution by g.
      !! @param[in]     sigfun  subroutine with calling sequence
      !!                          sigfun(r,g,sig), which takes in
      !!                          value of an imaginary time Green's
      !!                          function at the imaginary time grid
      !!                          points, and returns values of the
      !!                          self-energy Sigma at those grid points
      !! @param[in]     w       weighting parameter for fixed point
      !!                          iteration
      !! @param[in]     fptol   fixed point iteration tolerance
      !! @param[in,out] numit   on input: max number of fixed point
      !!                          iterations; on output: number of
      !!                          fixed point iterations taken
      !! @param[in]     g0      right hand side of Dyson equation, on
      !!                          imaginary time grid
      !! @param[in,out] g       on input, initial guess for fixed
      !!                          point iteration; on output, solution
      !!                          of the Dyson equation on imaginary
      !!                          time grid
      !! @param[out]    info    =0 if iteration converged to tolerance
      !!                          fptol; =-1 if iteration did not
      !!                          converge

      subroutine dlr_dyson_it(beta,r,dlrit,it2cf,it2cfp,&
          phi,sigfun,w,fptol,numit,g0,g,info)

      implicit none
      integer r,numit,it2cfp(r),info
      real *8 beta,dlrit(r),it2cf(r,r)
      real *8 g0(r),g(r),w,fptol,phi(r*r,r)

      integer i,info1
      real *8 one
      real *8, allocatable :: g0mat(:,:),sig(:),gnew(:)

      one = 1.0d0

      ! Get matrix of convolution by G0

      allocate(g0mat(r,r))

      call dlr_convmat(r,it2cf,it2cfp,phi,g0,g0mat)

      ! Weighted fixed point iteration

      allocate(sig(r),gnew(r))

      do i=1,numit

        ! Evaluate self-energy

        call sigfun(r,g,sig)

        ! Solve linear Dyson equation

        call dyson_it_lin(r,it2cf,it2cfp,phi,g0,g0mat,sig,gnew)

        ! Check self-consistency

        if (maxval(abs(gnew-g))<fptol) then

          g = gnew
          numit = i
          info = 0

          return

        else

          ! Next G is weighted linear combination of previous and
          ! current iterates

          g = w*gnew + (one-w)*g

        endif
      enddo

      info = -1

      end subroutine dlr_dyson_it

      !> Solve the linear Dyson equation in imaginary time, with a fixed
      !! self-energy.
      !!
      !! This solver forms the Dyson equation in imaginary time using
      !! the DLR basis and solves it using Gaussian elimination.
      !!
      !! @param[in]   r       number of DLR basis functions
      !! @param[in]   it2cf   imaginary time grid values ->
      !!                        DLR coefficients transform matrix,
      !!                        stored in LAPACK LU factored format;
      !!                        LU factors
      !! @param[in]   it2cfp  imaginary time grid values ->
      !!                        DLR coefficients transform matrix,
      !!                        stored in LAPACK LU factored format;
      !!                        LU pivots
      !! @param[in]   phi     tensor taking DLR coefficients of g to
      !!                        matrix of convolution by g.
      !! @param[in]   g0      values of the right hand side G0 on
      !!                        the imaginary time grid
      !! @param[in]   g0mat   matrix of convolution by G0
      !! @param[in]   sig     values of the self-energy on the
      !!                          imaginary time grid
      !! @param[out]  g       solution of the linear Dyson equation
      !!                          on imaginary time grid

      subroutine dyson_it_lin(r,it2cf,it2cfp,phi,g0,g0mat,sig,g)

      implicit none
      integer r,it2cfp(r)
      real *8 it2cf(r,r)
      real *8 g0(r),g0mat(r,r),sig(r),g(r)
      real *8 phi(r*r,r)

      integer j,info1
      integer, allocatable :: ipiv(:)
      real *8 one
      real *8, allocatable :: sigc(:),sigmat(:,:),sysmat(:,:)

      one = 1.0d0

      allocate(sigc(r),sigmat(r,r),sysmat(r,r),ipiv(r))

      ! Get matrix of convolution by self-energy

      call dlr_convmat(r,it2cf,it2cfp,phi,sig,sigmat)

      ! Form system matrix for linear Dyson equation

      call dgemm('N','N',r,r,r,-one,g0mat,r,sigmat,r,0*one,sysmat,r)

      do j=1,r
        sysmat(j,j) = one + sysmat(j,j)
      enddo

      ! Solve linear equation by LU factorization + backsolve

      call dgetrf(r,r,sysmat,r,ipiv,info1)

      g = g0

      call dgetrs('N',r,1,sysmat,r,ipiv,g,r,info1)

      end subroutine dyson_it_lin

      !> Solve the nonlinear Dyson equation in Matsubara frequency,
      !! with a given expression for the self-energy in terms of the
      !! Green's function, evaluated in imaginary time.
      !!
      !! This solver uses weighted fixed point iteration to achieve
      !! self-consistency; this is an iteration
      !! G_{n+1} = w*G_n + (1-w)*G_{n-1}, where w is a given weight. The
      !! iteration terminates when the difference between G_{n+1} and
      !! G_n at all of the imaginary time grid points is less than a
      !! given tolerance in absolute value, or when a maximum number of
      !! iterations is reached.
      !!
      !! The solver transforms back and forth between the imaginary time
      !! and Matsubara frequency domains, evaluating the self-energy in
      !! imaginary time, and solving the Dyson equation in Matsubara
      !! frequency.
      !!
      !! @param[in]     beta    inverse temperature
      !! @param[in]     r       number of DLR basis functions
      !! @param[in]     dlrit   DLR imaginary time nodes
      !! @param[in]     it2cf   imaginary time grid values ->
      !!                          DLR coefficients transform matrix,
      !!                          stored in LAPACK LU factored format;
      !!                          LU factors
      !! @param[in]     it2cfp  imaginary time grid values ->
      !!                          DLR coefficients transform matrix,
      !!                          stored in LAPACK LU factored format;
      !!                          LU pivots
      !! @param[in]     cf2it   DLR coefficients -> imaginary time grid
      !!                          values transform matrix
      !! @param[in]     dlrmf   DLR Matsubara frequency nodes
      !! @param[in]     mf2cf   Matsubara frequency grid values ->
      !!                          DLR coefficients transform matrix,
      !!                          stored in LAPACK LU factored format;
      !!                          LU factors
      !! @param[in]     mf2cfp  Matsubra frequency grid values ->
      !!                          DLR coefficients transform matrix,
      !!                          stored in LAPACK LU factored format;
      !!                          LU pivots
      !! @param[in]     cf2mf   DLR coeffs -> Matsubara freq grid
      !!                          values transform matrix
      !! @param[in]     sigfun  subroutine with calling sequence
      !!                          sigfun(r,g,sig), which takes in
      !!                          value of an imaginary time Green's
      !!                          function at the imaginary time grid
      !!                          points, and returns values of the
      !!                          self-energy Sigma at those grid
      !!                          points
      !! @param[in]     w       weighting parameter for fixed point
      !!                          iteration
      !! @param[in]     fptol   fixed point iteration tolerance
      !! @param[in,out] numit   on input: max number of fixed point
      !!                          iterations; on output: number of
      !!                          fixed point iterations taken
      !! @param[in]     g0      right hand side of Dyson equation, on
      !!                          Matsubara frequency grid
      !! @param[in,out] g       on input, initial guess for fixed
      !!                          point iteration; on output, solution
      !!                          of the Dyson equation on imaginary
      !!                          time grid
      !! @param[out]    info    =0 if iteration converged to tolerance
      !!                          fptol; =-1 if iteration did not
      !!                          converge

      subroutine dlr_dyson_mf(beta,r,dlrit,it2cf,it2cfp,cf2it,&
          dlrmf,mf2cf,mf2cfp,cf2mf,sigfun,w,fptol,numit,g0,g,&
          info)

      implicit none
      integer r,numit,it2cfp(r),mf2cfp(r),dlrmf(r)
      integer info
      real *8 beta,dlrit(r),it2cf(r,r)
      real *8 cf2it(r,r),g(r),w,fptol
      complex *16 mf2cf(r,r),cf2mf(r,r),g0(r)

      integer i
      real *8 one
      real *8, allocatable :: sig(:),gnew(:)

      one = 1.0d0

      ! Weighted fixed point iteration

      allocate(sig(r),gnew(r))

      do i=1,numit

        ! Evaluate self-energy

        call sigfun(r,g,sig)

        ! Solve linear Dyson equation

        call dyson_mf_lin(beta,r,it2cf,it2cfp,cf2it,&
          mf2cf,mf2cfp,cf2mf,g0,sig,gnew)

        ! Check self-consistency

        if (maxval(abs(gnew-g))<fptol) then

          g = gnew
          numit = i
          info = 0

          return

        else

          ! Next G is weighted linear combination of previous and
          ! current iterates

          g = w*gnew + (one-w)*g

        endif
      enddo

      info = -1

      end subroutine dlr_dyson_mf

      !> Solve the linear Dyson equation in Matsubara frequency, with a
      !! fixed self-energy.
      !!
      !! This solver takes in the self-energy and returns the imaginary
      !! time Green's function on the imaginary time grid, but performs
      !! the solve in the Matsubara frequency domain by diagonal
      !! inversion.
      !!
      !! @param[in]   beta    inverse temperature
      !! @param[in]   r       number of DLR basis functions
      !! @param[in]   it2cf   imaginary time grid values ->
      !!                        DLR coefficients transform matrix,
      !!                        stored in LAPACK LU factored format;
      !!                        LU factors
      !! @param[in]   it2cfp  imaginary time grid values ->
      !!                        DLR coefficients transform matrix,
      !!                        stored in LAPACK LU factored format;
      !!                        LU pivots
      !! @param[in]   cf2it   DLR coefficients -> imaginary time grid
      !!                        values transform matrix
      !! @param[in]   mf2cf   Matsubara frequency grid values ->
      !!                        DLR coefficients transform matrix,
      !!                        stored in LAPACK LU factored format;
      !!                        LU factors
      !! @param[in]   mf2cfp  Matsubra frequency grid values ->
      !!                        DLR coefficients transform matrix,
      !!                        stored in LAPACK LU factored format;
      !!                        LU pivots
      !! @param[in]   cf2mf   DLR coeffs -> Matsubara freq grid
      !!                        values transform matrix
      !! @param[in]   g0      values of the right hand side G0 on
      !!                        the Matsubara frequency grid
      !! @param[in]   sig     values of the self-energy on the
      !!                          imaginary time grid
      !! @param[out]  g       solution of the linear Dyson equation
      !!                          on imaginary time grid

      subroutine dyson_mf_lin(beta,r,it2cf,it2cfp,cf2it,&
          mf2cf,mf2cfp,cf2mf,g0,sig,g)

      implicit none
      integer r,it2cfp(r),mf2cfp(r)
      real *8 beta,it2cf(r,r),cf2it(r,r)
      real *8 sig(r),g(r)
      complex *16 mf2cf(r,r),cf2mf(r,r),g0(r)

      real *8 one
      real *8, allocatable :: gc(:),sigc(:)
      complex *16, allocatable :: gmf(:),sigmf(:),tmp(:)

      one = 1.0d0

      allocate(sigc(r),gmf(r),sigmf(r),tmp(r),gc(r))

      ! Get DLR coefficients of self-energy

      call dlr_it2cf(r,it2cf,it2cfp,sig,sigc)

      ! Get self-energy on Matsubara frequency grid

      call dlr_cf2mf(r,cf2mf,sigc,sigmf)

      ! Solve Dyson equation by diagonal inversion

      gmf = g0/(one-beta**2*g0*sigmf)

      ! Get DLR coefficients of solution

      call dlr_mf2cf(r,mf2cf,mf2cfp,gmf,gc)

      ! Evaluate solution on imaginary time grid

      call dlr_cf2it(r,cf2it,gc,g)

      end subroutine dyson_mf_lin

      !> Solve the Dyson equation in Matsubara frequency.
      !!
      !! This solver takes in the self-energy and returns the imaginary
      !! time Green's function on the imaginary time grid, but performs
      !! the solve in the Matsubara frequency domain by diagonal
      !! inversion.
      !!
      !! @param[in]   beta    inverse temperature
      !! @param[in]   r       number of DLR basis functions
      !! @param[in]   g0      values of the right hand side G0 on
      !!                        the Matsubara frequency grid
      !! @param[in]   sigmf   values of the self-energy on the
      !!                        Matsubara frequency grid
      !! @param[out]  gmf     solution of the Dyson equation on the
      !!                        Matsubara frequency grid

      subroutine dyson_mf_solve(beta,r,g0,sigmf,gmf)

      implicit none
      integer r
      real *8 beta
      complex *16 g0(r),sigmf(r),gmf(r)

      gmf = g0/(1.0d0-beta**2*g0*sigmf)

      end subroutine dyson_mf_solve


Subroutine decomp(px0, py0, pz0, xm0, i, itq1)
  Implicit Double Precision (D)
  Double Precision enenew, pxnew, pynew, pznew
  Double Precision de0, beta2, gam, ptwo, px0, py0, pz0, xm0
  Common /lor/enenew, pxnew, pynew, pznew
  Common /hparnt/hipr1(100), ihpr2(50), hint1(100), ihnt2(50)
  Common /decom/ptwo(2, 5)
  Common /rndf77/nseed
  Common /hmain1/eatt, jatt, natt, nt, np, n0, n01, n10, n11
  Common /embed/iembed, nsembd, pxqembd, pyqembd, xembd, yembd, psembd, tmaxembd, phidecomp
  Save
  dcth = dble(ranart(nseed))*2.D0 - 1.D0
  dphi = dble(ranart(nseed)*hipr1(40))*2.D0
  If (iembed>=1 .And. iembed<=4) Then
     If (i==(natt-2*nsembd) .Or. i==(natt-2*nsembd-1)) Then
        dcth = 0.D0
        dphi = dble(phidecomp)
     End If
  End If
  ds = xm0**2
  dpcm = dsqrt((ds-(ptwo(1,5)+ptwo(2,5))**2)*(ds-(ptwo(1,5)-ptwo(2,5))**2)/ds/4D0)
  dpz = dpcm*dcth
  dpx = dpcm*dsqrt(1.D0-dcth**2)*dcos(dphi)
  dpy = dpcm*dsqrt(1.D0-dcth**2)*dsin(dphi)
  de1 = dsqrt(ptwo(1,5)**2+dpcm**2)
  de2 = dsqrt(ptwo(2,5)**2+dpcm**2)
  de0 = dsqrt(px0**2+py0**2+pz0**2+xm0**2)
  dbex = px0/de0
  dbey = py0/de0
  dbez = pz0/de0
  beta2 = dbex**2 + dbey**2 + dbez**2
  gam = 1.D0/dsqrt(1.D0-beta2)
  If (beta2>=0.9999999999999D0) Then
     Write (6, *) '1', dbex, dbey, dbez, beta2, gam
  End If
  Call lorenz(de1, dpx, dpy, dpz, -dbex, -dbey, -dbez)
  ptwo(1, 1) = pxnew
  ptwo(1, 2) = pynew
  ptwo(1, 3) = pznew
  ptwo(1, 4) = enenew
  Call lorenz(de2, -dpx, -dpy, -dpz, -dbex, -dbey, -dbez)
  ptwo(2, 1) = pxnew
  ptwo(2, 2) = pynew
  ptwo(2, 3) = pznew
  ptwo(2, 4) = enenew
  Return
End Subroutine decomp


      SUBROUTINE WF_P_DERIV
     &          (index)

c     Routine which computes the height derivatives of the field
c     vectors, P, according to Clemmow and Heading (1954). Equation is
c        dP/dz=-i*k*T*P.
c     Multiplication by -i is performed by operating on real and imag
c     parts separately. Multiplication by k is done in WF_STEP.

c     Wave Fields
      complex  * 16 c,s,p,dpdh,
     &              t11,t31,t41,t12,t32,t42,t14,t34,t44,
     &              tm11,tm31,tm41,tm12,tm32,tm42,tm14,tm34,tm44

      common/wf_pmtx/
     &              c(2),s(2),p(4,2,2),dpdh(4,2,2)
     &      /wf_tmtx/
     &              t11,t31,t41,t12,t32,t42,t14,t34,t44,
     &              tm11,tm31,tm41,tm12,tm32,tm42,tm14,tm34,tm44

c     Local
      complex  * 16 deriv

      do j=1,2
         deriv=t11*p(1,j,index)+t12*p(2,j,index)+t14*p(4,j,index)
         dpdh(1,j,index)=(0.d0,-1.d0)*deriv
         deriv=p(3,j,index)
         dpdh(2,j,index)=(0.d0,-1.d0)*deriv
         deriv=t31*p(1,j,index)+t32*p(2,j,index)+t34*p(4,j,index)
         dpdh(3,j,index)=(0.d0,-1.d0)*deriv
         deriv=t41*p(1,j,index)+t42*p(2,j,index)+t44*p(4,j,index)
         dpdh(4,j,index)=(0.d0,-1.d0)*deriv
      end do
      RETURN
      END      ! WF_P_DERIV


*DECK DGAMLM
      SUBROUTINE DGAMLM (XMIN, XMAX)
C***BEGIN PROLOGUE  DGAMLM
C***PURPOSE  Compute the minimum and maximum bounds for the argument in
C            the Gamma function.
C***LIBRARY   SLATEC (FNLIB)
C***CATEGORY  C7A, R2
C***TYPE      DOUBLE PRECISION (GAMLIM-S, DGAMLM-D)
C***KEYWORDS  COMPLETE GAMMA FUNCTION, FNLIB, LIMITS, SPECIAL FUNCTIONS
C***AUTHOR  Fullerton, W., (LANL)
C***DESCRIPTION
C
C Calculate the minimum and maximum legal bounds for X in gamma(X).
C XMIN and XMAX are not the only bounds, but they are the only non-
C trivial ones to calculate.
C
C             Output Arguments --
C XMIN   double precision minimum legal value of X in gamma(X).  Any
C        smaller value of X might result in underflow.
C XMAX   double precision maximum legal value of X in gamma(X).  Any
C        larger value of X might cause overflow.
C
C***REFERENCES  (NONE)
C***ROUTINES CALLED  D1MACH, XERMSG
C***REVISION HISTORY  (YYMMDD)
C   770601  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   890531  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900315  CALLs to XERROR changed to CALLs to XERMSG.  (THJ)
C***END PROLOGUE  DGAMLM
      DOUBLE PRECISION XMIN, XMAX, ALNBIG, ALNSML, XLN, XOLD, D1MACH
C***FIRST EXECUTABLE STATEMENT  DGAMLM
      ALNSML = LOG(D1MACH(1))
      XMIN = -ALNSML
      DO 10 I=1,10
        XOLD = XMIN
        XLN = LOG(XMIN)
        XMIN = XMIN - XMIN*((XMIN+0.5D0)*XLN - XMIN - 0.2258D0 + ALNSML)
     1    / (XMIN*XLN+0.5D0)
        IF (ABS(XMIN-XOLD).LT.0.005D0) GO TO 20
 10   CONTINUE
      CALL XERMSG ('SLATEC', 'DGAMLM', 'UNABLE TO FIND XMIN', 1, 2)
C
 20   XMIN = -XMIN + 0.01D0
C
      ALNBIG = LOG (D1MACH(2))
      XMAX = ALNBIG
      DO 30 I=1,10
        XOLD = XMAX
        XLN = LOG(XMAX)
        XMAX = XMAX - XMAX*((XMAX-0.5D0)*XLN - XMAX + 0.9189D0 - ALNBIG)
     1    / (XMAX*XLN-0.5D0)
        IF (ABS(XMAX-XOLD).LT.0.005D0) GO TO 40
 30   CONTINUE
      CALL XERMSG ('SLATEC', 'DGAMLM', 'UNABLE TO FIND XMAX', 2, 2)
C
 40   XMAX = XMAX - 0.01D0
      XMIN = MAX (XMIN, -XMAX+1.D0)
C
      RETURN
      END


!
!  Copyright 2016 ARTED developers
!
!  Licensed under the Apache License, Version 2.0 (the "License");
!  you may not use this file except in compliance with the License.
!  You may obtain a copy of the License at
!
!      http://www.apache.org/licenses/LICENSE-2.0
!
!  Unless required by applicable law or agreed to in writing, software
!  distributed under the License is distributed on an "AS IS" BASIS,
!  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
!  See the License for the specific language governing permissions and
!  limitations under the License.
!
!--------10--------20--------30--------40--------50--------60--------70--------80--------90--------100-------110-------120--------130
Subroutine init_Ac
  use Global_Variables
  implicit none
  integer :: iter
  real(8) :: tt

  select case(ext_field)
  case('LR')
    Ac_ext(:,1)=Epdir_1(1)*dAc
    Ac_ext(:,2)=Epdir_1(2)*dAc
    Ac_ext(:,3)=Epdir_1(3)*dAc
    Ac_ind=0.d0
    javt=0.d0
  case('LF')
    f0_1=5.338d-9*sqrt(IWcm2_1)      ! electric field in a.u.
    omega_1=omegaev_1/(2d0*Ry)  ! frequency in a.u.
    tpulse_1=tpulsefs_1/0.02418d0 ! pulse duration in a.u.
    f0_2=5.338d-9*sqrt(IWcm2_2)      ! electric field in a.u.
    omega_2=omegaev_2/(2d0*Ry)  ! frequency in a.u.
    tpulse_2=tpulsefs_2/0.02418d0 ! pulse duration in a.u.
    T1_T2=T1_T2fs/0.02418d0 ! pulse duration in a.u.
    javt=0.d0
    Ac_ext=0.d0

    select case(AE_shape)
    case('Esin2sin')
! pulse shape : E(t)=f0*sin(Pi t/T)**2 *sin (omega t+phi_CEP*2d0*pi)
! pump laser
      do iter=0,Nt+1
        tt=iter*dt
        if (tt<tpulse_1) then
          Ac_ext(iter,:)=Epdir_1(:)*f0_1*(&
            &-(cos(omega_1*tt+phi_CEP_1*2d0*pi)-cos(phi_CEP_1*2d0*pi))/(2*omega_1)&
            &+(cos((omega_1+2*Pi/tpulse_1)*tt+phi_CEP_1*2d0*pi)-cos(phi_CEP_1*2d0*pi))/(4*(omega_1+2*Pi/tpulse_1))&
            &+(cos((omega_1-2*Pi/tpulse_1)*tt+phi_CEP_1*2d0*pi)-cos(phi_CEP_1*2d0*pi))/(4*(omega_1-2*Pi/tpulse_1))&
            &-0.5*(cos(omega_1*tpulse_1+phi_CEP_1*2d0*pi)-cos(phi_CEP_1*2d0*pi))/(omega_1*((omega_1*tpulse_1/(2*pi))**2-1.d0))&
            &*(3.d0*(tt/tpulse_1)**2-2.d0*(tt/tpulse_1)**3)&
            &)
        else
          Ac_ext(iter,:)=Ac_ext(iter-1,:)
        endif
      enddo

! probe laser
      do iter=0,Nt+1
        tt=iter*dt
        if(tt-T1_T2 <= 0d0)then

        else if ( (tt-T1_T2>0d0) .and. (tt-T1_T2<tpulse_2) ) then
          Ac_ext(iter,:)=Ac_ext(iter,:)+Epdir_2(:)*f0_2*(&
            &-(cos(omega_2*(tt-T1_T2)+phi_CEP_2*2d0*pi)-cos(phi_CEP_2*2d0*pi))/(2*omega_2)&
            &+(cos((omega_2+2*Pi/tpulse_2)*(tt-T1_T2)+phi_CEP_2*2d0*pi)-cos(phi_CEP_2*2d0*pi))/(4*(omega_2+2*Pi/tpulse_2))&
            &+(cos((omega_2-2*Pi/tpulse_2)*(tt-T1_T2)+phi_CEP_2*2d0*pi)-cos(phi_CEP_2*2d0*pi))/(4*(omega_2-2*Pi/tpulse_2))&
            &-0.5*(cos(omega_2*tpulse_2+phi_CEP_2*2d0*pi)-cos(phi_CEP_2*2d0*pi))/(omega_2*((omega_2*tpulse_2/(2*pi))**2-1.d0))&
            &*(3.d0*((tt-T1_T2)/tpulse_2)**2-2.d0*((tt-T1_T2)/tpulse_2)**3)&
            &)
        else
          Ac_ext(iter,:)=Ac_ext(iter-1,:)
        endif
      enddo

    case('Asin2cos')
! pulse shape : A(t)=f0/omega*sin(Pi t/T)**2 *cos (omega t+phi_CEP*2d0*pi)
! pump laser
      do iter=0,Nt+1
        tt=iter*dt
        if (tt<tpulse_1) then
          Ac_ext(iter,:)=-Epdir_1(:)*f0_1/omega_1*(sin(pi*tt/tpulse_1))**2*cos(omega_1*tt+phi_CEP_1*2d0*pi)
        end if
      enddo
! probe laser
      do iter=0,Nt+1
        tt=iter*dt
        if ( (tt-T1_T2>0d0) .and. (tt-T1_T2<tpulse_2) ) then
          Ac_ext(iter,:)=Ac_ext(iter,:) &
            &-Epdir_2(:)*f0_2/omega_2*(sin(pi*(tt-T1_T2)/tpulse_2))**2*cos(omega_2*(tt-T1_T2)+phi_CEP_2*2d0*pi)
        endif
      enddo
    case('input')
      Ac_ext=0d0
      if(Myrank==0)then
        open(899,file='input_Ac.dat')
        do iter=0,Nt
          read(899,*)Ac_ext(iter,1),Ac_ext(iter,2),Ac_ext(iter,3)
        end do
        close(899)
      end if
      call MPI_BCAST(Ac_ext,(Nt+3)*3,MPI_REAL8,0,MPI_COMM_WORLD,ierr)

    case('Asin2_cw')
! pulse shape : A(t)=f0/omega*sin(Pi t/T)**2 *cos (omega t+phi_CEP*2d0*pi)
! pump laser
      do iter=0,Nt+1
        tt=iter*dt
        if (tt<tpulse_1*0.5d0) then
          Ac_ext(iter,:)=-Epdir_1(:)*f0_1/omega_1*(sin(pi*tt/tpulse_1))**2*cos(omega_1*tt+phi_CEP_1*2d0*pi)
        else
          Ac_ext(iter,:)=-Epdir_1(:)*f0_1/omega_1*cos(omega_1*tt+phi_CEP_1*2d0*pi)
        end if
      enddo

    end select

    Ac_ind=0.d0
  end select
  Ac_tot=Ac_ind+Ac_ext

  return
End Subroutine init_Ac
!--------10--------20--------30--------40--------50--------60--------70--------80--------90--------100-------110-------120--------130


      SUBROUTINE WNNLS(W,MDW,ME,MA,N,L,PRGOPT,X,RNORM,MODE,IWORK,WORK)
C***BEGIN PROLOGUE  WNNLS
C***DATE WRITTEN   790701   (YYMMDD)
C***REVISION DATE  820801   (YYMMDD)
C***CATEGORY NO.  K1A2A
C***KEYWORDS  CONSTRAINED LEAST SQUARES,CURVE FITTING,DATA FITTING,
C             EQUALITY CONSTRAINTS,INEQUALITY CONSTRAINTS,
C             NONNEGATIVITY CONSTRAINTS,QUADRATIC PROGRAMMING
C***AUTHOR  HANSON, R. J., (SNLA)
C           HASKELL, K. H., (SNLA)
C***PURPOSE  Solve a linearly constrained least squares problem with
C            equality constraints and nonnegativity constraints on
C            selected variables.
C***DESCRIPTION
C
C     DIMENSION W(MDW,N+1),PRGOPT(*),X(N),IWORK(M+N),WORK(M+5*N)
C
C     Written by Karen H. Haskell, Sandia Laboratories,
C     and R.J. Hanson, Sandia Laboratories.
C
C     Abstract
C
C     This subprogram solves a linearly constrained least squares
C     problem.  Suppose there are given matrices E and A of
C     respective dimensions ME by N and MA by N, and vectors F
C     and B of respective lengths ME and MA.  This subroutine
C     solves the problem
C
C               EX = F, (equations to be exactly satisfied)
C
C               AX = B, (equations to be approximately satisfied,
C                        in the least squares sense)
C
C               subject to components L+1,...,N nonnegative
C
C     Any values ME.GE.0, MA.GE.0 and 0.LE. L .LE.N are permitted.
C
C     The problem is reposed as problem WNNLS
C
C               (WT*E)X = (WT*F)
C               (   A)    (   B), (least squares)
C               subject to components L+1,...,N nonnegative.
C
C     The subprogram chooses the heavy weight (or penalty parameter) WT.
C
C     The parameters for WNNLS are
C
C     INPUT..
C
C     W(*,*),MDW,  The array W(*,*) is double subscripted with first
C     ME,MA,N,L    dimensioning parameter equal to MDW.  For this
C                  discussion let us call M = ME + MA.  Then MDW
C                  must satisfy MDW.GE.M.  The condition MDW.LT.M
C                  is an error.
C
C                  The array W(*,*) contains the matrices and vectors
C
C                       (E  F)
C                       (A  B)
C
C                  in rows and columns 1,...,M and 1,...,N+1
C                  respectively.  Columns 1,...,L correspond to
C                  unconstrained variables X(1),...,X(L).  The
C                  remaining variables are constrained to be
C                  nonnegative. The condition L.LT.0 or L.GT.N is
C                  an error.
C
C     PRGOPT(*)    This real-valued array is the option vector.
C                  If the user is satisfied with the nominal
C                  subprogram features set
C
C                  PRGOPT(1)=1 (or PRGOPT(1)=1.0)
C
C                  Otherwise PRGOPT(*) is a linked list consisting of
C                  groups of data of the following form
C
C                  LINK
C                  KEY
C                  DATA SET
C
C                  The parameters LINK and KEY are each one word.
C                  The DATA SET can be comprised of several words.
C                  The number of items depends on the value of KEY.
C                  The value of LINK points to the first
C                  entry of the next group of data within
C                  PRGOPT(*).  The exception is when there are
C                  no more options to change.  In that
C                  case LINK=1 and the values KEY and DATA SET
C                  are not referenced. The general layout of
C                  PRGOPT(*) is as follows.
C
C               ...PRGOPT(1)=LINK1 (link to first entry of next group)
C               .  PRGOPT(2)=KEY1 (key to the option change)
C               .  PRGOPT(3)=DATA VALUE (data value for this change)
C               .       .
C               .       .
C               .       .
C               ...PRGOPT(LINK1)=LINK2 (link to the first entry of
C               .                       next group)
C               .  PRGOPT(LINK1+1)=KEY2 (key to the option change)
C               .  PRGOPT(LINK1+2)=DATA VALUE
C               ...     .
C               .       .
C               .       .
C               ...PRGOPT(LINK)=1 (no more options to change)
C
C                  Values of LINK that are nonpositive are errors.
C                  A value of LINK.GT.NLINK=100000 is also an error.
C                  This helps prevent using invalid but positive
C                  values of LINK that will probably extend
C                  beyond the program limits of PRGOPT(*).
C                  Unrecognized values of KEY are ignored.  The
C                  order of the options is arbitrary and any number
C                  of options can be changed with the following
C                  restriction.  To prevent cycling in the
C                  processing of the option array a count of the
C                  number of options changed is maintained.
C                  Whenever this count exceeds NOPT=1000 an error
C                  message is printed and the subprogram returns.
C
C                  OPTIONS..
C
C                  KEY=6
C                         Scale the nonzero columns of the
C                  entire data matrix
C                  (E)
C                  (A)
C                  to have length one. The DATA SET for
C                  this option is a single value.  It must
C                  be nonzero if unit length column scaling is
C                  desired.
C
C                  KEY=7
C                         Scale columns of the entire data matrix
C                  (E)
C                  (A)
C                  with a user-provided diagonal matrix.
C                  The DATA SET for this option consists
C                  of the N diagonal scaling factors, one for
C                  each matrix column.
C
C                  KEY=8
C                         Change the rank determination tolerance from
C                  the nominal value of SQRT(SRELPR).  This quantity
C                  can be no smaller than SRELPR, The arithmetic-
C                  storage precision.  The quantity used
C                  here is internally restricted to be at
C                  least SRELPR.  The DATA SET for this option
C                  is the new tolerance.
C
C                  KEY=9
C                         Change the blow-up parameter from the
C                  nominal value of SQRT(SRELPR).  The reciprocal of
C                  this parameter is used in rejecting solution
C                  components as too large when a variable is
C                  first brought into the active set.  Too large
C                  means that the proposed component times the
C                  reciprocal of the parameter is not less than
C                  the ratio of the norms of the right-side
C                  vector and the data matrix.
C                  This parameter can be no smaller than SRELPR,
C                  the arithmetic-storage precision.
C
C                  For example, suppose we want to provide
C                  a diagonal matrix to scale the problem
C                  matrix and change the tolerance used for
C                  determining linear dependence of dropped col
C                  vectors.  For these options the dimensions of
C                  PRGOPT(*) must be at least N+6.  The FORTRAN
C                  statements defining these options would
C                  be as follows.
C
C                  PRGOPT(1)=N+3 (link to entry N+3 in PRGOPT(*))
C                  PRGOPT(2)=7 (user-provided scaling key)
C
C                  CALL SCOPY(N,D,1,PRGOPT(3),1) (copy the N
C                  scaling factors from a user array called D(*)
C                  into PRGOPT(3)-PRGOPT(N+2))
C
C                  PRGOPT(N+3)=N+6 (link to entry N+6 of PRGOPT(*))
C                  PRGOPT(N+4)=8 (linear dependence tolerance key)
C                  PRGOPT(N+5)=... (new value of the tolerance)
C
C                  PRGOPT(N+6)=1 (no more options to change)
C
C
C     IWORK(1),    The amounts of working storage actually allocated
C     IWORK(2)     for the working arrays WORK(*) and IWORK(*),
C                  respectively.  These quantities are compared with
C                  the actual amounts of storage needed for WNNLS( ).
C                  Insufficient storage allocated for either WORK(*)
C                  or IWORK(*) is considered an error.  This feature
C                  was included in WNNLS( ) because miscalculating
C                  the storage formulas for WORK(*) and IWORK(*)
C                  might very well lead to subtle and hard-to-find
C                  execution errors.
C
C                  The length of WORK(*) must be at least
C
C                  LW = ME+MA+5*N
C                  This test will not be made if IWORK(1).LE.0.
C
C                  The length of IWORK(*) must be at least
C
C                  LIW = ME+MA+N
C                  This test will not be made if IWORK(2).LE.0.
C
C     OUTPUT..
C
C     X(*)         An array dimensioned at least N, which will
C                  contain the N components of the solution vector
C                  on output.
C
C     RNORM        The residual norm of the solution.  The value of
C                  RNORM contains the residual vector length of the
C                  equality constraints and least squares equations.
C
C     MODE         The value of MODE indicates the success or failure
C                  of the subprogram.
C
C                  MODE = 0  Subprogram completed successfully.
C
C                       = 1  Max. number of iterations (equal to
C                            3*(N-L)) exceeded. Nearly all problems
C                            should complete in fewer than this
C                            number of iterations. An approximate
C                            solution and its corresponding residual
C                            vector length are in X(*) and RNORM.
C
C                       = 2  Usage error occurred.  The offending
C                            condition is noted with the error
C                            processing subprogram, XERROR( ).
C
C     User-designated
C     Working arrays..
C
C     WORK(*)      A real-valued working array of length at least
C                  M + 5*N.
C
C     IWORK(*)     An integer-valued working array of length at least
C                  M+N.
C***REFERENCES  K.H. HASKELL AND R.J. HANSON, *AN ALGORITHM FOR
C                 LINEAR LEAST SQUARES PROBLEMS WITH EQUALITY AND
C                 NONNEGATIVITY CONSTRAINTS*, SAND77-0552, JUNE 1978.
C               K.H. HASKELL AND R.J. HANSON, *SELECTED ALGORITHMS FOR
C                 THE LINEARLY CONSTRAINED LEAST SQUARES PROBLEM--
C                 A USERS GUIDE*, SAND78-1290, AUGUST 1979.
C               K.H. HASKELL AND R.H. HANSON, *AN ALGORITHM FOR
C                 LINEAR LEAST SQUARES PROBLEMS WITH EQUALITY AND
C                 NONNEGATIVITY CONSTRAINTS*, MATH. PROG. 21 (1981),
C                 PP. 98-118.
C               R.J. HANSON AND K.H. HASKELL, *TWO ALGORITHMS FOR THE
C                 LINEARLY CONSTRAINED LEAST SQUARES PROBLEM*, ACM
C                 TRANS. ON MATH. SOFTWARE, SEPT. 1982.
C***ROUTINES CALLED  WNLSM,XERROR,XERRWV
C***END PROLOGUE  WNNLS
C
C     THE EDITING REQUIRED TO CONVERT THIS SUBROUTINE FROM SINGLE TO
C     DOUBLE PRECISION INVOLVES THE FOLLOWING CHARACTER STRING CHANGES.
C     USE AN EDITING COMMAND (CHANGE) /STRING-1/(TO)STRING-2/.
C     (START AT LINE WITH C++ IN COLS. 1-3.)
C     /REAL (12 BLANKS)/DOUBLE PRECISION/,/, DUMMY/,SNGL(DUMMY)/
C
C     WRITTEN BY KAREN H. HASKELL, SANDIA LABORATORIES,
C     AND R.J. HANSON, SANDIA LABORATORIES.
C     REVISED FEB.25, 1982.
C
C     SUBROUTINES CALLED BY WNNLS( )
C
C++
C     WNLSM         COMPANION SUBROUTINE TO WNNLS( ), WHERE
C                   MOST OF THE COMPUTATION TAKES PLACE.
C
C     XERROR,XERRWV FROM SLATEC ERROR PROCESSING PACKAGE.
C                   THIS IS DOCUMENTED IN SANDIA TECH. REPT.,
C                   SAND78-1189.
C
C     REFERENCES
C
C     1. SOLVING LEAST SQUARES PROBLEMS, BY C.L. LAWSON
C        AND R.J. HANSON.  PRENTICE-HALL, INC. (1974).
C
C     2. BASIC LINEAR ALGEBRA SUBPROGRAMS FOR FORTRAN USAGE, BY
C        C.L. LAWSON, R.J. HANSON, D.R. KINCAID, AND F.T. KROGH.
C        TOMS, V. 5, NO. 3, P. 308.  ALSO AVAILABLE AS
C        SANDIA TECHNICAL REPORT NO. SAND77-0898.
C
C     3. AN ALGORITHM FOR LINEAR LEAST SQUARES WITH EQUALITY
C        AND NONNEGATIVITY CONSTRAINTS, BY K.H. HASKELL AND
C        R.J. HANSON.  AVAILABLE AS SANDIA TECHNICAL REPORT NO.
C        SAND77-0552, AND MATH. PROGRAMMING, VOL. 21, (1981), P. 98-118.
C
C     4. SLATEC COMMON MATH. LIBRARY ERROR HANDLING
C        PACKAGE.  BY R. E. JONES.  AVAILABLE AS SANDIA
C        TECHNICAL REPORT SAND78-1189.
C
      REAL              DUMMY, W(MDW,1), PRGOPT(1), X(1), WORK(1), RNORM
      INTEGER IWORK(*)
C
C
C***FIRST EXECUTABLE STATEMENT  WNNLS
      MODE = 0
       iwork(1)=mdw*6
       iwork(2)=mdw*2
      IF (MA+ME.LE.0 .OR. N.LE.0) RETURN
      IF (.NOT.(IWORK(1).GT.0)) GO TO 20
      LW = ME + MA + 5*N
      IF (.NOT.(IWORK(1).LT.LW)) GO TO 10
      NERR = 2
      IOPT = 1
      print*,'work array',iwork(1),lw
      CALL XERRWV( 'WNNLS( ), INSUFFICIENT STORAGE ALLOCATED FOR WORK(*)
     1, NEED LW=I1 BELOW', 70, NERR, IOPT, 1, LW, 0, 0, DUMMY, DUMMY)
      MODE = 2
      RETURN
   10 CONTINUE
   20 IF (.NOT.(IWORK(2).GT.0)) GO TO 40
      LIW = ME + MA + N
      IF (.NOT.(IWORK(2).LT.LIW)) GO TO 30
      NERR = 2
      IOPT = 1
      CALL XERRWV( 'WNNLS( ), INSUFFICIENT STORAGE ALLOCATED FOR IWORK(*
     1), NEED LIW=I1 BELOW', 72, NERR, IOPT, 1, LIW, 0, 0, DUMMY, DUMMY)
      MODE = 2
      RETURN
   30 CONTINUE
   40 IF (.NOT.(MDW.LT.ME+MA)) GO TO 50
      NERR = 1
      IOPT = 1
      CALL XERROR( 'WNNLS( ), THE VALUE MDW.LT.ME+MA IS AN ERROR', 44,
     1 NERR, IOPT)
      MODE = 2
      RETURN
   50 IF (0.LE.L .AND. L.LE.N) GO TO 60
      NERR = 2
      IOPT = 1
      CALL XERROR( 'WNNLS( ), L.LE.0.AND.L.LE.N IS REQUIRED', 39, NERR,
     1 IOPT)
      MODE = 2
      RETURN
C
C     THE PURPOSE OF THIS SUBROUTINE IS TO BREAK UP THE ARRAYS
C     WORK(*) AND IWORK(*) INTO SEPARATE WORK ARRAYS
C     REQUIRED BY THE MAIN SUBROUTINE WNLSM( ).
C
   60 L1 = N + 1
      L2 = L1 + N
      L3 = L2 + ME + MA
      L4 = L3 + N
      L5 = L4 + N
C
      CALL WNLSM(W, MDW, ME, MA, N, L, PRGOPT, X, RNORM, MODE, IWORK,
     1 IWORK(L1), WORK(1), WORK(L1), WORK(L2), WORK(L3), WORK(L4),
     2 WORK(L5))
      RETURN
      END


c****************************************************************

      program get_peg

c****************************************************************
c**
c**   FILE NAME: get_peg.f
c**
c**   DATE WRITTEN: 6/10/95
c**
c**   PROGRAMMER: Scott Hensley
c**
c**   FUNCTIONAL DESCRIPTION: This program reads simple emphemeris
c**   information and compute the appropriate peg frame as well as
c**   generating
c**
c**   ROUTINES CALLED:none
c**
c**   NOTES: none
c**
c**   UPDATE LOG:
c**     This program is modified from get_peg_info.f. Cunren Liang, 21-OCT-2015
c**     Both original program and this program assume WGS84 coordinate
c*****************************************************************

      implicit none

c     PARAMETER STATEMENTS:

      real*8 r_awgs84,r_e2wgs84
      parameter(r_awgs84=6378137.d0,r_e2wgs84=.00669437999015d0)

      real*8 pi,r_dtor,r_rtod
      parameter(pi=3.141592653589793d0)     !if you have to ask, give it up
      parameter(r_rtod=180.d0/pi,r_dtor=pi/180.d0)  !radian to degree conversions

      integer i_xyztollh,i_llhtoxyz
      parameter(i_xyztollh=2, i_llhtoxyz=1)
      integer i_schtoxyz,i_xyztosch
      parameter(i_schtoxyz=0,i_xyztosch=1)

      character*512 argstring
      integer j,k
      real*8 r_spinvec(3)
      real*8 r_gm, r_earthgm, r_spindot, r_earthspindot

      type ellipsoid
         sequence
         real*8 r_a
         real*8 r_e2
      end type ellipsoid
      type (ellipsoid) elp

      type peg_struct
         sequence
         real*8 r_lat
         real*8 r_lon
         real*8 r_hdg
      end type peg_struct
      type (peg_struct) peg

      type pegtrans
         sequence
         real*8 r_mat(3,3)
         real*8 r_matinv(3,3)
         real*8 r_ov(3)
         real*8 r_radcur
      end type pegtrans
      type (pegtrans) ptm

      real*8 r_enumat(3,3),r_xyzenumat(3,3),r_enuvel(3)
      real*8 r_xyzpeg(3),r_vxyzpeg(3),r_llhpeg(3)
      real*8 r_tempv(3), r_tempa(3)
      real*8 r_tempvec(3), r_inertialacc(3), r_bodyacc(3), r_platvel(3)
      real*8 r_platacc(3), r_xyznorm, r_platsch(3)
      real*8 r_xyzschmat(3,3),r_schxyzmat(3,3)
      real*8 r_velnorm

      data r_earthspindot /7.29211573052d-5/
      data r_earthgm /3.98600448073d14/

      elp%r_a = r_awgs84
      elp%r_e2 = r_e2wgs84

cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c     input the point to be converted: r_xyzpeg, r_vxyzpeg, r_gm, r_spindot
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc

c      print '(a,$)',' position and velocity of point, Planet GM, Planet Spinrate: x, y, z, vx, vy, vz, r_gm, r_spindot: '
c      read *, r_xyzpeg(1), r_xyzpeg(2), r_xyzpeg(3), r_vxyzpeg(1), r_vxyzpeg(2), r_vxyzpeg(3), r_gm, r_spindot

      if(iargc() .ne. 8)then
         write(6,*) ' '
         write(6,*) ' usage: get_peg x y z vx vy vz gm spin'
         write(6,*) '    x, y, z:    position of platform'
         write(6,*) '    vx, vy, vz: velocity of platform'
         write(6,*) '    gm:         planet gm'
         write(6,*) '    spin:       planet spin'
         write(6,*) ' '
         stop
      endif

      call getarg(1, argstring)
      read(argstring,*) r_xyzpeg(1)

      call getarg(2, argstring)
      read(argstring,*) r_xyzpeg(2)

      call getarg(3, argstring)
      read(argstring,*) r_xyzpeg(3)

      call getarg(4, argstring)
      read(argstring,*) r_vxyzpeg(1)

      call getarg(5, argstring)
      read(argstring,*) r_vxyzpeg(2)

      call getarg(6, argstring)
      read(argstring,*) r_vxyzpeg(3)

      call getarg(7, argstring)
      read(argstring,*) r_gm

      call getarg(8, argstring)
      read(argstring,*) r_spindot

c example:
c     get_peg 3014487.424, 5533954.399, 3400560.970, 3185.529504, 2252.778825, -6468.375282, 398600448073000, 7.29211573052e-05

cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c     do the calculations now

      write(6,*) ' '
      write(6,'(a,1x,3(f12.3,1x))') 'Pos Peg = ',(r_xyzpeg(j),j=1,3)
      write(6,'(a,1x,3(f12.6,1x))') 'Vel Peg = ',(r_vxyzpeg(j),j=1,3)

      call norm(r_vxyzpeg,r_velnorm)

c     take the lat,lon as the peg point and the heading as the peg heading

      call latlon(elp,r_xyzpeg,r_llhpeg,i_xyztollh)
      call enubasis(r_llhpeg(1),r_llhpeg(2),r_enumat)
      call tranmat(r_enumat,r_xyzenumat)
      call matvec(r_xyzenumat,r_vxyzpeg,r_enuvel)
      peg%r_hdg = atan2(r_enuvel(1),r_enuvel(2))

      peg%r_lat = r_llhpeg(1)
      peg%r_lon = r_llhpeg(2)

      call radar_to_xyz(elp,peg,ptm)

      write(6,*) ' '
      write(6,'(a,1x,f12.7,1x,f12.7,1x,f12.3)') 'Peg Lat/Lon , H = ',
     +     peg%r_lat*r_rtod,peg%r_lon*r_rtod,r_llhpeg(3)
      write(6,'(a,1x,f15.7)') 'Peg Heading = ',peg%r_hdg*r_rtod
      write(6,'(a,1x,f15.5)') 'Radius Curvature = ',ptm%r_radcur

      write(6,*) ' '
      write(6,'(a)') 'Rotation matrix '
      write(6,905) ' First row =  ',ptm%r_mat(1,1),ptm%r_mat(1,2),ptm%r_mat(1,3)
 905  format(a,1x,3(f12.9,1x))
      write(6,905) ' Second row = ',ptm%r_mat(2,1),ptm%r_mat(2,2),ptm%r_mat(2,3)
      write(6,905) ' Third row =  ',ptm%r_mat(3,1),ptm%r_mat(3,2),ptm%r_mat(3,3)
      write(6,*) ' '
      write(6,'(a)') 'Translation vector '
      write(6,906) ' Vector = ',ptm%r_ov
 906  format(a,1x,3(f14.5,1x))

      r_spinvec(1) = 0.
      r_spinvec(2) = 0.
      r_spinvec(3) = r_spindot

      call norm(r_xyzpeg,r_xyznorm)

      call cross(r_spinvec,r_xyzpeg,r_tempv)

      do k=1,3
         r_inertialacc(k) = -(r_gm*r_xyzpeg(k))/r_xyznorm**3
      enddo

      call cross(r_spinvec,r_vxyzpeg,r_tempa)
      call cross(r_spinvec,r_tempv,r_tempvec)

      do k=1,3
         r_bodyacc(k) = r_inertialacc(k) - 2.d0*r_tempa(k) - r_tempvec(k)
      enddo

c     convert back to a local SCH basis

      call convert_sch_to_xyz(ptm,r_platsch,r_xyzpeg,i_xyztosch)
      call schbasis(ptm,r_platsch,r_xyzschmat,r_schxyzmat)
      call matvec(r_xyzschmat,r_bodyacc,r_platacc)
      call matvec(r_xyzschmat,r_vxyzpeg,r_platvel)

      write(6,'(a,x,3(f15.7,x))') 'Platform SCH Velocity (m/s): ',r_platvel
      write(6,'(a,x,3(f15.7,x))') 'Platform SCH Acceleration (m/s^2): ',r_platacc

      end


      subroutine setse1(prop)
c     implicit double precision (a-h,o-z)                                    dp
c
c     initialize elastic material constants
c
      dimension prop(4,*)
      q1=prop(1,1)*prop(2,1)/((1.+prop(2,1))*(1.-2.0*prop(2,1)))
      q2=prop(1,1)*0.5/(1.+prop(2,1))
      q3=q1+2.0*q2
      prop(1,5)=prop(1,1)
      prop(2,5)=prop(2,1)
      do 10 i=1,4
      do 10 j=1,4
   10 prop(i,j)=0.0
      prop(1,1)=q3
      prop(2,2)=q3
      prop(3,3)=q3
      prop(4,4)=q2
      prop(1,2)=q1
      prop(1,3)=q1
      prop(2,1)=q1
      prop(2,3)=q1
      prop(3,1)=q1
      prop(3,2)=q1
ck      write(25,20) q1,q2,q3
ck   20 format(5x,'q1=',e14.4,2x,'q2=',e14.4,2x,'q3=',e14.4/)
      return
      end


      SUBROUTINE DFLUX(FLUX,SOL,JSTEP,JINC,TIME,NOEL,NPT,COORDS,JLTYP,
     1                 TEMP,PRESS,SNAME)
C
      INCLUDE 'ABA_PARAM.INC'

      DIMENSION COORDS(3),FLUX(2),TIME(2)
      CHARACTER*80 SNAME

	  x=COORDS(1)
      y=COORDS(2)
      z=COORDS(3)
	  PI=3.1415926

      !焊接工艺参数，使用同一热源
      wu=110.0
      wi=10.0
      effi=0.8
      v=0.005
      q=wu*wi*effi

      !焊接热源形状参数(球热源)
      a=0.003
	  b=0.003
	  c=0.003

      !各个关键点坐标及焊枪经过时间(相对总时间累计shijian)
      x1=0
      y1=-0.003
      z1=0.003
	  t1=0.0

      x2=0.012
      y2=-0.003
      z2=0.003
	  t2=2.4

      x3=0.015
      y3=0
      z3=0.003
	  t3=3.3425

      x4=0.018
      y4=0.003
      z4=0.003
	  t4=4.285

      !焊缝几何形状参数
      r=0.003

      !热源分布
	  heat=6.0*sqrt(3.0)*q/(a*b*c*PI*sqrt(PI))

        !第一段直线
        if(TIME(2).lt.t2) then
          d=v*TIME(2)
        !热源中心在总体坐标系的坐标
          xd=x1+d
          yd=y1
          zd=z1
        !热源局部坐标
          xx=x-xd
          yy=y-yd
          zz=z-zd

	   shape=exp(-3.0*xx**2/a**2-3.0*yy**2/b**2-3.0*zz**2/c**2)

        !第一段圆弧
        else if (TIME(2). lt. t3. and. TIME(2). ge. t2)then
          d=v*(TIME(2)-t2)
          !焊缝圆弧扫过的圆心角
          theta=d/r
          !热源中心在总体坐标系中的坐标
          xd=x2+r*sin(theta)
		  yd=y2+r*(1-cos(theta))
          zd=z2

          xx=x-xd
          yy=y-yd
          zz=z-zd

          shape=exp(-3.0*xx**2/a**2-3.0*yy**2/b**2-3.0*zz**2/c**2)

         !第二段圆弧
        else if (TIME(2). lt. t4. and. TIME(2). ge. t3)then
          d=v*(TIME(2)-t3)
          !焊缝圆弧扫过的圆心角
          theta=d/r
          !热源中心在总体坐标系中的坐标
          xd=x3+r*(1-cos(theta))
		  yd=y3+r*sin(theta)
          zd=z3

          xx=x-xd
          yy=y-yd
          zz=z-zd

          shape=exp(-3.0*xx**2/a**2-3.0*yy**2/b**2-3.0*zz**2/c**2)

        else if (TIME(2).ge.t4) then
          d=v*(TIME(2)-t4)
          xd=x4+d
          yd=y4
          zd=z4

          xx=x-xd
          yy=y-yd
          zz=z-zd

          shape=exp(-3.0*xx**2/a**2-3.0*yy**2/b**2-3.0*zz**2/c**2)

        end if

C     JLTYP＝1，表示为体热源
      JLTYP=1
      FLUX(1)=heat*shape
      RETURN
      END


      subroutine runP_00(m0sq,Gr,Czero0,N0)
      implicit none
      include 'TRconstants.f'
      include 'pvDnames.f'
      include 'pvDv.f'
      include 'Darraydef.f'
      include 'Darrays.f'
      integer ep,N0,m,n,np
      parameter(np=3)
      double precision m0sq,Gr(np,np)
      double complex Czero0(-2:0),bit,pole

      do ep=-2,0
      bit=czip
      do n=1,np
      do m=1,np
      bit=bit+Gr(n,m)*Dv(dii(z2(n,m))+N0,ep)
      enddo
      enddo

      pole=czip
      if (ep .gt. -2) pole=4d0*Dv(dd00+N0,ep-1)

      Dv(dd00+N0,ep)=
     . (pole
     . +2d0*Czero0(ep)
     . +2d0*m0sq*Dv(dd0+N0,ep)
     . -bit)/8d0
      enddo

      return
      end