*DECK DBI
      DOUBLE PRECISION FUNCTION DBI (X)
C***BEGIN PROLOGUE  DBI
C***PURPOSE  Evaluate the Bairy function (the Airy function of the
C            second kind).
C***LIBRARY   SLATEC (FNLIB)
C***CATEGORY  C10D
C***TYPE      DOUBLE PRECISION (BI-S, DBI-D)
C***KEYWORDS  BAIRY FUNCTION, FNLIB, SPECIAL FUNCTIONS
C***AUTHOR  Fullerton, W., (LANL)
C***DESCRIPTION
C
C DBI(X) calculates the double precision Airy function of the
C second kind for double precision argument X.
C
C Series for BIF        on the interval -1.00000E+00 to  1.00000E+00
C                                        with weighted error   1.45E-32
C                                         log weighted error  31.84
C                               significant figures required  30.85
C                                    decimal places required  32.40
C
C Series for BIG        on the interval -1.00000E+00 to  1.00000E+00
C                                        with weighted error   1.29E-33
C                                         log weighted error  32.89
C                               significant figures required  31.48
C                                    decimal places required  33.45
C
C Series for BIF2       on the interval  1.00000E+00 to  8.00000E+00
C                                        with weighted error   6.08E-32
C                                         log weighted error  31.22
C                        approx significant figures required  30.8
C                                    decimal places required  31.80
C
C Series for BIG2       on the interval  1.00000E+00 to  8.00000E+00
C                                        with weighted error   4.91E-33
C                                         log weighted error  32.31
C                        approx significant figures required  31.6
C                                    decimal places required  32.90
C
C***REFERENCES  (NONE)
C***ROUTINES CALLED  D1MACH, D9AIMP, DBIE, DCSEVL, INITDS, XERMSG
C***REVISION HISTORY  (YYMMDD)
C   770701  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  DBI
      DOUBLE PRECISION X, BIFCS(13), BIGCS(13), BIF2CS(15), BIG2CS(15),
     1  THETA, XM, XMAX, X3SML, Z,  D1MACH, DCSEVL, DBIE
      LOGICAL FIRST
      SAVE BIFCS, BIGCS, BIF2CS, BIG2CS, NBIF, NBIG,
     1 NBIF2, NBIG2, X3SML, XMAX, FIRST
      DATA BIFCS(  1) / -.1673021647 1986649483 5374239281 76 D-1     /
      DATA BIFCS(  2) / +.1025233583 4249445611 4263627777 57 D+0     /
      DATA BIFCS(  3) / +.1708309250 7381516539 4296502420 13 D-2     /
      DATA BIFCS(  4) / +.1186254546 7744681179 2164592100 40 D-4     /
      DATA BIFCS(  5) / +.4493290701 7792133694 5318879272 42 D-7     /
      DATA BIFCS(  6) / +.1069820714 3387889067 5677676636 28 D-9     /
      DATA BIFCS(  7) / +.1748064339 9771824706 0105176285 73 D-12    /
      DATA BIFCS(  8) / +.2081023107 1761711025 8818918343 99 D-15    /
      DATA BIFCS(  9) / +.1884981469 5665416509 9279717333 33 D-18    /
      DATA BIFCS( 10) / +.1342577917 3097804625 8826666666 66 D-21    /
      DATA BIFCS( 11) / +.7715959342 9658887893 3333333333 33 D-25    /
      DATA BIFCS( 12) / +.3653387961 7478566399 9999999999 99 D-28    /
      DATA BIFCS( 13) / +.1449756592 7953066666 6666666666 66 D-31    /
      DATA BIGCS(  1) / +.2246622324 8574522283 4682201390 24 D-1     /
      DATA BIGCS(  2) / +.3736477545 3019545441 7275616667 52 D-1     /
      DATA BIGCS(  3) / +.4447621895 7212285696 2152943266 39 D-3     /
      DATA BIGCS(  4) / +.2470807563 6329384245 4945919488 82 D-5     /
      DATA BIGCS(  5) / +.7919135339 5149635134 8624262855 96 D-8     /
      DATA BIGCS(  6) / +.1649807985 1827779880 8878724027 06 D-10    /
      DATA BIGCS(  7) / +.2411990666 4835455909 2475011228 41 D-13    /
      DATA BIGCS(  8) / +.2610373623 6091436985 1847812693 33 D-16    /
      DATA BIGCS(  9) / +.2175308297 7160323853 1237920000 00 D-19    /
      DATA BIGCS( 10) / +.1438694640 0390433219 4837333333 33 D-22    /
      DATA BIGCS( 11) / +.7734912561 2083468629 3333333333 33 D-26    /
      DATA BIGCS( 12) / +.3446929203 3849002666 6666666666 66 D-29    /
      DATA BIGCS( 13) / +.1293891927 3216000000 0000000000 00 D-32    /
      DATA BIF2CS(  1) / +.0998457269 3816041044 6828425799 3 D+0      /
      DATA BIF2CS(  2) / +.4786249778 6300553772 2114673182 31 D+0     /
      DATA BIF2CS(  3) / +.2515521196 0433011771 3244154366 75 D-1     /
      DATA BIF2CS(  4) / +.5820693885 2326456396 5156978722 16 D-3     /
      DATA BIF2CS(  5) / +.7499765964 4377865943 8614573782 17 D-5     /
      DATA BIF2CS(  6) / +.6134602870 3493836681 4030103564 74 D-7     /
      DATA BIF2CS(  7) / +.3462753885 1480632900 4342687333 59 D-9     /
      DATA BIF2CS(  8) / +.1428891008 0270254287 7708467489 31 D-11    /
      DATA BIF2CS(  9) / +.4496270429 8334641895 0564721792 00 D-14    /
      DATA BIF2CS( 10) / +.1114232306 5833011708 4283001066 66 D-16    /
      DATA BIF2CS( 11) / +.2230479106 6175002081 5178666666 66 D-19    /
      DATA BIF2CS( 12) / +.3681577873 6393142842 9226666666 66 D-22    /
      DATA BIF2CS( 13) / +.5096086844 9338261333 3333333333 33 D-25    /
      DATA BIF2CS( 14) / +.6000338692 6288554666 6666666666 66 D-28    /
      DATA BIF2CS( 15) / +.6082749744 6570666666 6666666666 66 D-31    /
      DATA BIG2CS(  1) / +.0333056621 4551434046 5176188111 647 D+0    /
      DATA BIG2CS(  2) / +.1613092151 2319706761 3287532084 943 D+0    /
      DATA BIG2CS(  3) / +.6319007309 6134286912 1615634921 173 D-2    /
      DATA BIG2CS(  4) / +.1187904568 1625173638 9780192304 567 D-3    /
      DATA BIG2CS(  5) / +.1304534588 6200265614 7116485012 843 D-5    /
      DATA BIG2CS(  6) / +.9374125995 5352172954 6809615508 936 D-8    /
      DATA BIG2CS(  7) / +.4745801886 7472515378 8510169834 595 D-10   /
      DATA BIG2CS(  8) / +.1783107265 0948139980 0065667560 946 D-12   /
      DATA BIG2CS(  9) / +.5167591927 8495818037 4276356640 000 D-15   /
      DATA BIG2CS( 10) / +.1190045083 8682712512 9496251733 333 D-17   /
      DATA BIG2CS( 11) / +.2229828806 6640351727 7063466666 666 D-20   /
      DATA BIG2CS( 12) / +.3465519230 2768941972 2666666666 666 D-23   /
      DATA BIG2CS( 13) / +.4539263363 2050451413 3333333333 333 D-26   /
      DATA BIG2CS( 14) / +.5078849965 1352234666 6666666666 666 D-29   /
      DATA BIG2CS( 15) / +.4910206746 9653333333 3333333333 333 D-32   /
      DATA FIRST /.TRUE./
C***FIRST EXECUTABLE STATEMENT  DBI
      IF (FIRST) THEN
         ETA = 0.1*REAL(D1MACH(3))
         NBIF = INITDS (BIFCS, 13, ETA)
         NBIG = INITDS (BIGCS, 13, ETA)
         NBIF2 = INITDS (BIF2CS, 15, ETA)
         NBIG2 = INITDS (BIG2CS, 15, ETA)
C
         X3SML = ETA**0.3333
         XMAX = (1.5*LOG(D1MACH(2)))**0.6666D0
      ENDIF
      FIRST = .FALSE.
C
      IF (X.GE.(-1.0D0)) GO TO 20
      CALL D9AIMP (X, XM, THETA)
      DBI = XM * SIN(THETA)
      RETURN
C
 20   IF (X.GT.1.0D0) GO TO 30
      Z = 0.D0
      IF (ABS(X).GT.X3SML) Z = X**3
      DBI = 0.625 + DCSEVL (Z, BIFCS, NBIF) + X*(0.4375D0 +
     1  DCSEVL (Z, BIGCS, NBIG))
      RETURN
C
 30   IF (X.GT.2.0D0) GO TO 40
      Z = (2.0D0*X**3 - 9.0D0)/7.D0
      DBI = 1.125D0 + DCSEVL (Z, BIF2CS, NBIF2) + X*(0.625D0 +
     1  DCSEVL (Z, BIG2CS, NBIG2))
      RETURN
C
 40   IF (X .GT. XMAX) CALL XERMSG ('SLATEC', 'DBI',
     +   'X SO BIG THAT BI OVERFLOWS', 1, 2)
C
      DBI = DBIE(X) * EXP(2.0D0*X*SQRT(X)/3.0D0)
      RETURN
C
      END


	SUBROUTINE GGRFML  ( ixtyp, iytyp, np, xm, ym, bmlx1, bmlx0,
     +			     bmly1, bmly0, xl, yl, iret )
C************************************************************************
C* GGRFML								*
C* 									*
C* This subroutine converts points in graph coordinates into linear	*
C* intermediate coordinates.						*
C*									*
C* GGRFML  ( IXTYP, IYTYP, NP, XM, YM, BMLX1, BMLX0, BMLY1, BMLY0,	*
C*           XL, YL, IRET )						*
C*									*
C* Input parameters:							*
C*	IXTYP		INTEGER		X axis type			*
C*	IYTYP		INTEGER		Y axis type			*
C*	NP		INTEGER		Number of points		*
C*	XM (NP)		REAL		X coordinates			*
C*	YM (NP)		REAL		Y coordinates			*
C*	BMLX1		REAL		X scaling factor		*
C*	BMLX0		REAL		X offset			*
C*	BMLY1		REAL		Y scaling factor		*
C*	BMLY0		REAL		Y offset			*
C*									*
C* Output parameters:							*
C*	XL (NP)		REAL		X coordinates			*
C*	YL (NP)		REAL		Y coordinates 			*
C*	IRET		INTEGER		Return code			*
C**									*
C* Log:									*
C* M. desJardins/GSFC	 6/85	GEMPLT Version 3.1			*
C* M. desJardins/GSFC	10/86	Added polar coordinates			*
C* M. desJardins/GSFC	 6/88	Documentation				*
C* K. Brill/NMC		 7/90	SkewT offset multiplied by aspect ratio *
C* M. desJardins/GSFC	 9/90	Use constants in GEMPRM.PRM		*
C************************************************************************
	INCLUDE		'ERROR.PRM'
	INCLUDE		'GEMPRM.PRM'
	INCLUDE		'XYDEF.CMN'
C*
	REAL		xl (*), yl (*), xm (*), ym (*)
C-------------------------------------------------------------------------
	iret = NORMAL
C
C*	Do transform for polar coordinates.  These are done separately
C*	from the other coordinate types since the x and y values cannot
C*	be computed independently.
C
	IF  ( ( ixtyp .eq. 5 ) .and. ( iytyp .eq. 5 ) )  THEN
	    DO  i = 1, np
		CALL RTTOXY  ( xm (i), ym (i), x, y, ier )
		xl (i) = bmlx1 * x + bmlx0
		yl (i) = bmly1 * y + bmly0
	    END DO
	    RETURN
	END IF
C
C*	Do transform for Y axis then for X axis.
C*	Order is important for skew-T plots.
C
	IF  ( iytyp .eq. 1 )  THEN
	    DO i = 1, np
	    	yl (i)  = bmly1 * ym (i) + bmly0
	    END DO
C
	  ELSE IF  ( iytyp .eq. 2 )  THEN
	    DO i = 1, np
		IF  ( ym (i) .gt. 0.0 )  THEN
		    yl (i)  =  bmly1 * ALOG ( ym (i) ) + bmly0
		  ELSE
		    yl (i)  =  0.0
		END IF
	    END DO
C
	  ELSE IF  ( iytyp .eq. 3 )  THEN
	    DO i = 1, np
		IF  ( ym (i) .ge. 0.0 )  THEN
		    yl (i)  =  bmly1 * ym (i) ** RKAPPA + bmly0
		  ELSE
		    yl (i)   = 0.0
		END IF
	    END DO
	END IF
C
	IF  ( ixtyp .eq. 1 )  THEN
	    DO i = 1, np
		xl (i)  =  bmlx1 * xm (i) + bmlx0
	    END DO
C
	  ELSE IF  ( ixtyp .eq. 2 )  THEN
	    DO i = 1, np
		IF  ( xm (i) .gt. 0. )  THEN
		    xl (i) = bmlx1 * ALOG ( xm (i) ) + bmlx0
		  ELSE
		    xl (i) = 0.0
		END IF
	    END DO
C
	  ELSE IF ( ixtyp .eq. 3 )  THEN
	    DO i = 1, np
		IF  ( xm (i) .ge. 0.0 )  THEN
		    xl (i)  = bmlx1 * xm (i) ** RKAPPA + bmlx0
		  ELSE
		    xl (i) = 0.0
		END IF
	    END DO
C
	  ELSE IF  ( ixtyp .eq. 4 )  THEN
	    DO i = 1, np
		xl (i) = bmlx1 * xm (i) + bmlx0 + yl (i) * yxgraf
	    END DO
C
	END IF
C*
	RETURN
	END


      subroutine interstitial(zj_flag,lmax,
     >                     pnrel,matom_left,matom_right,
     >                     r_sph,
     >                     ncrit,ngaussr,
     >                     grwylm,gwwylm,wylm,
     >                     cgnt,lmax_cg,
     >                     pzz,pzj,bj,bh)
c     =================================================================
c
      implicit   none
c
      integer    zj_flag
      integer    lmax,lmax_cg
      integer    ncrit
      integer    ir
      integer    lm1
      integer    lm2
      integer    l1
      integer    m1
      integer    l2
      integer    m2
      integer    l3
      integer    m3
      integer    iwylm
      integer    ng
      integer    ngaussr
c
      real*8     r_sph
      real*8     rgauss
      real*8     cgnt(lmax_cg+1,(lmax_cg+1)**2,(lmax_cg+1)**2)
      real*8     gwwylm(ngaussr,ncrit-1)
      real*8     grwylm(ngaussr,ncrit-1)
      real*8     pi,rt4pi
      parameter (pi=3.141592653589793d0)
c
      complex*16 pnrel
      complex*16 wylm((2*lmax+1)*(lmax+1),ngaussr,ncrit-1)
      complex*16 matom_left(0:lmax)
      complex*16 matom_right(0:lmax)
      complex*16 bj(0:lmax)
      complex*16 bh(0:lmax)
      complex*16 eiz
      complex*16 pzz((lmax+1)**2,(lmax+1)**2)
      complex*16 pzj
      complex*16 zlzl
      complex*16 zljl
      complex*16 zlm1
      complex*16 zlm2
      complex*16 jlm1
      complex*16 steplm
      complex*16 czero
      complex*16 sqrtm1
c
      parameter (czero=(0.0d0,0.0d0))
      parameter (sqrtm1=(0.0d0,1.0d0))
c
c     *****************************************************************
c     returns:
c                      Rs   3->     -> ^  ->       ->
c              pzz = + int d r * Z (r)*Z (r)*Sigma(r)
c                       0         L     L'
c
c                      Rs   3->     -> ^  ->       ->
c              pzj = + int d r * Z (r)*J (r)*Sigma(r) * delta
c                       0         L     L'                   LL'
c
c     *****************************************************************
c
c     =================================================================
c     For muffin-tin potentials and r=>Rmt, one has
c        ->                                     ->
c     Z (r) = -p*[j (p*r)*cot(d ) - n (p*r)]*Y (r)
c      L           l           l     l        L
c
c     ^  ->                                   * ->
c     Z (r) = -p*[j (p*r)*cot(d ) - n (p*r)]*Y (r)
c      L           l           l     l        L
c
c        ->              ->
c     J (r) = j (p*r)*Y (r)
c      L       l       L
c
c     ^  ->            * ->
c     J (r) = j (p*r)*Y (r)
c      L       l       L
c
c     calculate the interstial integrals...............................
c     loop over each region between MT-sphere and circumscibing sphere.
c     =================================================================
c     -----------------------------------------------------------------
      call zeroout(pzz,2*(lmax+1)**4)
      pzj=czero
      rt4pi=sqrt(4.d0*pi)
c     -----------------------------------------------------------------
      do ir=1,ncrit-1
c        ==============================================================
c        loop over the gaussian point in each region...................
c        ==============================================================
         do ng=1,ngaussr
            rgauss=grwylm(ng,ir)
	    if(rgauss.gt.0.d0) then
c           -----------------------------------------------------------
            call zsphbesjh(lmax,pnrel*rgauss,bj,bh,eiz,1)
c           -----------------------------------------------------------
            eiz=sqrtm1*eiz/rgauss
c           ===========================================================
c           loop over l1,m1............................................
c           ===========================================================
            lm1=0
	    do l1=0,lmax
               zlm1=matom_left(l1)*bj(l1)-eiz*bh(l1)
               jlm1=eiz*bh(l1)/matom_left(l1)
	    do m1=-l1,l1
	      lm1=lm1+1
	       zljl=0.d0
c              ========================================================
c              loop over l2,m2.........................................
	       lm2=0
	       do l2=0,lmax
                  zlm2=matom_right(l2)*bj(l2)-eiz*bh(l2)
	       do m2=-l2,l2
		 lm2=lm2+1
c                 =====================================================
c                 perform sum over l3,m3 with gaunt # and gaussian wt..
		  zlzl=0.d0
                     m3=m1-m2
                  do l3=l1+l2,max(abs(m3),abs(l1-l2)),-2
                     iwylm= (l3*(l3+1))/2 + abs(m3) +1
c theta(r) is formed with sum_lm3 steplm*Ylm
c  cgnt(lm,lmp,lmpp)=int dO Y(lm),Y(lmp),Y(lmpp)^*
                     if(m3.ge.0) then
                        steplm=wylm(iwylm,ng,ir)
                     else
                        steplm=(1-2*mod(abs(m3),2))*
     &                     conjg(wylm(iwylm,ng,ir))
                     endif
		     if(l3.eq.0) then
		     if(abs(rgauss-r_sph).lt.1.d-10) then
		       steplm=steplm-0.5d0*rt4pi
		     else if(rgauss.lt.r_sph) then
		       steplm=steplm-rt4pi
		     endif
		     endif
                     zlzl=zlzl+cgnt(l3/2+1,lm2,lm1)*steplm
                     if(lm2.eq.lm1 .and. zj_flag.eq.1) then
                        zljl=zljl+cgnt(l3/2+1,lm2,lm1)*steplm
                     endif
                  enddo
                  pzz(lm2,lm1)=pzz(lm2,lm1)+zlzl*zlm1*zlm2*gwwylm(ng,ir)
               enddo
               enddo
               pzj=pzj+zljl*zlm1*jlm1*gwwylm(ng,ir)
            enddo
            enddo
	    endif  !  rgauss.gt.zero
         enddo
      enddo
c
      return
      end


      SUBROUTINE TG01JD( JOB, SYSTYP, EQUIL, N, M, P, A, LDA, E, LDE,
     $                   B, LDB, C, LDC, NR, INFRED, TOL, IWORK, DWORK,
     $                   LDWORK, INFO )
C
C     SLICOT RELEASE 5.7.
C
C     Copyright (c) 2002-2020 NICONET e.V.
C
C     PURPOSE
C
C     To find a reduced (controllable, observable, or irreducible)
C     descriptor representation (Ar-lambda*Er,Br,Cr) for an original
C     descriptor representation (A-lambda*E,B,C).
C     The pencil Ar-lambda*Er is in an upper block Hessenberg form, with
C     either Ar or Er upper triangular.
C
C     ARGUMENTS
C
C     Mode Parameters
C
C     JOB     CHARACTER*1
C             Indicates whether the user wishes to remove the
C             uncontrollable and/or unobservable parts as follows:
C             = 'I':  Remove both the uncontrollable and unobservable
C                     parts to get an irreducible descriptor
C                     representation;
C             = 'C':  Remove the uncontrollable part only to get a
C                     controllable descriptor representation;
C             = 'O':  Remove the unobservable part only to get an
C                     observable descriptor representation.
C
C     SYSTYP  CHARACTER*1
C             Indicates the type of descriptor system algorithm
C             to be applied according to the assumed
C             transfer-function matrix as follows:
C             = 'R':  Rational transfer-function matrix;
C             = 'S':  Proper (standard) transfer-function matrix;
C             = 'P':  Polynomial transfer-function matrix.
C
C     EQUIL   CHARACTER*1
C             Specifies whether the user wishes to preliminarily scale
C             the system (A-lambda*E,B,C) as follows:
C             = 'S':  Perform scaling;
C             = 'N':  Do not perform scaling.
C
C     Input/Output Parameters
C
C     N       (input) INTEGER
C             The dimension of the descriptor state vector; also the
C             order of square matrices A and E, the number of rows of
C             matrix B, and the number of columns of matrix C.  N >= 0.
C
C     M       (input) INTEGER
C             The dimension of descriptor system input vector; also the
C             number of columns of matrix B.  M >= 0.
C
C     P       (input) INTEGER
C             The dimension of descriptor system output vector; also the
C             number of rows of matrix C.  P >= 0.
C
C     A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
C             On entry, the leading N-by-N part of this array must
C             contain the original state matrix A.
C             On exit, the leading NR-by-NR part of this array contains
C             the reduced order state matrix Ar of an irreducible,
C             controllable, or observable realization for the original
C             system, depending on the value of JOB, JOB = 'I',
C             JOB = 'C', or JOB = 'O', respectively.
C             The matrix Ar is upper triangular if SYSTYP = 'R' or 'P'.
C             If SYSTYP = 'S' and JOB = 'C', the matrix [Br Ar]
C             is in a controllable staircase form (see TG01HD).
C             If SYSTYP = 'S' and JOB = 'I' or 'O', the matrix ( Ar )
C                                                              ( Cr )
C             is in an observable staircase form (see TG01HD).
C             The block structure of staircase forms is contained
C             in the leading INFRED(7) elements of IWORK.
C
C     LDA     INTEGER
C             The leading dimension of array A.  LDA >= MAX(1,N).
C
C     E       (input/output) DOUBLE PRECISION array, dimension (LDE,N)
C             On entry, the leading N-by-N part of this array must
C             contain the original descriptor matrix E.
C             On exit, the leading NR-by-NR part of this array contains
C             the reduced order descriptor matrix Er of an irreducible,
C             controllable, or observable realization for the original
C             system, depending on the value of JOB, JOB = 'I',
C             JOB = 'C', or JOB = 'O', respectively.
C             The resulting Er has INFRED(6) nonzero sub-diagonals.
C             If at least for one k = 1,...,4, INFRED(k) >= 0, then the
C             resulting Er is structured being either upper triangular
C             or block Hessenberg, in accordance to the last
C             performed order reduction phase (see METHOD).
C             The block structure of staircase forms is contained
C             in the leading INFRED(7) elements of IWORK.
C
C     LDE     INTEGER
C             The leading dimension of array E.  LDE >= MAX(1,N).
C
C     B       (input/output) DOUBLE PRECISION array, dimension (LDB,M),
C             if JOB = 'C', or (LDB,MAX(M,P)), otherwise.
C             On entry, the leading N-by-M part of this array must
C             contain the original input matrix B; if JOB = 'I',
C             or JOB = 'O', the remainder of the leading N-by-MAX(M,P)
C             part is used as internal workspace.
C             On exit, the leading NR-by-M part of this array contains
C             the reduced input matrix Br of an irreducible,
C             controllable, or observable realization for the original
C             system, depending on the value of JOB, JOB = 'I',
C             JOB = 'C', or JOB = 'O', respectively.
C             If JOB = 'C', only the first IWORK(1) rows of B are
C             nonzero.
C
C     LDB     INTEGER
C             The leading dimension of array B.  LDB >= MAX(1,N).
C
C     C       (input/output) DOUBLE PRECISION array, dimension (LDC,N)
C             On entry, the leading P-by-N part of this array must
C             contain the original output matrix C; if JOB = 'I',
C             or JOB = 'O', the remainder of the leading MAX(M,P)-by-N
C             part is used as internal workspace.
C             On exit, the leading P-by-NR part of this array contains
C             the transformed state/output matrix Cr of an irreducible,
C             controllable, or observable realization for the original
C             system, depending on the value of JOB, JOB = 'I',
C             JOB = 'C', or JOB = 'O', respectively.
C             If JOB = 'I', or JOB = 'O', only the last IWORK(1) columns
C             (in the first NR columns) of C are nonzero.
C
C     LDC     INTEGER
C             The leading dimension of array C.
C             LDC >= MAX(1,M,P) if N > 0.
C             LDC >= 1          if N = 0.
C
C     NR      (output) INTEGER
C             The order of the reduced descriptor representation
C             (Ar-lambda*Er,Br,Cr) of an irreducible, controllable,
C             or observable realization for the original system,
C             depending on JOB = 'I', JOB = 'C', or JOB = 'O',
C             respectively.
C
C     INFRED  (output) INTEGER array, dimension 7
C             This array contains information on performed reduction
C             and on structure of resulting system matrices as follows:
C             INFRED(k) >= 0 (k = 1, 2, 3, or 4) if Phase k of reduction
C                            (see METHOD) has been performed. In this
C                            case, INFRED(k) is the achieved order
C                            reduction in Phase k.
C             INFRED(k) < 0  (k = 1, 2, 3, or 4) if Phase k was not
C                            performed.
C             INFRED(5)  -   the number of nonzero sub-diagonals of A.
C             INFRED(6)  -   the number of nonzero sub-diagonals of E.
C             INFRED(7)  -   the number of blocks in the resulting
C                            staircase form at last performed reduction
C                            phase. The block dimensions are contained
C                            in the first INFRED(7) elements of IWORK.
C
C     Tolerances
C
C     TOL     DOUBLE PRECISION
C             The tolerance to be used in rank determinations when
C             transforming (A-lambda*E,B,C). If the user sets TOL > 0,
C             then the given value of TOL is used as a lower bound for
C             reciprocal condition numbers in rank determinations; a
C             (sub)matrix whose estimated condition number is less than
C             1/TOL is considered to be of full rank.  If the user sets
C             TOL <= 0, then an implicitly computed, default tolerance,
C             defined by  TOLDEF = N*N*EPS,  is used instead, where
C             EPS is the machine precision (see LAPACK Library routine
C             DLAMCH).  TOL < 1.
C
C     Workspace
C
C     IWORK   INTEGER array, dimension ((c*N+MAX(M,P)), where
C             c = 2, if JOB = 'I' or SYSTYP = 'R', and c = 1, otherwise.
C             On exit, if INFO = 0, the leading INFRED(7) elements of
C             IWORK contain the orders of the diagonal blocks of
C             Ar-lambda*Er.
C
C     DWORK   DOUBLE PRECISION array, dimension (LDWORK)
C
C     LDWORK  INTEGER
C             The length of the array DWORK.
C             LDWORK >= MAX(8*N,2*M,2*P), if EQUIL = 'S';
C             LDWORK >= MAX(N,2*M,2*P),   if EQUIL = 'N'.
C             If LDWORK >= 2*N*N+N*M+N*P+MAX(N,2*M,2*P) then more
C             accurate results are to be expected by performing only
C             those reductions phases (see METHOD), where effective
C             order reduction occurs. This is achieved by saving the
C             system matrices before each phase and restoring them if no
C             order reduction took place.
C
C     Error Indicator
C
C     INFO    INTEGER
C             = 0:  successful exit;
C             < 0:  if INFO = -i, the i-th argument had an illegal
C                   value.
C
C     METHOD
C
C     The subroutine is based on the reduction algorithms of [1].
C     The order reduction is performed in 4 phases:
C     Phase 1: Eliminate all finite uncontrollable eigenvalues.
C              The resulting matrix ( Br Ar ) is in a controllable
C              staircase form (see SLICOT Library routine TG01HD), and
C              Er is upper triangular.
C              This phase is performed if JOB = 'I' or 'C' and
C              SYSTYP = 'R' or 'S'.
C     Phase 2: Eliminate all infinite and finite nonzero uncontrollable
C              eigenvalues. The resulting matrix ( Br Er ) is in a
C              controllable staircase form (see TG01HD), and Ar is
C              upper triangular.
C              This phase is performed if JOB = 'I' or 'C' and
C              SYSTYP = 'R' or 'P'.
C     Phase 3: Eliminate all finite unobservable eigenvalues.
C              The resulting matrix ( Ar ) is in an observable
C                                   ( Cr )
C              staircase form (see SLICOT Library routine TG01ID), and
C              Er is upper triangular.
C              This phase is performed if JOB = 'I' or 'O' and
C              SYSTYP = 'R' or 'S'.
C     Phase 4: Eliminate all infinite and finite nonzero unobservable
C              eigenvalues. The resulting matrix ( Er ) is in an
C                                                ( Cr )
C              observable staircase form (see TG01ID), and Ar is
C              upper triangular.
C              This phase is performed if JOB = 'I' or 'O' and
C              SYSTYP = 'R' or 'P'.
C
C     REFERENCES
C
C     [1] A. Varga
C         Computation of Irreducible Generalized State-Space
C         Realizations.
C         Kybernetika, vol. 26, pp. 89-106, 1990.
C
C     NUMERICAL ASPECTS
C
C     The algorithm is numerically backward stable and requires
C     0( N**3 )  floating point operations.
C
C     FURTHER COMMENTS
C
C     If the pencil (A-lambda*E) has no zero eigenvalues, then an
C     irreducible realization can be computed skipping Phases 1 and 3
C     by using the setting: JOB = 'I' and SYSTYP = 'P'.
C
C     CONTRIBUTOR
C
C     A. Varga, German Aerospace Center, DLR Oberpfaffenhofen.
C     April 1999. Based on the RASP routine RPDSIR.
C
C     REVISIONS
C
C     July 1999, V. Sima, Research Institute for Informatics, Bucharest.
C     May 2003, A. Varga, German Aerospace Center, DLR Oberpfaffenhofen.
C     May 2003, March 2004, March 2017, April 2017, V. Sima.
C
C     KEYWORDS
C
C     Controllability, irreducible realization, observability,
C     orthogonal canonical form, orthogonal transformation.
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION   ONE, ZERO
      PARAMETER          ( ONE = 1.0D0, ZERO = 0.0D0 )
C     .. Scalar Arguments ..
      CHARACTER         EQUIL, JOB, SYSTYP
      INTEGER           INFO, LDA, LDB, LDC, LDE, LDWORK, M, N, NR, P
      DOUBLE PRECISION  TOL
C     .. Array Arguments ..
      INTEGER           INFRED(*), IWORK(*)
      DOUBLE PRECISION  A(LDA,*), B(LDB,*), C(LDC,*), DWORK(*), E(LDE,*)
C     .. Local Scalars ..
      CHARACTER         JOBQ, JOBZ
      LOGICAL           DONE1, DONE2, DONE3, FINCON, FINOBS, INFCON,
     $                  INFOBS, LEQUIL, LJOBC, LJOBIR, LJOBO, LSPACE,
     $                  LSYSP, LSYSR, LSYSS
      INTEGER           I, IB, KWA, KWB, KWC, KWE, LBA, LBE, LDM, LDP,
     $                  LDQ, LDZ, M1, MAXMP, N1, NBLCK, NC, P1
C     .. Local Arrays ..
      DOUBLE PRECISION  DUM(1)
C     .. External Functions ..
      LOGICAL           LSAME
      EXTERNAL          LSAME
C     .. External Subroutines ..
      EXTERNAL          DLACPY, MA02CD, TB01XD, TG01AD, TG01HX, XERBLA
C     .. Intrinsic Functions ..
      INTRINSIC         MAX
C     .. Executable Statements ..
C
      INFO  = 0
      MAXMP = MAX( M, P )
      N1    = MAX( 1, N )
C
C     Decode JOB.
C
      LJOBIR = LSAME( JOB, 'I' )
      LJOBC  = LJOBIR .OR. LSAME( JOB, 'C' )
      LJOBO  = LJOBIR .OR. LSAME( JOB, 'O' )
C
C     Decode SYSTYP.
C
      LSYSR  = LSAME( SYSTYP, 'R' )
      LSYSS  = LSYSR .OR. LSAME( SYSTYP, 'S' )
      LSYSP  = LSYSR .OR. LSAME( SYSTYP, 'P' )
C
      LEQUIL =  LSAME( EQUIL, 'S' )
C
C     Test the input scalar arguments.
C
      IF( .NOT.LJOBC .AND. .NOT.LJOBO ) THEN
         INFO = -1
      ELSE IF( .NOT.LSYSS .AND. .NOT.LSYSP ) THEN
         INFO = -2
      ELSE IF( .NOT.LEQUIL .AND. .NOT.LSAME( EQUIL, 'N' ) ) THEN
         INFO = -3
      ELSE IF( N.LT.0 ) THEN
         INFO = -4
      ELSE IF( M.LT.0 ) THEN
         INFO = -5
      ELSE IF( P.LT.0 ) THEN
         INFO = -6
      ELSE IF( LDA.LT.N1 ) THEN
         INFO = -8
      ELSE IF( LDE.LT.N1 ) THEN
         INFO = -10
      ELSE IF( LDB.LT.N1 ) THEN
         INFO = -12
      ELSE IF( LDC.LT.1 .OR. ( N.GT.0 .AND. LDC.LT.MAXMP ) ) THEN
         INFO = -14
      ELSE IF( TOL.GE.ONE ) THEN
         INFO = -17
      ELSE IF( ( .NOT.LEQUIL .AND. LDWORK.LT.MAX( N, 2*MAXMP ) ) .OR.
     $         ( LEQUIL .AND. LDWORK.LT.MAX( 8*N, 2*MAXMP ) ) ) THEN
         INFO = -20
      END IF
C
      IF ( INFO.NE.0 ) THEN
C
C        Error return.
C
         CALL XERBLA( 'TG01JD', -INFO )
         RETURN
      END IF
C
C     Quick return if possible.
C
      INFRED(1) = -1
      INFRED(2) = -1
      INFRED(3) = -1
      INFRED(4) = -1
      INFRED(5) =  0
      INFRED(6) =  0
      INFRED(7) =  0
C
      IF( MAX( N, MAXMP ).EQ.0 ) THEN
         NR = 0
         RETURN
      END IF
C
      M1  = MAX( 1, M )
      P1  = MAX( 1, P )
      LDM = MAX( LDC, M )
      LDP = MAX( LDC, P )
C
C     Set controllability/observability determination options.
C
      FINCON = LJOBC .AND. LSYSS
      INFCON = LJOBC .AND. LSYSP
      FINOBS = LJOBO .AND. LSYSS
      INFOBS = LJOBO .AND. LSYSP
C
C     Set large workspace option and determine offsets.
C
      LSPACE = LDWORK.GE.N*( 2*N + M + P ) + MAX( N, 2*MAXMP )
      KWA = MAX( N, 2*MAXMP ) + 1
      KWE = KWA + N*N
      KWB = KWE + N*N
      KWC = KWB + N*M
C
C     If required, scale the system (A-lambda*E,B,C).
C     Workspace: need 8*N.
C
      IF( LEQUIL ) THEN
         CALL TG01AD( 'All', N, N, M, P, ZERO, A, LDA, E, LDE, B, LDB,
     $                C, LDP, DWORK(1), DWORK(N+1), DWORK(2*N+1), INFO )
      END IF
C
      JOBQ = 'N'
      JOBZ = 'N'
      LDQ = 1
      LDZ = 1
      LBA = MAX( 0, N-1 )
      LBE = LBA
      NC = N
      NR = N
      IB = 1
C
      DONE1 = .FALSE.
      DONE2 = .FALSE.
      DONE3 = .FALSE.
C
      IF( FINCON ) THEN
C
C        Phase 1: Eliminate all finite uncontrollable eigenvalues.
C
         IF( LSPACE ) THEN
C
C           Save system matrices.
C
            CALL DLACPY( 'Full', NC, NC, A, LDA, DWORK(KWA), N1 )
            CALL DLACPY( 'Full', NC, NC, E, LDE, DWORK(KWE), N1 )
            CALL DLACPY( 'Full', NC, M,  B, LDB, DWORK(KWB), N1 )
            CALL DLACPY( 'Full', P,  NC, C, LDC, DWORK(KWC), P1 )
         END IF
C
C        Perform finite controllability form reduction.
C        Workspace: need   MAX(N,2*M).
C
         CALL TG01HX( JOBQ, JOBZ, NC, NC, M, P, NC, LBE, A, LDA,
     $                E, LDE, B, LDB, C, LDP, DUM, LDQ, DUM, LDZ, NR,
     $                NBLCK, IWORK, TOL, IWORK(N+1), DWORK, INFO )
         DONE1 = NR.LT.NC .OR. .NOT.LSPACE
         IF( DONE1 ) THEN
            IF( NBLCK.GT.1 ) THEN
               LBA = IWORK(1) + IWORK(2) - 1
            ELSE IF( NBLCK.EQ.1 ) THEN
               LBA = IWORK(1) - 1
            ELSE
               LBA = 0
            END IF
            LBE = 0
            INFRED(1) = NC - NR
            INFRED(7) = NBLCK
            NC = NR
            IB = N + 1
         ELSE
C
C           Restore system matrices.
C
            CALL DLACPY( 'Full', NC, NC, DWORK(KWA), N1, A, LDA )
            CALL DLACPY( 'Full', NC, NC, DWORK(KWE), N1, E, LDE )
            CALL DLACPY( 'Full', NC, M,  DWORK(KWB), N1, B, LDB )
            CALL DLACPY( 'Full', P,  NC, DWORK(KWC), P1, C, LDC )
         END IF
      END IF
C
      IF( INFCON ) THEN
C
C        Phase 2: Eliminate all infinite and all finite nonzero
C                 uncontrollable eigenvalues.
C
         IF( LSPACE .AND. ( .NOT.FINCON .OR. DONE1 ) ) THEN
C
C           Save system matrices.
C
            CALL DLACPY( 'Full', NC, NC, A, LDA, DWORK(KWA), N1 )
            CALL DLACPY( 'Full', NC, NC, E, LDE, DWORK(KWE), N1 )
            CALL DLACPY( 'Full', NC, M,  B, LDB, DWORK(KWB), N1 )
            CALL DLACPY( 'Full', P,  NC, C, LDC, DWORK(KWC), P1 )
         END IF
C
C        Perform infinite controllability form reduction.
C        Workspace: need   MAX(N,2*M).
C
         CALL TG01HX( JOBQ, JOBZ, NC, NC, M, P, NC, LBA, E, LDE,
     $                A, LDA, B, LDB, C, LDP, DUM, LDQ, DUM, LDZ, NR,
     $                NBLCK, IWORK(IB), TOL, IWORK(IB+N), DWORK, INFO )
         DONE2 = NR.LT.NC .OR. .NOT.LSPACE
         IF( DONE2 ) THEN
            IF( NBLCK.GT.1 ) THEN
               LBE = IWORK(IB) + IWORK(IB+1) - 1
            ELSE IF( NBLCK.EQ.1 ) THEN
               LBE = IWORK(IB) - 1
            ELSE
               LBE = 0
            END IF
            LBA = 0
            INFRED(2) = NC - NR
            INFRED(7) = NBLCK
            NC = NR
            IF ( DONE1 ) THEN
               DO 10 I = 1, NBLCK
                  IWORK(I) = IWORK(IB+I-1)
   10          CONTINUE
            ELSE
               IB = N + 1
            END IF
         ELSE
C
C           Restore system matrices.
C
            CALL DLACPY( 'Full', NC, NC, DWORK(KWA), N1, A, LDA )
            CALL DLACPY( 'Full', NC, NC, DWORK(KWE), N1, E, LDE )
            CALL DLACPY( 'Full', NC, M,  DWORK(KWB), N1, B, LDB )
            CALL DLACPY( 'Full', P,  NC, DWORK(KWC), P1, C, LDC )
         END IF
      END IF
C
      IF( FINOBS .OR. INFOBS ) THEN
C
C        Compute the pertransposed dual system exploiting matrix shapes.
C
         CALL TB01XD( 'Z', NC, M, P, LBA, MAX( 0, NC-1 ), A, LDA,
     $                B, LDB, C, LDC, DUM, 1, INFO )
         CALL MA02CD( NC, LBE, MAX( 0, NC-1 ), E, LDE )
      END IF
C
      IF( FINOBS ) THEN
C
C        Phase 3: Eliminate all finite unobservable eigenvalues.
C
         IF( LSPACE ) THEN
C
C           Save system matrices.
C
            CALL DLACPY( 'Full', NC, NC, A, LDA, DWORK(KWA), N1 )
            CALL DLACPY( 'Full', NC, NC, E, LDE, DWORK(KWE), N1 )
            CALL DLACPY( 'Full', NC, P,  B, LDB, DWORK(KWC), N1 )
            CALL DLACPY( 'Full', M,  NC, C, LDC, DWORK(KWB), M1 )
         END IF
C
C        Perform finite observability form reduction.
C        Workspace: need   MAX(N,2*P).
C
         CALL TG01HX( JOBZ, JOBQ, NC, NC, P, M, NC, LBE, A, LDA,
     $                E, LDE, B, LDB, C, LDM, DUM, LDZ, DUM, LDQ, NR,
     $                NBLCK, IWORK(IB), TOL, IWORK(IB+N), DWORK, INFO )
         DONE3 = NR.LT.NC .OR. .NOT.LSPACE
         IF( DONE3 ) THEN
            IF( NBLCK.GT.1 ) THEN
               LBA = IWORK(IB) + IWORK(IB+1) - 1
            ELSE IF( NBLCK.EQ.1 ) THEN
               LBA = IWORK(IB) - 1
            ELSE
               LBA = 0
            END IF
            LBE = 0
            INFRED(3) = NC - NR
            INFRED(7) = NBLCK
            NC = NR
            IF ( DONE1 .OR. DONE2 ) THEN
               DO 20 I = 1, NBLCK
                  IWORK(I) = IWORK(IB+I-1)
   20          CONTINUE
            ELSE
               IB = N + 1
            END IF
         ELSE
C
C           Restore system matrices.
C
            CALL DLACPY( 'Full', NC, NC, DWORK(KWA), N1, A, LDA )
            CALL DLACPY( 'Full', NC, NC, DWORK(KWE), N1, E, LDE )
            CALL DLACPY( 'Full', NC, P,  DWORK(KWC), N1, B, LDB )
            CALL DLACPY( 'Full', M,  NC, DWORK(KWB), M1, C, LDC )
         END IF
      END IF
C
      IF( INFOBS ) THEN
C
C        Phase 4: Eliminate all infinite and all finite nonzero
C                 unobservable eigenvalues.
C
         IF( LSPACE .AND. ( .NOT.FINOBS .OR. DONE3 ) ) THEN
C
C
C           Save system matrices.
C
            CALL DLACPY( 'Full', NC, NC, A, LDA, DWORK(KWA), N1 )
            CALL DLACPY( 'Full', NC, NC, E, LDE, DWORK(KWE), N1 )
            CALL DLACPY( 'Full', NC, P,  B, LDB, DWORK(KWC), N1 )
            CALL DLACPY( 'Full', M,  NC, C, LDC, DWORK(KWB), M1 )
         END IF
C
C        Perform infinite observability form reduction.
C        Workspace: need   MAX(N,2*P).
C
         CALL TG01HX( JOBZ, JOBQ, NC, NC, P, M, NC, LBA, E, LDE,
     $                A, LDA, B, LDB, C, LDM, DUM, LDZ, DUM, LDQ, NR,
     $                NBLCK, IWORK(IB), TOL, IWORK(IB+N), DWORK, INFO )
         IF( NR.LT.NC .OR. .NOT.LSPACE ) THEN
            IF( NBLCK.GT.1 ) THEN
               LBE = IWORK(IB) + IWORK(IB+1) - 1
            ELSE IF( NBLCK.EQ.1 ) THEN
               LBE = IWORK(IB) - 1
            ELSE
               LBE = 0
            END IF
            LBA = 0
            INFRED(4) = NC - NR
            INFRED(7) = NBLCK
            NC = NR
            IF ( DONE1 .OR. DONE2 .OR. DONE3 ) THEN
               DO 30 I = 1, NBLCK
                  IWORK(I) = IWORK(IB+I-1)
   30          CONTINUE
            END IF
         ELSE
C
C           Restore system matrices.
C
            CALL DLACPY( 'Full', NC, NC, DWORK(KWA), N1, A, LDA )
            CALL DLACPY( 'Full', NC, NC, DWORK(KWE), N1, E, LDE )
            CALL DLACPY( 'Full', NC, P,  DWORK(KWC), N1, B, LDB )
            CALL DLACPY( 'Full', M,  NC, DWORK(KWB), M1, C, LDC )
         END IF
      END IF
C
      IF( FINOBS .OR. INFOBS ) THEN
C
C        Compute the pertransposed dual system exploiting matrix shapes.
C
         CALL TB01XD( 'Z', NC, P, M, LBA, MAX( 0, NC-1 ), A, LDA,
     $                B, LDB, C, LDC, DUM, 1, INFO )
         CALL MA02CD( NC, LBE, MAX( 0, NC-1 ), E, LDE )
      END IF
C
C     Set structural information on A and E.
C
      INFRED(5) = LBA
      INFRED(6) = LBE
C
      RETURN
C *** Last line of TG01JD ***
      END


c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1999  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ################################################################
c     ##                                                            ##
c     ##  function geometry  --  evaluate distance, angle, torsion  ##
c     ##                                                            ##
c     ################################################################
c
c
c     "geometry" finds the value of the interatomic distance, angle
c     or dihedral angle defined by two to four input atoms
c
c
      function geometry (ia,ib,ic,id)
      implicit none
      include 'sizes.i'
      include 'atoms.i'
      include 'math.i'
      integer ia,ib,ic,id
      real*8 xab,yab,zab
      real*8 xba,yba,zba
      real*8 xcb,ycb,zcb
      real*8 xdc,ydc,zdc
      real*8 xt,yt,zt
      real*8 xu,yu,zu
      real*8 rab2,rcb2,rabc
      real*8 rt2,ru2,rtru
      real*8 cosine,sign
      real*8 geometry
c
c
c     set default in case atoms are coincident or colinear
c
      geometry = 0.0d0
c
c     compute the value of the distance in angstroms
c
      if (ic .eq. 0) then
         xab = x(ia) - x(ib)
         yab = y(ia) - y(ib)
         zab = z(ia) - z(ib)
         geometry = sqrt(xab*xab + yab*yab + zab*zab)
c
c     compute the value of the angle in degrees
c
      else if (id .eq. 0) then
         xab = x(ia) - x(ib)
         yab = y(ia) - y(ib)
         zab = z(ia) - z(ib)
         xcb = x(ic) - x(ib)
         ycb = y(ic) - y(ib)
         zcb = z(ic) - z(ib)
         rab2 = xab*xab + yab*yab + zab*zab
         rcb2 = xcb*xcb + ycb*ycb + zcb*zcb
         rabc = sqrt(rab2 * rcb2)
         if (rabc .ne. 0.0d0) then
            cosine = (xab*xcb + yab*ycb + zab*zcb) / rabc
            cosine = min(1.0d0,max(-1.0d0,cosine))
            geometry = radian * acos(cosine)
         end if
c
c     compute the value of the dihedral angle in degrees
c
      else
         xba = x(ib) - x(ia)
         yba = y(ib) - y(ia)
         zba = z(ib) - z(ia)
         xcb = x(ic) - x(ib)
         ycb = y(ic) - y(ib)
         zcb = z(ic) - z(ib)
         xdc = x(id) - x(ic)
         ydc = y(id) - y(ic)
         zdc = z(id) - z(ic)
         xt = yba*zcb - ycb*zba
         yt = xcb*zba - xba*zcb
         zt = xba*ycb - xcb*yba
         xu = ycb*zdc - ydc*zcb
         yu = xdc*zcb - xcb*zdc
         zu = xcb*ydc - xdc*ycb
         rt2 = xt*xt + yt*yt + zt*zt
         ru2 = xu*xu + yu*yu + zu*zu
         rtru = sqrt(rt2 * ru2)
         if (rtru .ne. 0.0d0) then
            cosine = (xt*xu + yt*yu + zt*zu) / rtru
            cosine = min(1.0d0,max(-1.0d0,cosine))
            geometry = radian * acos(cosine)
            sign = xba*xu + yba*yu + zba*zu
            if (sign .lt. 0.0d0)  geometry = -geometry
         end if
      end if
      return
      end


program test_get_grid_z

  use bmif_2_0, only: BMI_FAILURE
  use bmiheatf
  use fixtures, only: config_file, status

  implicit none

  integer, parameter :: grid_id = 1
  integer, parameter :: nz = 1
  double precision, parameter, dimension(nz) :: expected_z = (/ 0.0 /)

  type (bmi_heat) :: m
  double precision, dimension(nz) :: grid_z
  integer :: i

  status = m%initialize(config_file)
  status = m%get_grid_z(grid_id, grid_z)
  status = m%finalize()

  print *, grid_z
  print *, expected_z

  do i = 1, nz
     if (grid_z(i).ne.expected_z(i)) then
        stop BMI_FAILURE
     end if
  end do
end program test_get_grid_z


!*robodoc*u* tests/testACA
!  NAME
!    testACA
!  SYNOPSIS

!$Id: testACA.f90 526 2018-03-25 23:44:51Z mexas $

program testACA

!  PURPOSE
!    Testing cgca_m2gl/cgca_ico.
!  DESCRIPTION
!    cgca_ico converts some image index into its cosubscripts.
!    Lots of data has to be set prior to calling cgca_ico.
!    The test can be run on any number of images.
!    space coarray is established and the cgca_ico is called
!    using its cosubscripts.
!  AUTHOR
!    Anton Shterenlikht
!  COPYRIGHT
!    See LICENSE
!  USES
!    cgca testaux
!  USED BY
!    Part of CGPACK test suite
!  SOURCE

use testaux

implicit none

integer( kind=idef ) :: ir( cgca_scodim ), img, nimgs, flag, ind,      &
 ng,      & ! number of grains in the whole model
 cosub( cgca_scodim ), c( cgca_scodim )  ! coarray dimensions

integer( kind=iarr ), allocatable :: space(:,:,:,:) [:,:,:]

integer( kind=ilrg ) :: icells, mcells

real( kind=rdef ) ::    &
 qual,                  & ! quality
 bsz0(3),               & ! the given "box" size
 bsz(3),                & ! updated "box" size
 dm,                    & ! mean grain size, linear dim, phys units
 lres,                  & ! linear resolution, cells per unit of length
 res                      ! resolutions, cells per grain

!*********************************************************************72
! first executable statement

! physical dimensions of the box, assume mm
bsz0 = (/ 1.0, 2.0, 3.0 /)

! mean grain size, linear dimension, e.g. mean grain diameter, also mm
dm = 5.0e-1

! resolution
res = 1.0e5

! In this test set the number of images via the env var
! the code must be able to cope with any value >= 1.
   img = this_image()
 nimgs = num_images()

! do a check on image 1
if ( img .eq. 1 ) then
  ! print a banner
  call banner("ACA")
  ! print the parameter values
  call cgca_pdmp
  write (*,'(a,i0,a)') "running on ", nimgs, " images in a 3D grid"
end if

! want to sync here to make sure the banner is
! printed before the rest.
sync all

! each image calculates the coarray grid dimensions
call cgca_gdim( nimgs, ir, qual )

! calculate the resolution and the actual phys dimensions
! of the box
! subroutine cgca_cadim( bsz, res, dm, ir, c, lres, ng )
! c - coarray sizes
! ir - coarray grid sizes
bsz = bsz0
call cgca_cadim( bsz, res, dm, ir, c, lres, ng )

! total number of cells in a coarray
icells = int( c(1), kind=ilrg ) * int( c(2), kind=ilrg ) *             &
         int( c(3), kind=ilrg )

! total number of cells in the model
mcells = icells * int( nimgs, kind=ilrg )

if ( img .eq. 1 ) then
  write ( *, "(9(a,i0),tr1,g10.3,tr1,g10.3,3(a,g10.3),a)" )            &
    "img: ", img  , " nimgs: ", nimgs, " (", c(1) ,                    &
    ","    , c(2) , ","       , c(3) , ")[", ir(1),                    &
    ","    , ir(2), ","       , ir(3), "] ", ng   ,                    &
    qual, lres,                                                        &
    " (", bsz(1), ",", bsz(2), ",", bsz(3), ")"
  write (*,'(a,i0,a)') "Each image has ",icells, " cells"
  write (*,'(a,i0,a)') "The model has ", mcells, " cells"
end if

! allocate space coarray with a single layer
! implicit sync all
!subroutine cgca_as( l1, u1, l2, u2, l3, u3, col1, cou1, col2, cou2,   &
!                    col3, props, coarray )
call cgca_as(1, c(1), 1, c(2), 1, c(3), 1, ir(1), 1, ir(2), 1, 1, space)

! check cgca_ico on the last image
! make only image 1 do this.
if ( img .eq. 1 ) then

  ! Dump lower and upper cobounds
  write (*,*) "cgca_slcob:", cgca_slcob
  write (*,*) "cgca_sucob:", cgca_sucob

  ! Calculate subscripts for all indices and check
  do ind = 1, num_images()
    call cgca_ico( ind, cosub, flag )
    if ( flag .ne. 0 ) then
      write (*,*) "ERROR: cgca_ico returned flag:", flag
      stop
    end if

    write (*,*) "index=", ind, "cosub:", cosub

    ! check
    if ( image_index( space, cosub ) .ne. ind ) then
      write (*,*) "ERROR: testACA failed: cgca_ico calculated wrong values"
    end if

  end do

end if

sync all

! deallocate all arrays
call cgca_ds( space )

end program testACA

!*roboend*


program main

  ! These modules are all in BoxLib/Src/F_BaseLib
  use boxlib
  use multifab_module
  use bl_IO_module

  ! These modules are all in this directory
  use init_data_module
  use write_plotfile_module
  use advance_module

  implicit none

  ! stuff you can set with the inputs file (otherwise use default values below)
  integer :: dim, nsteps, plot_int, n_cell, max_grid_size, verbose

  ! dummy indices using for reading in inputs file
  integer :: un, farg, narg
  logical :: need_inputs_file, found_inputs_file
  character(len=128) :: inputs_file_name

  integer, allocatable :: lo(:), hi(:)
  integer :: istep

  real(dp_t), allocatable :: prob_lo(:), prob_hi(:)
  real(dp_t) :: dx, dt, time, start_time, run_time, run_time_IOproc

  logical, allocatable :: is_periodic(:)

  type(box)      :: bx
  type(boxarray) :: ba
  type(layout)   :: la
  type(multifab) :: data

  namelist /probin/ dim, nsteps, plot_int, n_cell, max_grid_size, verbose

  ! if running in parallel, this will print out the number of MPI
  ! processes and OpenMP threads
  call boxlib_initialize()

  ! parallel_wtime() returns the number of wallclock-time seconds since
  ! the program began
  start_time = parallel_wtime()

  ! default values - will get overwritten by the inputs file
  dim           = 2
  nsteps        = 10
  plot_int      = 1
  n_cell        = 64
  max_grid_size = 32
  verbose       = 0

  ! read inputs file and overwrite any default values
  narg = command_argument_count()
  need_inputs_file = .true.
  farg = 1
  if ( need_inputs_file .AND. narg >= 1 ) then
     call get_command_argument(farg, value = inputs_file_name)
     inquire(file = inputs_file_name, exist = found_inputs_file )
     if ( found_inputs_file ) then
        farg = farg + 1
        un = unit_new()
        open(unit=un, file = inputs_file_name, status = 'old', action = 'read')
        read(unit=un, nml = probin)
        close(unit=un)
        need_inputs_file = .false.
     end if
  end if

  ! now that we have dim, we can allocate these
  allocate(lo(dim),hi(dim))
  allocate(is_periodic(dim))
  allocate(prob_lo(dim),prob_hi(dim))

  ! physical problem is a box on (-1,-1) to (1,1), periodic on all sides
  prob_lo(:) = -1.d0
  prob_hi(:) =  1.d0
  is_periodic(:) = .true.

  ! create a box from (0,0) to (n_cell-1,n_cell-1)
  lo(:) = 0
  hi(:) = n_cell-1
  bx = make_box(lo,hi)

  ! the grid spacing is the same in each direction
  dx = (prob_hi(1)-prob_lo(1)) / n_cell

  ! initialize the boxarray to be one single box
  call boxarray_build_bx(ba,bx)

  ! overwrite the boxarray to respect max_grid_size
  call boxarray_maxsize(ba,max_grid_size)

  ! build the layout, la
  ! the third argument is the problem domain, which in this case is bx
  call layout_build_ba(la,ba,bx,pmask=is_periodic)

  call destroy(ba)

  ! build multifab with 2 components and 6 ghost cells
  call multifab_build(data,la,2,6)

  ! initialze data
  call init_data(data,dx,prob_lo)

  istep = 0
  time = 0.d0

  dt = 0.1d0*dx

  ! write out plotfile 0
  call write_plotfile(la,data,istep,dx,time,prob_lo,prob_hi)

  do istep=1,nsteps

     if (verbose .ge. 1) then
        ! we only want one processor to write to screen
        if ( parallel_IOProcessor() ) then
           print*,'Advancing time step',istep
        end if
     end if

     ! advance the data
     call advance(data,dx,dt)

     time = time + dt

     if (mod(istep,plot_int) .eq. 0 .or. istep .eq. nsteps) then
        ! write out plotfile
        call write_plotfile(la,data,istep,dx,time,prob_lo,prob_hi)
     end if

  end do

  ! make sure to destroy the multifab or you'll leak memory
  call destroy(data)
  call destroy(la)

  deallocate(lo,hi,is_periodic,prob_lo,prob_hi)

  ! deallocate temporary boxarrays and communication mappings
  call layout_flush_copyassoc_cache()

  ! check for memory that should have been deallocated
  if ( parallel_IOProcessor() ) then
     print*, 'MEMORY STATS AT END OF PROGRAM'
     print*, ' '
  end if
  call print(multifab_mem_stats(),    "    multifab")
  call print(fab_mem_stats(),         "         fab")
  call print(boxarray_mem_stats(),    "    boxarray")
  call print(layout_mem_stats(),      "      layout")
  call print(boxassoc_mem_stats(),    "    boxassoc")
  call print(fgassoc_mem_stats(),     "     fgassoc")
  call print(syncassoc_mem_stats(),   "   syncassoc")
  call print(copyassoc_mem_stats(),   "   copyassoc")
  call print(fluxassoc_mem_stats(),   "   fluxassoc")

  ! parallel_wtime() returns the number of wallclock-time seconds since
  ! the program began
  run_time = parallel_wtime() - start_time

  ! collect run_time from each processor and store the maximum
  call parallel_reduce(run_time_IOproc, run_time, MPI_MAX, &
                       proc = parallel_IOProcessorNode())

  if ( parallel_IOProcessor() ) then
     print*,"Run time (s) =",run_time_IOproc
  end if

  call boxlib_finalize()

end program main


! PR 19239.  Check for various kinds of vector subscript.  In this test,
! all vector subscripts are indexing single-dimensional arrays.
! { dg-do run }
program main
  implicit none
  integer, parameter :: n = 10
  integer :: i, j, calls
  integer, dimension (n) :: a, b, idx, id

  idx = (/ 3, 1, 5, 2, 4, 10, 8, 7, 6, 9 /)
  id = (/ (i, i = 1, n) /)
  b = (/ (i * 100, i = 1, n) /)

  !------------------------------------------------------------------
  ! Tests for a simple variable subscript
  !------------------------------------------------------------------

  a (idx) = b
  call test (idx, id)

  a = b (idx)
  call test (id, idx)

  a (idx) = b (idx)
  call test (idx, idx)

  !------------------------------------------------------------------
  ! Tests for constant ranges with non-default stride
  !------------------------------------------------------------------

  a (idx (1:7:3)) = b (10:6:-2)
  call test (idx (1:7:3), id (10:6:-2))

  a (10:6:-2) = b (idx (1:7:3))
  call test (id (10:6:-2), idx (1:7:3))

  a (idx (1:7:3)) = b (idx (1:7:3))
  call test (idx (1:7:3), idx (1:7:3))

  a (idx (1:7:3)) = b (idx (10:6:-2))
  call test (idx (1:7:3), idx (10:6:-2))

  a (idx (10:6:-2)) = b (idx (10:6:-2))
  call test (idx (10:6:-2), idx (10:6:-2))

  a (idx (10:6:-2)) = b (idx (1:7:3))
  call test (idx (10:6:-2), idx (1:7:3))

  !------------------------------------------------------------------
  ! Tests for subscripts of the form CONSTRANGE + CONST
  !------------------------------------------------------------------

  a (idx (1:5) + 1) = b (1:5)
  call test (idx (1:5) + 1, id (1:5))

  a (1:5) = b (idx (1:5) + 1)
  call test (id (1:5), idx (1:5) + 1)

  a (idx (6:10) - 1) = b (idx (1:5) + 1)
  call test (idx (6:10) - 1, idx (1:5) + 1)

  !------------------------------------------------------------------
  ! Tests for variable subranges
  !------------------------------------------------------------------

  do j = 5, 10
    a (idx (2:j:2)) = b (3:2+j/2)
    call test (idx (2:j:2), id (3:2+j/2))

    a (3:2+j/2) = b (idx (2:j:2))
    call test (id (3:2+j/2), idx (2:j:2))

    a (idx (2:j:2)) = b (idx (2:j:2))
    call test (idx (2:j:2), idx (2:j:2))
  end do

  !------------------------------------------------------------------
  ! Tests for function vectors
  !------------------------------------------------------------------

  calls = 0

  a (foo (5, calls)) = b (2:10:2)
  call test (foo (5, calls), id (2:10:2))

  a (2:10:2) = b (foo (5, calls))
  call test (id (2:10:2), foo (5, calls))

  a (foo (5, calls)) = b (foo (5, calls))
  call test (foo (5, calls), foo (5, calls))

  if (calls .ne. 8) call abort

  !------------------------------------------------------------------
  ! Tests for constant vector constructors
  !------------------------------------------------------------------

  a ((/ 1, 5, 3, 9 /)) = b (1:4)
  call test ((/ 1, 5, 3, 9 /), id (1:4))

  a (1:4) = b ((/ 1, 5, 3, 9 /))
  call test (id (1:4), (/ 1, 5, 3, 9 /))

  a ((/ 1, 5, 3, 9 /)) = b ((/ 2, 5, 3, 7 /))
  call test ((/ 1, 5, 3, 9 /), (/ 2, 5, 3, 7 /))

  !------------------------------------------------------------------
  ! Tests for variable vector constructors
  !------------------------------------------------------------------

  do j = 1, 5
    a ((/ 1, (i + 3, i = 2, j) /)) = b (1:j)
    call test ((/ 1, (i + 3, i = 2, j) /), id (1:j))

    a (1:j) = b ((/ 1, (i + 3, i = 2, j) /))
    call test (id (1:j), (/ 1, (i + 3, i = 2, j) /))

    a ((/ 1, (i + 3, i = 2, j) /)) = b ((/ 8, (i + 2, i = 2, j) /))
    call test ((/ 1, (i + 3, i = 2, j) /), (/ 8, (i + 2, i = 2, j) /))
  end do

  !------------------------------------------------------------------
  ! Tests in which the vector dimension is partnered by a temporary
  !------------------------------------------------------------------

  calls = 0
  a (idx (1:6)) = foo (6, calls)
  if (calls .ne. 1) call abort
  do i = 1, 6
    if (a (idx (i)) .ne. i + 3) call abort
  end do
  a = 0

  calls = 0
  a (idx (1:6)) = foo (6, calls) * 100
  if (calls .ne. 1) call abort
  do i = 1, 6
    if (a (idx (i)) .ne. (i + 3) * 100) call abort
  end do
  a = 0

  a (idx) = id + 100
  do i = 1, n
    if (a (idx (i)) .ne. i + 100) call abort
  end do
  a = 0

  a (idx (1:10:3)) = (/ 20, 10, 9, 11 /)
  if (a (idx (1)) .ne. 20) call abort
  if (a (idx (4)) .ne. 10) call abort
  if (a (idx (7)) .ne. 9) call abort
  if (a (idx (10)) .ne. 11) call abort
  a = 0

contains
  subroutine test (lhs, rhs)
    integer, dimension (:) :: lhs, rhs
    integer :: i

    if (size (lhs, 1) .ne. size (rhs, 1)) call abort
    do i = 1, size (lhs, 1)
      if (a (lhs (i)) .ne. b (rhs (i))) call abort
    end do
    a = 0
  end subroutine test

  function foo (n, calls)
    integer :: i, n, calls
    integer, dimension (n) :: foo

    calls = calls + 1
    foo = (/ (i + 3, i = 1, n) /)
  end function foo
end program main


!--------------------------------------------------------------------------------
! 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.
!--------------------------------------------------------------------------------

c************************************************
c     generate equidistant k-point mesh as needed
c     for wannier functions
c     Frank Freimuth, September 2006
c************************************************
      program kpunktgen
      implicit none
      integer num,numkpt,dim
      integer c1,c2,c3,limit
      real ilen,shift
      real i1,i2,i3
      logical l_shift

      print*,"specify dimension"
      read(*,*)dim
      print*,"symmetric to origin?"
      read(*,*)l_shift
      if(dim==3)then
      print*,"create three dimensional k-point set"
      print*,"Divisions per direction"
      read(*,*)num
      print*,"Divisions per direction: ",num
      numkpt=num**3
      print*,"Number of k-points: ",numkpt
      ilen=1.0/num
      print*,"length of intervals: ",ilen
c      open(100,file='kpts',form='formatted',status='unknown')
      open(200,file='w90kpts',form='formatted',status='unknown')
c      write(100,'(2x,i3,8x,f7.5)')numkpt,1.0
      write(200,*)numkpt
      limit=num-1
      if (l_shift) then
         shift=limit*ilen/2.0
      endif

      do c1=0,limit
         do c2=0,limit
            do c3=0,limit
               i1=ilen*c1-shift
               i2=ilen*c2-shift
               i3=ilen*c3-shift
c               write(100,'(3x,f7.5,3x,f7.5,3x,f7.5,3x,f7.5)')i1,i2,i3,1.00000
c               write(200,'(3x,f7.5,3x,f7.5,3x,f7.5)')i1,i2,i3
               write(200,*)i1,i2,i3
            enddo
         enddo
      enddo
      close(100)
      close(200)

      elseif(dim==2)then
      print*,"create two dimensional k-point set"
         print*,"Divisions per direction"
      read(*,*)num
      print*,"Divisions per direction: ",num
      numkpt=num**2
      print*,"Number of k-points: ",numkpt
      ilen=1.0/num
      print*,"Length of intervals: ",ilen
c      open(100,file='kpts',form='formatted',status='unknown')
      open(200,file='w90kpts',form='formatted',status='unknown')
c      write(100,'(2x,i3,8x,f7.5,8x,1a)')numkpt,1.0,"F"
      write(200,*)numkpt
      limit=num-1
      if(l_shift)then
         shift=limit*ilen/2.0
      endif
      do c1=0,limit
         do c2=0,limit
               i1=ilen*c1-shift
               i2=ilen*c2-shift
c               write(100,'(3x,f7.5,3x,f7.5,3x,f7.5)')i1,i2,1.00000
c               write(200,'(3x,f7.5,3x,f7.5,3x,f6.5)')i1,i2,0.00000
               write(200,*)i1,i2,0.00000
         enddo
      enddo
      close(100)
      close(200)

      elseif(dim==1)then
      print*,"create one dimensional k-point set"
      print*,"Divisions per direction"
      read(*,*)num
      print*,"Divisions per direction: ",num
      numkpt=num
      print*,"Number of k-points: ",numkpt
      ilen=1.0/num
      print*,"length of intervals: ",ilen
c      open(100,file='kpts',form='formatted',status='unknown')
      open(200,file='w90kpts',form='formatted',status='unknown')
c      write(100,'(2x,i3,8x,f7.5)')numkpt,1.0
      write(200,*)numkpt
      limit=num-1
      if (l_shift) then
         shift=limit*ilen/2.0
      endif

      do c1=0,limit

               i1=ilen*c1-shift

c               write(100,'(3x,f7.5,3x,f7.5,3x,f7.5,3x,f7.5)')i1,i2,i3,1.00000
c               write(200,'(3x,f7.5,3x,f7.5,3x,f7.5)')i1,0.0000,0.00000
               write(200,*)i1,0.0000,0.00000

      enddo
      close(100)
      close(200)

      endif
      end program kpunktgen


!+MODULE NAME
!   particles
!
!+MODULE DESCRIPTION
!   This module initialize the particle spatial and velocity distributions,
!   and contains a function for transforming particle location between Cartesian
!   and field-aligned coordinate systems.
!
!+CONTAINS subroutines
!   PARTICLES_INITIALIZE
!   PARTICLE_INITIALIZE
!   FAC_ROTATION_MATRIX
!
!+AUTHOR
!   Jesse Woodroffe
!   jwoodroffe@lanl.gov
!

module particles

use global
use rksuite_90
use fields
use interpolation

integer, private :: idist, idens
real(dp), private :: x0, y0, z0, E0, alpha, vtperp, vtpara, vz0, vp0
real(dp), private :: xsMin, xsMax, ysMin, ysMax, zsMin, zsMax, mltMin, mltMax, r0

! Flux mapping
integer, private :: nEnergies, nPitchAngles
real(dp), private :: EkevMin, EkevMax, PitchAngleDegMin, PitchAngleDegMax
real(dp), dimension(:), allocatable, private :: pitchAngles, energies
real(dp), private :: phi0 ! Initial gyrophase angle in degrees; if phi0 < 0, use random gyrophase.

contains

  subroutine particles_initialize()

  implicit none

  integer :: nseed, lun, ierr
  real(dp) :: gam, vt
  integer :: i

  ! Configure velocity space distribution

  open(newunit=lun,file='ptm_input/dist_velocity_'//id_string//'.txt',action='read',status='old',iostat=ierr)
  call assert(ierr==0,'particles_initialize','error opening dist_velocity_'//id_string//'.txt')

  ! Initialize the system Random Number Generator
  call random_seed(size=nseed)
  call random_seed(put=(/(iseed+i,i=0,nseed-1)/))

  ! Read in the user-specified distribution function type
  read(lun,*) idist

  select case(idist)

    case(1)
      ! Monoenergetic ring distribution
      read(lun,*) E0
      read(lun,*) alpha
      read(lun,*) phi0
      gam = 1.d0+E0/(mass*mc2)
      vt = ckm*sqrt(gam*gam-1)/gam
      vp0 = vt*sind(alpha)
      vz0 = vt*cosd(alpha)

    case(2)
      ! Non-relativistic Bi-Maxwellian distribution
      read(lun,*) vtperp
      read(lun,*) vtpara
      read(lun,*) phi0

    case(3)
      ! Automatic flux map mode
      ! This option overrides the 'nparticles' option from
      ! the ptm_parameters.txt file and sets it to the number
      ! of particles necessary to obtain the desired flux map.

      fluxMap = .TRUE.

      read(lun,*) nEnergies
      read(lun,*) nPitchAngles
      read(lun,*) phi0
      read(lun,*) EkevMin
      read(lun,*) EkevMax
      read(lun,*) PitchAngleDegMin
      read(lun,*) PitchAngleDegMax
      read(lun,*) xsource

      nparticles = nEnergies*nPitchAngles
      write(*,*) 'FLUX MAP MODE'
      write(*,*) 'NPARTICLES = ', nparticles

      allocate(pitchAngles(abs(nPitchAngles)))
      allocate(energies(abs(nEnergies)))

      if(nEnergies==1) then
        energies=EkevMin
      else
        energies = linspace(EkevMin,EkevMax,nEnergies)
      endif

      if(nPitchAngles==1) then
        pitchAngles = PitchAngleDegMin
      else
        pitchAngles = linspace(PitchAngleDegMin,PitchAngleDegMax,nPitchAngles)
      endif

    case(4)
      ! User-specified flux map mode
      ! This option overrides the 'nparticles' option from
      ! the ptm_parameters.txt file and sets it to the number
      ! of particles necessary to obtain the desired flux map.

      fluxMap = .TRUE.
      read(lun,*) nEnergies
      read(lun,*) nPitchAngles
      read(lun,*) phi0
      read(lun,*) xsource

      nparticles = nEnergies*nPitchAngles
      write(*,*) 'FLUX MAP MODE'
      write(*,*) 'NPARTICLES = ', nparticles

      allocate(pitchAngles(abs(nPitchAngles)))
      allocate(energies(abs(nEnergies)))
      call read_array('ptm_data/energies_'//id_string//'.bin',energies)
      call read_array('ptm_data/pitchangles_'//id_string//'.bin',pitchAngles)

    case default

      call assert(.FALSE.,'particles_initialize','idist='//int2str(idist)//' not supported')

  end select

  close(lun)

  ! Configure physical space distributions

  open(newunit=lun,file='ptm_input/dist_density_'//id_string//'.txt',action='read',status='old',iostat=ierr)
  call assert(ierr==0,'particles_initialize','error opening dist_density_'//id_string//'.txt')

  read(lun,*) idens

  select case(idens)
    case(1) ! All particles are seeded at same position
      read(lun,*) x0
      read(lun,*) y0
      read(lun,*) z0
      write(*,'(a20,3f8.3)') 'x0,y0,z0=', x0, y0, z0
    case(2) ! Particles are seeded randomly throughout a cubic region
      read(lun,*) xsMin
      read(lun,*) xsMax
      read(lun,*) ysMin
      read(lun,*) ysMax
      read(lun,*) zsMin
      read(lun,*) zsMax
    case(3) ! Particles are seeded randomly at a given radial distance
      read(lun,*) r0
      read(lun,*) mltMin
      read(lun,*) mltMax
    case default
      call assert(.FALSE.,'particles_initialize','idens='//int2str(idens)//' not supported')

  end select

  close(lun)

  return

  end subroutine particles_initialize

!

  subroutine particle_cleanup(myParticle)

  implicit none

  type(particle) :: myParticle

  if(associated(myParticle%y)) myParticle%y=>null()

  return

  end subroutine particle_cleanup

!

  function fac_rotation_matrix(myParticle,toCartesian) result(R)
  ! Calculate a matrix that rotates from Cartesian ("XYZ") coordinates to a between a local
  ! field-aligned coordinate system ("PQB"). PQB is equaivalent to the dipole coordinate system
  ! when the magnetic field is dipolar. The inverse transform is given by the transpose of the
  ! matrix.
  !
  ! P is the "x-like" coordinate which points in a direction perpendicular to both Q and B
  !   directions. For a dipole field, this is in the direction of the local radius of curvature
  ! Q is the "y-like" coordinate which points in a direction perpendicular to both the radial
  !   direction and the magnetic field. For a dipole magnetic field this is the azimuthal direction.
  ! B is the "z-like" coordinate which points in the local magnetic field direction
  !
  ! Jesse Woodroffe
  ! 8/22/2016

  implicit none

  type(particle) :: myParticle
  real(dp), dimension(3,3) :: R
  real(dp), dimension(3) :: bhat, phat, qhat, rhat
  logical, intent(in), optional :: toCartesian

  call get_fields(myParticle,bhat)
  bhat = bhat/norm(bhat)
  rhat = myParticle%x/norm(myParticle%x)
  qhat = cross_product(bhat,rhat)
  phat = cross_product(qhat,bhat)

  ! Populate rotation matrix
  R(1,:) = phat
  R(2,:) = qhat
  R(3,:) = bhat

  ! If rotation from FAC to Cartesian is desired, transpose rotation matrix
  if(present(toCartesian)) then
    if(toCartesian) R = transpose(R)
  endif

  return

  end function fac_rotation_matrix

!

  subroutine particle_initialize(myParticle,tag)
  ! This is an initialization method for the particle data type
  implicit none

  type(particle) :: myParticle
  integer, intent(in), optional :: tag
  real(dp) :: x, y, z
  real(dp) :: vp, vz, v
  real(dp), dimension(3) :: bvec, bhat, rhat
  real(dp), dimension(3,3) :: R
  real(dp) :: gam, phi, dx, dy, dz, dt, wc
  integer :: im, jm, km, lm, iEnergy, iPitchAngle

  real(dp) :: usq, gami, b0
  real(dp), dimension(3) :: evec, curlb, curlbhat, gradb, fE, fG, fC
  real(dp), dimension(3,3) :: Bgrad

  myParticle%drift = .FALSE.
  myParticle%integrate = .TRUE.

  allocate(myParticle%p(2))
  allocate(myParticle%y(7))
  myParticle%x => myParticle%y(1:3)
  myParticle%v => myParticle%y(4:6)

  myParticle%p(1) = e_me*charge_mass_ratio
  myParticle%p(2) = mass*mc2

  myParticle%qmr => myParticle%p(1)
  myParticle%mc2 => myParticle%p(2)

! initialize particle location (x,y,z)

  select case(idens)

    case(1) ! All particles start at same position
      x = x0
      y = y0
      z = z0
    case(2) ! Particles are seeded randomly throughout a rectangular region
      x = xsMin+(xsMax-xsMin)*random_uniform()
      y = ysMin+(ysMax-ysMin)*random_uniform()
      z = zsMin+(zsMax-zsMin)*random_uniform()
    case(3) ! Particles are seeded along the equator at a fixed radial distance and random local times
      phi = 2*pi*(mltMin+random_uniform()*(mltMax-mltMin))/24.0d0
      x = r0*sin(phi)
      y = r0*cos(phi)
      z = 0.0d0
    case default
      call assert(.FALSE.,'particle_initialize','idens='//int2str(idens)//' not supported')
  end select

  myParticle%x = [x,y,z]

  ! initialize particle velocity components (vp,vz)

  select case(idist)
    case(1) ! Initialize a particle beam
      vp = vp0
      vz = vz0
      gam = 1.0/sqrt(1.d0-(vp**2+vz**2)/csq)

    case(2) ! Bi-Maxwellian
      do ! Get perpendicular velocity truncated normal distribution
        vp = vtperp*random_gauss()
        if(vp>0.d0) exit
      enddo
      ! Parallel velocity from a normal distribution
      vz = vtpara*random_gauss()
      gam = 1.0/sqrt(1.d0-(vp**2+vz**2)/csq)

    case(3:4) ! Set up particle properties for flux map mode
      call assert(present(tag),'particle_initialize','idist=3 requires specification of particle tag in calling routine')
      myParticle%tag = tag
      iEnergy = ceiling(tag/real(nPitchAngles))
      iPitchAngle = tag-(iEnergy-1)*nPitchAngles
      gam = 1.0+energies(iEnergy)/myParticle%mc2
      v = ckm*sqrt(gam*gam-1.d0)/gam
      vp = v*sind(pitchAngles(iPitchAngle))
      vz = v*cosd(pitchAngles(iPitchAngle))
      myParticle%fluxMapCoordinates(1:6) = [merge(thi,tlo,itrace<0),x,y,z,energies(iEnergy),pitchAngles(iPitchAngle)]

    case default
      call assert(.FALSE.,'particle_initialize','idist='//int2str(idist)//' not supported')

  end select

  ! *********** construct myParticle object

  ! Set the particle at the correct time in order to allow for forward and reverse tracing
  myParticle%t = merge(Tlo,Thi,itrace>0)
  myParticle%drift = iswitch<0

  ! Initialize the grid and interpolators
  im = locate(xgrid,x)
  jm = locate(ygrid,y)
  km = locate(zgrid,z)
  lm = locate(tgrid,myParticle%t)

  dx = xgrid(im+1)-xgrid(im)
  dy = ygrid(jm+1)-ygrid(jm)
  dz = zgrid(km+1)-zgrid(km)
  dt = tgrid(lm+1)-tgrid(lm)

  call grid_init(myParticle%grid,im,jm,km,lm,dx,dy,dz,dt)
  call get_fields(myParticle,bvec,doInit=.TRUE.)

  bhat = bvec/norm(bvec)                                  ! mag field direction
  R = fac_rotation_matrix(myParticle,toCartesian=.TRUE.)  ! rotation from PQB field-aligned to Cartesian coordinates
  phi = merge(radians(phi0),twopi*random_uniform(),phi0>0.d0)
  rhat = matmul(R,[cos(phi),sin(phi),0.d0])

  myParticle%v = gam*(vz*bhat+vp*rhat)

  ! Store initial cartesian components for flux mapping
  myParticle%fluxMapCoordinates(7:9) = myParticle%v

  return

  end subroutine particle_initialize

end module particles


      subroutine screenz (t,d,z1,z2,a1,a2,ymass,aion,zion,nion,
     1                    scfac, dscfacdt)

      implicit none

      integer nion
      double precision t, d, z1, z2, a1, a2
      double precision, dimension(nion) :: ymass, aion, zion
      double precision scfac
      double precision dscfacdt

!.... this subroutine calculates screening factors for nuclear reaction
!.... rates in the weak, intermediate , and strong regimes
!.... given the temperature (t--degk), the density (d--g/cc), the
!.... atomic numbers and weights of the elements in the reaction
!.... channel with the largest coulomb barrier (z1,z2,a1,a2),
!.... and the mean plasma parameters
!.... calculated in main and passed over in common aver:
!.... (mean atomic number--zbar, mean square of the atomic number--z2bar,
!.... mean atomic weight--abar, and total number of moles of
!.... nuclei per gram--ytot1).
!.... the unscreened rate is to be multiplied by the dimensionless
!.... the treatment is based on graboske, dewit, grossman, and cooper
!.... ap j. 181,457 (1973) for weak screening and on
!.... alastuey and jancovici, ap.j. 226, 1034, 1978, with plasma
!.... parameters from itoh, totsuji, setsuo, and dewitt, ap.j. 234,
!.... 1079,1979,  for strong screening (rkw modification).

!.... last revision 15 nov 1982

      double precision x13, x14, x53, x512
      parameter (x13=1.d+0/3.d+0,
     &           x14=1.d+0/4.d+0,
     &           x53=5.d+0/3.d+0,
     &           x512=5.d+0/12.d+0)

      double precision abar, zbar, ytot1, z2bar, theta

      integer iy

      double precision qlam0, ztilda, qlam0z, gamp, taufac
      double precision dqlam0dt, dqlam0zdt, dgampdt, dtaufacdt
      double precision zhat, zhat2, gamef, tau12, alph12
      double precision dgamefdt, dtau12dt, dalph12dt
      double precision h12w, h12, c, h12fac
      double precision dh12wdt, dh12dt, dcdt

!... calculate averages for screening routine
!... nb  y = x/a with x the mass fraction
!... zi and ai are the nuclear chage and atomic mass number
!... respectively

! this part came in through a common block in Kepler -- do it
! directly here
      abar=0.d0
      zbar=0.d0
      ytot1=0.d0
      z2bar=0.d0

      do iy = 1, nion
         ytot1 = ytot1 + ymass(iy)
         z2bar = z2bar + zion(iy)**2*ymass(iy)
         abar = abar + aion(iy)*ymass(iy)
         zbar = zbar + zion(iy)*ymass(iy)
      enddo

      z2bar=z2bar/ytot1
      abar=abar/ytot1
      zbar=zbar/ytot1

! resume original Kepler screen...
      theta=1.d0
      ytot1=1.d0/abar

!.... calculate average plasma parameters
!....
      if((z1*z2).le.0.d0) go to 50
      qlam0=1.88d+8*sqrt(d/(abar*t**3))
      dqlam0dt=-1.5d+0*qlam0 / t

      ztilda=sqrt(z2bar+zbar*theta)

      qlam0z=qlam0*ztilda
      dqlam0zdt=ztilda*dqlam0dt

      gamp=2.27493d+5*(d*zbar*ytot1)**x13/t
      dgampdt=-gamp/t

      taufac=4.248719d+3/t**x13
      dtaufacdt=-x13*taufac/t

!.... calculate screening factor
!.... approx. for strong screening only good for alpha .lt. 1.6

      zhat=(z1+z2)**x53-z1**x53-z2**x53
      zhat2=(z1+z2)**x512-z1**x512-z2**x512

      gamef=2.d0**x13*gamp*z1*z2/(z1+z2)**x13
      dgamefdt=gamef*dgampdt/gamp

      tau12=taufac*(z1**2*z2**2*a1*a2/(a1+a2))**x13
      dtau12dt=tau12*dtaufacdt/taufac

      alph12=3.d0*gamef/tau12
      dalph12dt=alph12*(dgamefdt/gamef - dtau12dt/tau12)

!....
!.... limit alph12 to 1.6 to prevent unphysical behavior
!.... (h dec. as rho inc.) at high rho.  this should really
!.... be replaced by a pycnonuclear reaction rate formula.
!....
      if(alph12.le.1.6d0) go to 60
      alph12=1.6d0
      dalph12dt=0.0d0

      gamef=1.6d0*tau12/3.d0
      dgamefdt=gamef*dtau12dt/tau12

      gamp=gamef*(z1+z2)**x13/(2.d0**x13*z1*z2)
      dgampdt=gamp*dgamefdt/gamef

 60   h12w=z1*z2*qlam0z
      dh12wdt=h12w*dqlam0zdt/qlam0z

      h12=h12w
      dh12dt=dh12wdt
      if(gamef.gt.0.3d0) go to 30
      go to 40

 30   c=0.896434d0*gamp*zhat-3.44740d0*gamp**x14*zhat2-
     1     0.5551d0*(log(gamp)+x53*log(z1*z2/(z1+z2)))-2.996d0
      dcdt=0.896434d0*dgampdt*zhat-
     1     3.44740d0*x14*gamp**(x14-1.0d0)*zhat2*dgampdt-
     2     0.5551d0*dgampdt/gamp

      h12=c-(tau12/3.d0)*(5.d0*alph12**3/32.d0-0.014d0*alph12**4
     1     -0.0128d0*alph12**5)-gamef*(0.0055d0*alph12**4
     2     -0.0098d0*alph12**5+0.0048d0*alph12**6)
      dh12dt=dcdt - ((dtau12dt*alph12**3 + 3.0d0*tau12*alph12**2*
     1       dalph12dt)*(5.d0/32.d0 - 0.014d0*alph12 -
     2       0.0128d0*alph12**2) + tau12*alph12**3*dalph12dt*(-0.014d0
     3       - 2.d0*0.0128d0*alph12))/3.d0 -(dgamefdt*alph12**4 + 4.d0
     4       *gamef*alph12**3*dalph12dt)*(0.0055d0 - 0.0098d0*alph12 -
     5       0.0048d0*alph12**2) - gamef*alph12**4*dalph12dt*(-0.0098d0
     6       + 2.d0*0.0048d0*alph12)

      h12fac=0.77d0

      h12=log(max(1.d+0-0.0562d+0*alph12**3,h12fac))+h12
      if (1.d+0-0.0562d+0*alph12**3 .gt. h12fac) then
         dh12dt=(-3.d0*0.0562d0*alph12**2*dalph12dt)/
     1          (1.d0-0.0562d0*alph12**3) + dh12dt
      endif

      if(gamef.gt.0.8d0) go to 40

      h12=h12w*((0.8d0-gamef)/0.5d0)+h12*((gamef-0.3d0)/0.5d0)
      dh12dt=((dh12wdt*(0.8d0-gamef) - h12w*dgamefdt + dh12dt*
     1       (gamef-0.3d0) + h12*dgamefdt)/0.5d0)

 40   if(h12.gt.300.d0) then
         h12=300.d0
         dh12dt=0.d0
      endif
      if(h12.lt.0.d0) then
         h12=0.d0
         dh12dt=0.d0
      endif

      scfac=exp(h12)
      dscfacdt=scfac*dh12dt
      return

 50   scfac=1.d0
      dscfacdt=0.d0
      return

      end subroutine screenz


c
c
c
c    comp_R1111 -> R, dRdA, dRdf, dRdDg
c    comp_R1000 -> R
c    comp_R0111 ->    dRdA, dRdf, dRdDg
c    comp_R1100 -> R, dRdA
c    comp_R0100 ->    dRdA
c
c
c==============================================================================

      subroutine comp_R1111(R,dRdA,dRdf,dRdDg,f,A,invA,diA,An,invAn,Dg,
     *                      nip)
c
c     compute R, dRdA, dRdf, dRdDg
c
c     nip = 0 -> simple backward Euler
c         > 0 -> backward Euler exponential map with nip series terms
c
      implicit none
      integer          nip, i
      double precision R(6), dRdf(6,6), dRdA(6,6), dRdDg(6),
     *                 f(6), A(6), invA(6), diA(6,6), An(6), invAn(6),
     *                 Dg, dRdiA(6,6), hs(6), hs2(6), hu(3,3), hu2(3,3),
     *                 h4(6,6), h42(6,6), h4df(6,6), h4diA(6,6),
     *                 fact, fact2

      if (nip.eq.0) then

c       simple backward Euler
c    ------------------------------
        fact = - Dg
        call set_s_p(R,A)        ! R
        call set_s_am(R,An)      !
        call set_s_af(R,f,fact)  !
        call unit_4_f(dRdf,fact) ! dRdf
        call unit_4_p(dRdA)      ! dRdA
        call set_s_m(dRdDg,f)    ! dRdDg

      else

c       backward Euler exponential map
c    -------------------------------------
c       for i=1

        call set_s_p(R,A)
        call mult_u_ss_p(hu,invAn,A)
        call mult_s_su_am(R,A,hu)
        call set_s_p(hs,f)
        call set_s_af(R,hs,Dg)

        call unit_4_p(dRdA)
        call diff_TAT_am(dRdA,hu)

        call unit_4_f(dRdf,Dg)

        call set_s_p(dRdDg,f)

c       for i=2,3,..nip
        if (nip.gt.1) then

          call mult_u_ss_p(hu,invA,f)
          call diff_TU_p(h4,hu)
          call pzero(dRdiA,36)
          call set_4_p(h4df,h4)

c         for i=2

          fact  = Dg * Dg * 0.5d0

c         dR/df
          call mult_u_ss_p(hu2,hs,invA)
          call diff_UT_ap(h4df,hu2)
          call set_4_af(dRdf,h4df,fact)

c         dR/dinvA
          call diff_ATB_p(h4diA,hs,f)
          call set_4_af(dRdiA,h4diA,fact)

c         R
          call mult_s_su_p(hs2,hs,hu)
          call set_s_p(hs,hs2)
          call set_s_af(R,hs,fact)

c         dR/dDg
          call set_s_af(dRdDg,hs,Dg)
          fact2 = fact

c         for i=3,4...nip
          do i=3, nip

            fact  = fact * Dg / real(i)

c           dR/df
            call mult_4_44_p(h42,h4,h4df)
            call set_4_p(h4df,h42)
            call mult_u_ss_p(hu2,hs,invA)
            call diff_UT_ap(h4df,hu2)
            call set_4_af(dRdf,h4df,fact)

c           dR/dinvA
            call mult_4_44_p(h42,h4,h4diA)
            call set_4_p(h4diA,h42)
            call diff_ATB_ap(h4diA,hs,f)
            call set_4_af(dRdiA,h4diA,fact)

c           R
            call mult_s_su_p(hs2,hs,hu)
            call set_s_p(hs,hs2)
            call set_s_af(R,hs,fact)

c           dR/dDg
            call set_s_af(dRdDg,hs,fact2)
            fact2 = fact2 * Dg / real(i)

          enddo

c         dR/dA = dR/dinvA : dinvA/dA
          call mult_4_44_ap(dRdA,dRdiA,diA)

        endif

      endif

      return

      end

c=============================================================================

      subroutine comp_R1000(R,f,A,invA,An,invAn,Dg,nip)
c
c     compute R
c
c     nip = 0 -> simple backward Euler
c         > 0 -> backward Euler exponential map with nip series terms
c
      implicit none
      integer          nip, i
      double precision R(6),
     *                 f(6), A(6), invA(6), An(6), invAn(6), Dg,
     *                 hs(6), hs2(6), hu(3,3), fact

      if (nip.eq.0) then

c       simple backward Euler
c    ------------------------------
        fact = - Dg
        call set_s_p(R,A)        ! R
        call set_s_am(R,An)      !
        call set_s_af(R,f,fact)  !

      else

c       backward Euler exponential map
c    -------------------------------------
c       for i=1

        call set_s_p(R,A)
        call mult_u_ss_p(hu,invAn,A)
        call mult_s_su_am(R,A,hu)
        call set_s_p(hs,f)
        call set_s_af(R,hs,Dg)

c       for i=2,3,..nip
        if (nip.gt.1) then

          call mult_u_ss_p(hu,invA,f)

          fact  = Dg

          do i=2, nip

            fact  = fact * Dg / real(i)

c           R
            call mult_s_su_p(hs2,hs,hu)
            call set_s_p(hs,hs2)
            call set_s_af(R,hs,fact)

          enddo

        endif

      endif

      return

      end

c=============================================================================

      subroutine comp_R0111(dRdA,dRdf,dRdDg,f,A,invA,diA,An,invAn,Dg,
     *                      nip)
c
c     compute dRdA, dRdf, dRdDg
c
c     nip = 0 -> simple backward Euler
c         > 0 -> backward Euler exponential map with nip series terms
c
      implicit none
      integer          nip, i
      double precision dRdf(6,6), dRdA(6,6), dRdDg(6),
     *                 f(6), A(6), invA(6), diA(6,6), An(6), invAn(6),
     *                 Dg, dRdiA(6,6), hs(6), hs2(6), hu(3,3), hu2(3,3),
     *                 h4(6,6), h42(6,6), h4df(6,6), h4diA(6,6),
     *                 fact, fact2

      if (nip.eq.0) then

c       simple backward Euler
c    ------------------------------
        fact = - Dg
        call unit_4_f(dRdf,fact) ! dRdf
        call unit_4_p(dRdA)      ! dRdA
        call set_s_m(dRdDg,f)    ! dRdDg

      else

c       backward Euler exponential map
c    -------------------------------------
c       for i=1

        call mult_u_ss_p(hu,invAn,A)
        call set_s_p(hs,f)

        call unit_4_p(dRdA)
        call diff_TAT_am(dRdA,hu)

        call unit_4_f(dRdf,Dg)

        call set_s_p(dRdDg,f)

c       for i=2,3,..nip
        if (nip.gt.1) then

          call mult_u_ss_p(hu,invA,f)
          call diff_TU_p(h4,hu)
          call pzero(dRdiA,36)
          call set_4_p(h4df,h4)

c         for i=2

          fact  = Dg * Dg * 0.5d0

c         dR/df
          call mult_u_ss_p(hu2,hs,invA)
          call diff_UT_ap(h4df,hu2)
          call set_4_af(dRdf,h4df,fact)

c         dR/dinvA
          call diff_ATB_p(h4diA,hs,f)
          call set_4_af(dRdiA,h4diA,fact)

          call mult_s_su_p(hs2,hs,hu)
          call set_s_p(hs,hs2)

c         dR/dDg
          call set_s_af(dRdDg,hs,Dg)
          fact2 = fact

c         for i=3,4...nip
          do i=3, nip

            fact  = fact * Dg / real(i)

c           dR/df
            call mult_4_44_p(h42,h4,h4df)
            call set_4_p(h4df,h42)
            call mult_u_ss_p(hu2,hs,invA)
            call diff_UT_ap(h4df,hu2)
            call set_4_af(dRdf,h4df,fact)

c           dR/dinvA
            call mult_4_44_p(h42,h4,h4diA)
            call set_4_p(h4diA,h42)
            call diff_ATB_ap(h4diA,hs,f)
            call set_4_af(dRdiA,h4diA,fact)

            call mult_s_su_p(hs2,hs,hu)
            call set_s_p(hs,hs2)

c           dR/dDg
            call set_s_af(dRdDg,hs,fact2)
            fact2 = fact2 * Dg / real(i)

          enddo

c         dR/dA = dR/dinvA : dinvA/dA
          call mult_4_44_ap(dRdA,dRdiA,diA)

        endif

      endif

      return

      end

c=============================================================================

      subroutine comp_R1100(R,dRdA,f,A,invA,diA,An,invAn,Dg,nip)
c
c     compute R, dRdA
c
c     nip = 0 -> simple backward Euler
c         > 0 -> backward Euler exponential map with nip series terms
c
      implicit none
      integer          nip, i
      double precision R(6), dRdA(6,6),
     *                 f(6), A(6), invA(6), diA(6,6), An(6), invAn(6),
     *                 Dg, dRdiA(6,6), hs(6), hs2(6), hu(3,3), hu2(3,3),
     *                 h4(6,6), h42(6,6), h4diA(6,6),
     *                 fact

      if (nip.eq.0) then

c       simple backward Euler
c    ------------------------------
        fact = - Dg
        call set_s_p(R,A)        ! R
        call set_s_am(R,An)      !
        call set_s_af(R,f,fact)  !
        call unit_4_p(dRdA)      ! dRdA

      else

c       backward Euler exponential map
c    -------------------------------------
c       for i=1

        call set_s_p(R,A)
        call mult_u_ss_p(hu,invAn,A)
        call mult_s_su_am(R,A,hu)
        call set_s_p(hs,f)
        call set_s_af(R,hs,Dg)

        call unit_4_p(dRdA)
        call diff_TAT_am(dRdA,hu)

c       for i=2,3,..nip
        if (nip.gt.1) then

          call mult_u_ss_p(hu,invA,f)
          call diff_TU_p(h4,hu)
          call pzero(dRdiA,36)

c         for i=2

          fact  = Dg * Dg * 0.5d0

c         dR/dinvA
          call diff_ATB_p(h4diA,hs,f)
          call set_4_af(dRdiA,h4diA,fact)

c         R
          call mult_s_su_p(hs2,hs,hu)
          call set_s_p(hs,hs2)
          call set_s_af(R,hs,fact)

c         for i=3,4...nip
          do i=3, nip

            fact  = fact * Dg / real(i)

c           dR/dinvA
            call mult_4_44_p(h42,h4,h4diA)
            call set_4_p(h4diA,h42)
            call diff_ATB_ap(h4diA,hs,f)
            call set_4_af(dRdiA,h4diA,fact)

c           R
            call mult_s_su_p(hs2,hs,hu)
            call set_s_p(hs,hs2)
            call set_s_af(R,hs,fact)

          enddo

c         dR/dA = dR/dinvA : dinvA/dA
          call mult_4_44_ap(dRdA,dRdiA,diA)

        endif

      endif

      return

      end

c=============================================================================

      subroutine comp_R0100(dRdA,f,A,invA,diA,An,invAn,Dg,nip)
c
c     compute R, dRdA
c
c     nip = 0 -> simple backward Euler
c         > 0 -> backward Euler exponential map with nip series terms
c
      implicit none
      integer          nip, i
      double precision dRdA(6,6),
     *                 f(6), A(6), invA(6), diA(6,6), An(6), invAn(6),
     *                 Dg, dRdiA(6,6), hs(6), hs2(6), hu(3,3), hu2(3,3),
     *                 h4(6,6), h42(6,6), h4diA(6,6),
     *                 fact

      if (nip.eq.0) then

c       simple backward Euler
c    ------------------------------
        call unit_4_p(dRdA)      ! dRdA

      else

c       backward Euler exponential map
c    -------------------------------------
c       for i=1

        call mult_u_ss_p(hu,invAn,A)
        call set_s_p(hs,f)

        call unit_4_p(dRdA)
        call diff_TAT_am(dRdA,hu)

c       for i=2,3,..nip
        if (nip.gt.1) then

          call mult_u_ss_p(hu,invA,f)
          call diff_TU_p(h4,hu)
          call pzero(dRdiA,36)

c         for i=2

          fact  = Dg * Dg * 0.5d0

c         dR/dinvA
          call diff_ATB_p(h4diA,hs,f)
          call set_4_af(dRdiA,h4diA,fact)

          call mult_s_su_p(hs2,hs,hu)
          call set_s_p(hs,hs2)

c         for i=3,4...nip
          do i=3, nip

            fact  = fact * Dg / real(i)

c           dR/dinvA
            call mult_4_44_p(h42,h4,h4diA)
            call set_4_p(h4diA,h42)
            call diff_ATB_ap(h4diA,hs,f)
            call set_4_af(dRdiA,h4diA,fact)

            call mult_s_su_p(hs2,hs,hu)
            call set_s_p(hs,hs2)

          enddo

c         dR/dA = dR/dinvA : dinvA/dA
          call mult_4_44_ap(dRdA,dRdiA,diA)

        endif

      endif

      return

      end

c=============================================================================


MODULE ZDecay
  USE ParamModule
  USE alfas_functions
CONTAINS
  FUNCTION SMZWidth(qcdord,qedord,Wradin,finitemassin)
    IMPLICIT NONE
    ! (qcdord,qedord):
    ! (0,0): LO
    ! (1,0): NLO QCD
    ! (0,1): NLO QED
    ! (1,1): NLO QCD+QED
    INTEGER,INTENT(IN)::qcdord,qedord
    LOGICAL,INTENT(IN),OPTIONAL::Wradin,finitemassin
    LOGICAL::Wrad,finitemass
    REAL(KIND(1d0))::SMZWidth
    REAL(KIND(1d0))::ZWidth_LOuu,ZWidth_LOdd,ZWidth_LOll,ZWidth_LOvv
    IF(.NOT.print_banner)THEN
       INCLUDE "banner.inc"
       print_banner=.TRUE.
    ENDIF
    IF(qcdord.LT.0.OR.qcdord.GT.1)THEN
       WRITE(*,*)"ERROR:Please specify the QCD corr. order to be 0 or 1"
       STOP
    ENDIF
    IF(qedord.LT.0.OR.qedord.GT.1)THEN
       WRITE(*,*)"ERROR:Please specify the QED corr. order to be 0 or 1"
       STOP
    ENDIF
    ! Z > u u~
    ZWidth_LOuu=Decay_e**2*Decay_MZ*(9d0-24d0*Decay_R_SW2+32d0*Decay_R_SW2**2)&
         /(288d0*Decay_R_CW2*pi*Decay_R_SW2)
    ! Z > d d~
    ZWidth_LOdd=Decay_e**2*Decay_MZ*(9d0-12d0*Decay_R_SW2+8d0*Decay_R_SW2**2)&
         /(288d0*Decay_R_CW2*pi*Decay_R_SW2)
    ! Z > e+ e-
    ZWidth_LOll=Decay_e**2*Decay_MZ*(1d0-4d0*Decay_R_SW2+8d0*Decay_R_SW2**2)&
         /(96d0*Decay_R_CW2*pi*Decay_R_SW2)
    ! Z > ve ve~
    ZWidth_LOvv=Decay_e**2*Decay_MZ/(96d0*Decay_R_CW2*pi*Decay_R_SW2)
    ! Z > u u~, c c~, d d~, s s~, b b~, l+ l-, v v~
    SMZWidth=ZWidth_LOuu*2d0+ZWidth_LOdd*3d0+ZWidth_LOll*3d0+ZWidth_LOvv*3d0
    ! include finite quark/lepton mass effect
    IF(PRESENT(finitemassin))THEN
       finitemass=finitemassin
    ELSE
       finitemass=.FALSE. ! it should be turned off with loop_qcd_qed_sm correspondigly
    END IF
    IF(finitemass)THEN
       SMZWidth=SMZWidth+SMZWidth_fmass(Finite_MC,Finite_MB,Finite_MTAU,Finite_MMU)
    ENDIF
    IF(qcdord.EQ.0.AND.qedord.EQ.0)RETURN
    IF(qcdord.EQ.1)THEN
       NLOOP=2
       Decay_aS=ALPHAS_MCFM(Decay_MZ)
       Decay_gs=DSQRT(4d0*pi*Decay_aS)
       SMZWidth=SMZWidth+(ZWidth_LOuu*2d0+ZWidth_LOdd*3d0)*Decay_aS/pi
    ENDIF
    IF(qedord.EQ.1)THEN
       IF(PRESENT(Wradin))THEN
          Wrad=Wradin
       ELSE
          Wrad=.FALSE. ! it should be turned off as we don't include W radiation in loop_qcd_qed_sm
       END IF
       SMZWidth=SMZWidth+SMZWidth_EW(Decay_Scheme)
       IF(Wrad)THEN
          SMZWidth=SMZWidth+SM_Z2ffW(0)
       ENDIF
    ENDIF
    RETURN
  END FUNCTION SMZWidth

  FUNCTION SMZWidth_EW(iScheme)
    IMPLICIT NONE
    INTEGER,INTENT(IN)::iScheme ! 1: alpha(MZ) 2: Gmu
    REAL(KIND(1d0))::SMZWidth_EW
    REAL(KIND(1d0)),EXTERNAL::Width_Z2uu_EW,Width_Z2dd_EW,Width_Z2ll_EW,Width_Z2vv_EW
    ! Z > u u~ and Z > c c~
    SMZWidth_EW=2d0*Width_Z2uu_EW(iScheme)
    ! Z > d d~, Z > s s~, Z > b b~
    SMZWidth_EW=SMZWidth_EW+3d0*Width_Z2dd_EW(iScheme)
    ! Z > e+ e-, Z > m+ m-, Z > tt+ tt-
    SMZWidth_EW=SMZWidth_EW+3d0*Width_Z2ll_EW(iScheme)
    ! Z > ve ve~, Z > vm vm~, Z > vt vt~
    SMZWidth_EW=SMZWidth_EW+3d0*Width_Z2vv_EW(iScheme)
    RETURN
  END FUNCTION SMZWIDTH_EW

  FUNCTION SM_Z2ffW(idummy)
    IMPLICIT NONE
    INTEGER,INTENT(IN)::idummy
    REAL(KIND(1d0))::SM_Z2ffW
    REAL(KIND(1d0)),EXTERNAL::Width_Z2udxWm,Width_Z2veepWm
    SM_Z2ffW=Width_Z2udxWm(0)*2d0*2d0
    SM_Z2ffW=SM_Z2ffW+Width_Z2veepWm(0)*2d0*3d0
    RETURN
  END FUNCTION SM_Z2ffW

  FUNCTION SMZWidth_fmass(mc,mb,mtt,mm)
    IMPLICIT NONE
    REAL(KIND(1d0)),INTENT(IN)::mc,mb,mtt,mm
    REAL(KIND(1d0)),EXTERNAL::Width_Z2cc_cmass,Width_Z2bb_bmass,Width_Z2tautau_taumass
    REAL(KIND(1d0))::SMZWidth_fmass
    SMZWidth_fmass=0d0
    IF(mc.GT.0d0)THEN
       SMZWidth_fmass=SMZWidth_fmass+Width_Z2cc_cmass(mc)
    ENDIF
    IF(mb.GT.0d0)THEN
       SMZWidth_fmass=SMZWidth_fmass+Width_Z2bb_bmass(mc)
    ENDIF
    IF(mtt.GT.0d0)THEN
       SMZWidth_fmass=SMZWidth_fmass+Width_Z2tautau_taumass(mtt)
    ENDIF
    IF(mm.GT.0d0)THEN
       SMZWidth_fmass=SMZWidth_fmass+Width_Z2tautau_taumass(mm)
    ENDIF
    RETURN
  END FUNCTION SMZWidth_fmass
END MODULE ZDecay