      subroutine voronoi_center_2d(x1,y1,z1,x2,y2,z2,
     *                   x3,y3,z3,xcnt,ycnt,zcnt)
C
C ######################################################################
C
C        $Log: coefficient.f,v $
C        Revision 2.00  2007/11/05 19:45:50  spchu
C        Import to CVS
C
CPVCS
CPVCS       Rev 1.21   02 Oct 2007 12:40:28   spchu
CPVCS    original version
C
C ######################################################################
C
C
C  calculate voronoi center of a triangle with vertices
C  x1,y1,z1,x2,y2,z2,x3,y3,z3
C  return results in xcnt,ycnt,zcnt
C  code lifted from matbld3d_stor
C
      implicit none
      real*8 x1,y1,z1,x2,y2,z2,x3,y3,z3,xcnt,ycnt,zcnt,
     * xa,ya,za,xb,yb,zb,xc,yc,zc,dotb3,dot3,rb3,ql,xl,yl,zl
C
      xa=x1
      ya=y1
      za=z1
      xb=x2-x1
      yb=y2-y1
      zb=z2-z1
      xc=x3-x1
      yc=y3-y1
      zc=z3-z1
      dotb3=xb*xc+yb*yc+zb*zc
      dot3=dotb3/(xc*xc+yc*yc+zc*zc)
      rb3=1.0/(xb*xb+yb*yb+zb*zb)
      ql=(1.0-dot3)/(1.0-dot3*dotb3*rb3+1.0d-30)
      xl=0.5*(ql*(xc-dotb3*rb3*xb)+xb)
      yl=0.5*(ql*(yc-dotb3*rb3*yb)+yb)
      zl=0.5*(ql*(zc-dotb3*rb3*zb)+zb)
      xcnt=xl+xa
      ycnt=yl+ya
      zcnt=zl+za
C      print *, xcnt,ycnt,zcnt
      if (dotb3.eq.0) then
      xa=x2
      ya=y2
      za=z2
      xb=x3-x2
      yb=y3-y2
      zb=z3-z2
      xc=x1-x2
      yc=y1-y2
      zc=z1-z2
      dotb3=xb*xc+yb*yc+zb*zc
      dot3=dotb3/(xc*xc+yc*yc+zc*zc)
      rb3=1.0/(xb*xb+yb*yb+zb*zb)
      ql=(1.0-dot3)/(1.0-dot3*dotb3*rb3+1.0d-30)
      xl=0.5*(ql*(xc-dotb3*rb3*xb)+xb)
      yl=0.5*(ql*(yc-dotb3*rb3*yb)+yb)
      zl=0.5*(ql*(zc-dotb3*rb3*zb)+zb)
      xcnt=xl+xa
      ycnt=yl+ya
      zcnt=zl+za
      endif
      return
      end
      subroutine coefficient(x1,y1,z1,x2,y2,z2,x3,y3,z3,x4,y4,z4,
     *     xcoef,ycoef,zcoef)
c#######################################################################
c
c     purpose -
c
C  calculate the contribution to the coupling coefficient of node1
C  (x1,y1,z1) to node2 (x2,y2,z2)
C  node3 (x3,y3,z3) is the third node of the face in question
C  node4 (x4,y4,z4) is the fourth node of the tet
C
C  input arguments
C     x1,y1,z1,x2,y2,z2,x3,y3,z3,x4,y4,z4  nodes defining the tet
C
C  ouput arguments
C     xcoef,ycoef,zcoef - vector area determined by the midpoint of
C       edge from (x1,y1,z2) to (x2,y2,z2) the voronoi point of the
C       tet and the 2d voronoi point of the two faces containing the
C       edge
C
c#######################################################################
      implicit none
      real*8 x1,y1,z1,x2,y2,z2,x3,y3,z3,x4,y4,z4,xcoef,ycoef,zcoef,
     *   xvor,yvor,zvor,radius,xm,ym,zm,ax1,ay1,az1,
     *   xv2d1,yv2d1,zv2d1,xv2d2,yv2d2,zv2d2,ax2,ay2,az2
C
C  get the voronoi center of the tet
C
      call voronoi_center(x1,y1,z1,x2,y2,z2,x3,y3,z3,
     *  x4,y4,z4,xvor,yvor,zvor,radius)
C
C  get the voronoi center of the two faces that share the edge
C
      call voronoi_center_2d(x1,y1,z1,x2,y2,z2,x3,y3,z3,
     *   xv2d1,yv2d1,zv2d1)
      call voronoi_center_2d(x2,y2,z2,x1,y1,z1,x4,y4,z4,
     *   xv2d2,yv2d2,zv2d2)
C
C  get midpoint of edge
C
      xm=(x2+x1)*0.5
      ym=(y2+y1)*0.5
      zm=(z2+z1)*0.5
C
C  calculate vector area of triangle determined by the tet
C  voronoi point one of the triangle voronoi points and the
C  midpoint of the edge
C
      ax1=  (yv2d1-ym)*(zvor-zm)-(yvor-ym)*(zv2d1-zm)
      ay1=-((xv2d1-xm)*(zvor-zm)-(xvor-xm)*(zv2d1-zm))
      az1=  (xv2d1-xm)*(yvor-ym)-(xvor-xm)*(yv2d1-ym)

C  repeat for second face
      ax2=-((yv2d2-ym)*(zvor-zm)-(yvor-ym)*(zv2d2-zm))
      ay2=  (xv2d2-xm)*(zvor-zm)-(xvor-xm)*(zv2d2-zm)
      az2=-((xv2d2-xm)*(yvor-ym)-(xvor-xm)*(yv2d2-ym))

      xcoef= - ax1 -ax2
      ycoef= - ay1 -ay2
      zcoef= - az1 -az2
      return
      end


      SUBROUTINE BESSEL (Z,J0,J0P)
C
C     BESSEL EVALUATES THE ZERO-ORDER BESSEL FUNCTION AND ITS DERIVATIVE
C     FOR COMPLEX ARGUMENT Z.
C
      COMPLEX J0,J0P,P0Z,P1Z,Q0Z,Q1Z,Z,ZI,ZI2,ZK,FJ,CZ,SZ,J0X,J0PX
      DIMENSION M(101), A1(25), A2(25), FJX(2)
      EQUIVALENCE (FJ,FJX)
      DATA PI,C3,P10,P20,Q10,Q20/3.141592654,.7978845608,.0703125,.11215
     120996,.125,.0732421875/
      DATA P11,P21,Q11,Q21/.1171875,.1441955566,.375,.1025390625/
      DATA POF,INIT/.7853981635,0/,FJX/0.,1./
      IF (INIT.EQ.0) GO TO 5
1     ZMS=Z*CONJG(Z)
      IF (ZMS.GT.1.E-12) GO TO 2
      J0=(1.,0.)
      J0P=-.5*Z
      RETURN
2     IB=0
      IF (ZMS.GT.37.21) GO TO 4
      IF (ZMS.GT.36.) IB=1
C     SERIES EXPANSION
      IZ=1.+ZMS
      MIZ=M(IZ)
      J0=(1.,0.)
      J0P=J0
      ZK=J0
      ZI=Z*Z
      DO 3 K=1,MIZ
      ZK=ZK*A1(K)*ZI
      J0=J0+ZK
3     J0P=J0P+A2(K)*ZK
      J0P=-.5*Z*J0P
      IF (IB.EQ.0) RETURN
      J0X=J0
      J0PX=J0P
C     ASYMPTOTIC EXPANSION
4     ZI=1./Z
      ZI2=ZI*ZI
      P0Z=1.+(P20*ZI2-P10)*ZI2
      P1Z=1.+(P11-P21*ZI2)*ZI2
      Q0Z=(Q20*ZI2-Q10)*ZI
      Q1Z=(Q11-Q21*ZI2)*ZI
      ZK=CEXP(FJ*(Z-POF))
      ZI2=1./ZK
      CZ=.5*(ZK+ZI2)
      SZ=FJ*.5*(ZI2-ZK)
      ZK=C3*CSQRT(ZI)
      J0=ZK*(P0Z*CZ-Q0Z*SZ)
      J0P=-ZK*(P1Z*SZ+Q1Z*CZ)
      IF (IB.EQ.0) RETURN
      ZMS=COS((SQRT(ZMS)-6.)*31.41592654)
      J0=.5*(J0X*(1.+ZMS)+J0*(1.-ZMS))
      J0P=.5*(J0PX*(1.+ZMS)+J0P*(1.-ZMS))
      RETURN
C     INITIALIZATION OF CONSTANTS
5     DO 6 K=1,25
      A1(K)=-.25/(K*K)
6     A2(K)=1./(K+1.)
      DO 8 I=1,101
      TEST=1.
      DO 7 K=1,24
      INIT=K
      TEST=-TEST*I*A1(K)
      IF (TEST.LT.1.E-6) GO TO 8
7     CONTINUE
8     M(I)=INIT
      GO TO 1
      END


      SUBROUTINE AG08BZ( EQUIL, L, N, M, P, A, LDA, E, LDE, B, LDB,
     $                   C, LDC, D, LDD, NFZ, NRANK, NIZ, DINFZ, NKROR,
     $                   NINFE, NKROL, INFZ, KRONR, INFE, KRONL,
     $                   TOL, IWORK, DWORK, ZWORK, LZWORK, INFO )
C
C     SLICOT RELEASE 5.5.
C
C     Copyright (c) 2002-2012 NICONET e.V.
C
C     PURPOSE
C
C     To extract from the system pencil
C
C                       ( A-lambda*E B )
C           S(lambda) = (              )
C                       (      C     D )
C
C     a regular pencil Af-lambda*Ef which has the finite Smith zeros of
C     S(lambda) as generalized eigenvalues. The routine also computes
C     the orders of the infinite Smith zeros and determines the singular
C     and infinite Kronecker structure of system pencil, i.e., the right
C     and left Kronecker indices, and the multiplicities of infinite
C     eigenvalues.
C
C     ARGUMENTS
C
C     Mode Parameters
C
C     EQUIL   CHARACTER*1
C             Specifies whether the user wishes to balance the system
C             matrix as follows:
C             = 'S':  Perform balancing (scaling);
C             = 'N':  Do not perform balancing.
C
C     Input/Output Parameters
C
C     L       (input) INTEGER
C             The number of rows of matrices A, B, and E.  L >= 0.
C
C     N       (input) INTEGER
C             The number of columns of matrices A, E, and C.  N >= 0.
C
C     M       (input) INTEGER
C             The number of columns of matrix B.  M >= 0.
C
C     P       (input) INTEGER
C             The number of rows of matrix C.  P >= 0.
C
C     A       (input/output) COMPLEX*16 array, dimension (LDA,N)
C             On entry, the leading L-by-N part of this array must
C             contain the state dynamics matrix A of the system.
C             On exit, the leading NFZ-by-NFZ part of this array
C             contains the matrix Af of the reduced pencil.
C
C     LDA     INTEGER
C             The leading dimension of array A.  LDA >= MAX(1,L).
C
C     E       (input/output) COMPLEX*16 array, dimension (LDE,N)
C             On entry, the leading L-by-N part of this array must
C             contain the descriptor matrix E of the system.
C             On exit, the leading NFZ-by-NFZ part of this array
C             contains the matrix Ef of the reduced pencil.
C
C     LDE     INTEGER
C             The leading dimension of array E.  LDE >= MAX(1,L).
C
C     B       (input/output) COMPLEX*16 array, dimension (LDB,M)
C             On entry, the leading L-by-M part of this array must
C             contain the input/state matrix B of the system.
C             On exit, this matrix does not contain useful information.
C
C     LDB     INTEGER
C             The leading dimension of array B.
C             LDB >= MAX(1,L) if M > 0;
C             LDB >= 1        if M = 0.
C
C     C       (input/output) COMPLEX*16 array, dimension (LDC,N)
C             On entry, the leading P-by-N part of this array must
C             contain the state/output matrix C of the system.
C             On exit, this matrix does not contain useful information.
C
C     LDC     INTEGER
C             The leading dimension of array C.  LDC >= MAX(1,P).
C
C     D       (input) COMPLEX*16 array, dimension (LDD,M)
C             The leading P-by-M part of this array must contain the
C             direct transmission matrix D of the system.
C
C     LDD     INTEGER
C             The leading dimension of array D.  LDD >= MAX(1,P).
C
C     NFZ     (output) INTEGER
C             The number of finite zeros.
C
C     NRANK   (output) INTEGER
C             The normal rank of the system pencil.
C
C     NIZ     (output) INTEGER
C             The number of infinite zeros.
C
C     DINFZ   (output) INTEGER
C             The maximal multiplicity of infinite Smith zeros.
C
C     NKROR   (output) INTEGER
C             The number of right Kronecker indices.
C
C     NINFE   (output) INTEGER
C             The number of elementary infinite blocks.
C
C     NKROL   (output) INTEGER
C             The number of left Kronecker indices.
C
C     INFZ    (output) INTEGER array, dimension (N+1)
C             The leading DINFZ elements of INFZ contain information
C             on the infinite elementary divisors as follows:
C             the system has INFZ(i) infinite elementary divisors of
C             degree i in the Smith form, where i = 1,2,...,DINFZ.
C
C     KRONR   (output) INTEGER array, dimension (N+M+1)
C             The leading NKROR elements of this array contain the
C             right Kronecker (column) indices.
C
C     INFE    (output) INTEGER array, dimension (1+MIN(L+P,N+M))
C             The leading NINFE elements of INFE contain the
C             multiplicities of infinite eigenvalues.
C
C     KRONL   (output) INTEGER array, dimension (L+P+1)
C             The leading NKROL elements of this array contain the
C             left Kronecker (row) indices.
C
C     Tolerances
C
C     TOL     DOUBLE PRECISION
C             A tolerance used in rank decisions to determine the
C             effective rank, which is defined as the order of the
C             largest leading (or trailing) triangular submatrix in the
C             QR (or RQ) factorization with column (or row) pivoting
C             whose estimated condition number is less than 1/TOL.
C             If the user sets TOL <= 0, then default tolerances are
C             used instead, as follows: TOLDEF = L*N*EPS in TG01FZ
C             (to determine the rank of E) and TOLDEF = (L+P)*(N+M)*EPS
C             in the rest, where EPS is the machine precision
C             (see LAPACK Library routine DLAMCH).  TOL < 1.
C
C     Workspace
C
C     IWORK   INTEGER array, dimension N+max(1,M)
C             On output, IWORK(1) contains the normal rank of the
C             transfer function matrix.
C
C     DWORK   DOUBLE PRECISION array, dimension (LDWORK)
C             LDWORK >= max(4*(L+N), 2*max(L+P,M+N))), if EQUIL = 'S',
C             LDWORK >= 2*max(L+P,M+N)),               if EQUIL = 'N'.
C
C     ZWORK   COMPLEX*16 array, dimension (LZWORK)
C             On exit, if INFO = 0, ZWORK(1) returns the optimal value
C             of LZWORK.
C
C     LZWORK  INTEGER
C             The length of the array ZWORK.
C             LZWORK >= max( max(L+P,M+N)*(M+N) +
C                            max(min(L+P,M+N) + max(min(L,N),3*(M+N)-1),
C                                3*(L+P), 1))
C             For optimum performance LZWORK should be larger.
C
C             If LZWORK = -1, then a workspace query is assumed;
C             the routine only calculates the optimal size of the
C             ZWORK array, returns this value as the first entry of
C             the ZWORK array, and no error message related to LZWORK
C             is issued by XERBLA.
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 routine extracts from the system matrix of a descriptor
C     system (A-lambda*E,B,C,D) a regular pencil Af-lambda*Ef which
C     has the finite zeros of the system as generalized eigenvalues.
C     The procedure has the following main computational steps:
C
C        (a) construct the (L+P)-by-(N+M) system pencil
C
C             S(lambda) = ( B  A )-lambda*( 0  E );
C                         ( D  C )        ( 0  0 )
C
C        (b) reduce S(lambda) to S1(lambda) with the same finite
C            zeros and right Kronecker structure but with E
C            upper triangular and nonsingular;
C
C        (c) reduce S1(lambda) to S2(lambda) with the same finite
C            zeros and right Kronecker structure but with D of
C            full row rank;
C
C        (d) reduce S2(lambda) to S3(lambda) with the same finite zeros
C            and with D square invertible;
C
C        (e) perform a unitary transformation on the columns of
C
C            S3(lambda) = (A-lambda*E   B) in order to reduce it to
C                         (     C       D)
C
C            (Af-lambda*Ef   X), with Y and Ef square invertible;
C            (     0         Y)
C
C        (f) compute the right and left Kronecker indices of the system
C            matrix, which together with the multiplicities of the
C            finite and infinite eigenvalues constitute the
C            complete set of structural invariants under strict
C            equivalence transformations of a linear system.
C
C     REFERENCES
C
C     [1] P. Misra, P. Van Dooren and A. Varga.
C         Computation of structural invariants of generalized
C         state-space systems.
C         Automatica, 30, pp. 1921-1936, 1994.
C
C     NUMERICAL ASPECTS
C
C     The algorithm is backward stable (see [1]).
C
C     FURTHER COMMENTS
C
C     In order to compute the finite Smith zeros of the system
C     explicitly, a call to this routine may be followed by a
C     call to the LAPACK Library routines ZGEGV or ZGGEV.
C
C     CONTRIBUTOR
C
C     A. Varga, German Aerospace Center, DLR Oberpfaffenhofen,
C     May 1999.
C     Complex version: V. Sima, Research Institute for Informatics,
C     Bucharest, Nov. 2008.
C
C     REVISIONS
C
C     V. Sima, Research Institute for Informatics, Bucharest, Mar. 2009,
C     Apr. 2009, Apr. 2011.
C
C     KEYWORDS
C
C     Generalized eigenvalue problem, Kronecker indices, multivariable
C     system, unitary transformation, structural invariant.
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION  ONE, ZERO
      PARAMETER         ( ONE = 1.0D0, ZERO = 0.0D0 )
      COMPLEX*16         CZERO
      PARAMETER         ( CZERO = ( 0.0D+0, 0.0D+0 ) )
C     .. Scalar Arguments ..
      CHARACTER         EQUIL
      INTEGER           DINFZ, INFO, L, LDA, LDB, LDC, LDD, LDE, LZWORK,
     $                  M, N, NFZ, NINFE, NIZ, NKROL, NKROR, NRANK, P
      DOUBLE PRECISION  TOL
C     .. Array Arguments ..
      INTEGER           INFE(*), INFZ(*), IWORK(*), KRONL(*), KRONR(*)
      DOUBLE PRECISION  DWORK(*)
      COMPLEX*16        A(LDA,*), B(LDB,*), C(LDC,*), D(LDD,*),
     $                  E(LDE,*), ZWORK(*)
C     .. Local Scalars ..
      LOGICAL           LEQUIL, LQUERY
      INTEGER           I, I0, I1, II, IPD, ITAU, J, JWORK, KABCD,
     $                  LABCD2, LDABCD, LZW, MM, MU, N2, NN, NSINFE, NU,
     $                  NUMU, PP, WRKOPT
      DOUBLE PRECISION  SVLMAX, TOLER
C     .. Local Arrays ..
      COMPLEX*16        DUM(1)
C     .. External Functions ..
      LOGICAL           LSAME
      DOUBLE PRECISION  DLAMCH, ZLANGE
      EXTERNAL          DLAMCH, LSAME, ZLANGE
C     .. External Subroutines ..
      EXTERNAL          AG8BYZ, MA02BZ, MA02CZ, TB01XZ, TG01AZ, TG01FZ,
     $                  XERBLA, ZLACPY, ZLASET, ZTZRZF, ZUNMRZ
C     .. Intrinsic Functions ..
      INTRINSIC         DBLE, INT, MAX, MIN
C     .. Executable Statements ..
C
      INFO = 0
      LDABCD = MAX( L+P, N+M )
      LABCD2 = LDABCD*( N+M )
      LEQUIL = LSAME( EQUIL, 'S' )
      LQUERY = ( LZWORK.EQ.-1 )
C
C     Test the input scalar arguments.
C
      IF( .NOT.LEQUIL .AND. .NOT.LSAME( EQUIL, 'N' ) ) THEN
         INFO = -1
      ELSE IF( L.LT.0 ) THEN
         INFO = -2
      ELSE IF( N.LT.0 ) THEN
         INFO = -3
      ELSE IF( M.LT.0 ) THEN
         INFO = -4
      ELSE IF( P.LT.0 ) THEN
         INFO = -5
      ELSE IF( LDA.LT.MAX( 1, L ) ) THEN
         INFO = -7
      ELSE IF( LDE.LT.MAX( 1, L ) ) THEN
         INFO = -9
      ELSE IF( LDB.LT.1 .OR. ( M.GT.0 .AND. LDB.LT.L ) ) THEN
         INFO = -11
      ELSE IF( LDC.LT.MAX( 1, P ) ) THEN
         INFO = -13
      ELSE IF( LDD.LT.MAX( 1, P ) ) THEN
         INFO = -15
      ELSE IF( TOL.GE.ONE ) THEN
         INFO = -27
      ELSE
         I0  = MIN( L+P, M+N )
         I1  = MIN( L, N )
         II  = MIN( M, P )
         LZW = MAX( 1, LABCD2 + MAX( I0 + MAX( I1, 3*( M+N ) - 1 ),
     $                               3*( L+P ) ) )
         IF( LQUERY ) THEN
            I = MAX( 1, LDABCD+I1 )
            J = MAX( 1, LDABCD )
            CALL TG01FZ( 'N', 'N', 'N', L, N, M, P, A, LDA, E, LDE, B,
     $                   LDB, C, LDC, DUM, 1, DUM, 1, NN, N2, TOL,
     $                   IWORK, DWORK, ZWORK, -1, INFO )
            WRKOPT = MAX( LZW, INT( ZWORK(1) ) )
            SVLMAX = ZERO
            CALL AG8BYZ( .TRUE., I1, M+N, P+L, SVLMAX, ZWORK, I, E, LDE,
     $                   NU, MU, NIZ, DINFZ, NKROL, INFZ, KRONL, TOL,
     $                   IWORK, DWORK, ZWORK, -1, INFO )
            WRKOPT = MAX( WRKOPT, LABCD2 + INT( ZWORK(1) ) )
            CALL AG8BYZ( .FALSE., I1, II, M+N, SVLMAX, ZWORK, I, E, LDE,
     $                   NU, MU, NIZ, DINFZ, NKROL, INFZ, KRONL, TOL,
     $                   IWORK, DWORK, ZWORK, -1, INFO )
            WRKOPT = MAX( WRKOPT, LABCD2 + INT( ZWORK(1) ) )
            CALL ZTZRZF( II, I1+II, ZWORK, J, ZWORK, ZWORK, -1, INFO )
            WRKOPT = MAX( WRKOPT, LABCD2 + II + INT( ZWORK(1) ) )
            CALL ZUNMRZ( 'Right', 'Conjugate transpose', I1, I1+II, II,
     $                   I1, ZWORK, J, ZWORK, ZWORK, J, ZWORK, -1,
     $                   INFO )
            WRKOPT = MAX( WRKOPT, LABCD2 + II + INT( ZWORK(1) ) )
         ELSE IF( LZWORK.LT.LZW ) THEN
            INFO = -31
         END IF
      END IF
C
      IF( INFO.NE.0 ) THEN
C
C        Error return.
C
         CALL XERBLA( 'AG08BZ', -INFO )
         RETURN
      ELSE IF( LQUERY ) THEN
         ZWORK(1) = WRKOPT
         RETURN
      END IF
C
      NIZ = 0
      NKROL = 0
      NKROR = 0
C
C     Quick return if possible.
C
      IF( MAX( L, N, M, P ).EQ.0 ) THEN
         NFZ = 0
         DINFZ = 0
         NINFE = 0
         NRANK = 0
         IWORK(1) = 0
         ZWORK(1) = ONE
         RETURN
      END IF
C
C     (Note: Comments in the code beginning "CWorkspace:", "RWorkspace:"
C     and "IWorkspace:" describe the minimal amount of complex, real and
C     integer workspace, respectively, needed at that point in the code,
C     as well as the preferred amount for good performance.)
C
      WRKOPT = 1
      KABCD  = 1
      JWORK  = KABCD + LABCD2
C
C     If required, balance the system pencil.
C     RWorkspace: need   4*(L+N).
C
      IF( LEQUIL ) THEN
         CALL TG01AZ( 'A', L, N, M, P, ZERO, A, LDA, E, LDE, B, LDB,
     $                C, LDC, DWORK, DWORK(L+1), DWORK(L+N+1), INFO )
      END IF
      SVLMAX = ZLANGE( 'Frobenius', L, N, E, LDE, DWORK )
C
C     Reduce the system matrix to QR form,
C
C          ( A11-lambda*E11 A12 B1 )
C          (     A21        A22 B2 ) ,
C          (     C1         C2  D  )
C
C     with E11 invertible and upper triangular.
C     IWorkspace: need   N.
C     RWorkspace: need   2*N.
C     CWorkspace: need   max( 1, N+P, min(L,N)+max(3*N-1,M,L) );
C                 prefer larger.
C
      CALL TG01FZ( 'N', 'N', 'N', L, N, M, P, A, LDA, E, LDE, B, LDB,
     $             C, LDC, DUM, 1, DUM, 1, NN, N2, TOL, IWORK, DWORK,
     $             ZWORK, LZWORK, INFO )
      WRKOPT = MAX( WRKOPT, INT( ZWORK(1) ) )
C
C     Construct the system pencil
C
C                          MM         NN
C                      ( B1 A12 A11-lambda*E11 ) NN
C        S1(lambda) =  ( B2 A22      A21       ) L-NN
C                      ( D  C2       C1        ) P
C
C     of dimension (L+P)-by-(M+N).
C     CWorkspace: need  LABCD2 = max( L+P, N+M )*( N+M ).
C
      N2 = N - NN
      MM = M + N2
      PP = P + ( L - NN )
      CALL ZLACPY( 'Full', L, M, B, LDB, ZWORK(KABCD), LDABCD )
      CALL ZLACPY( 'Full', P, M, D, LDD, ZWORK(KABCD+L), LDABCD )
      CALL ZLACPY( 'Full', L, N2, A(1,NN+1), LDA,
     $              ZWORK(KABCD+LDABCD*M), LDABCD )
      CALL ZLACPY( 'Full', P, N2, C(1,NN+1), LDC,
     $              ZWORK(KABCD+LDABCD*M+L), LDABCD )
      CALL ZLACPY( 'Full', L, NN, A, LDA,
     $              ZWORK(KABCD+LDABCD*MM), LDABCD )
      CALL ZLACPY( 'Full', P, NN, C, LDC,
     $              ZWORK(KABCD+LDABCD*MM+L), LDABCD )
C
C     If required, set tolerance.
C
      TOLER = TOL
      IF( TOLER.LE.ZERO ) THEN
         TOLER = DBLE( ( L + P )*( M + N ) ) * DLAMCH( 'Precision' )
      END IF
      SVLMAX = MAX( SVLMAX,
     $              ZLANGE( 'Frobenius', NN+PP, NN+MM, ZWORK(KABCD),
     $                      LDABCD, DWORK ) )
C
C     Extract the reduced pencil S2(lambda)
C
C             ( Bc  Ac-lambda*Ec )
C             ( Dc      Cc       )
C
C     having the same finite Smith zeros as the system pencil
C     S(lambda) but with Dc, a MU-by-MM full row rank
C     left upper trapezoidal matrix, and Ec, an NU-by-NU
C     upper triangular nonsingular matrix.
C
C     IWorkspace: need   MM,            MM <= M+N;
C     RWorkspace: need   2*max(MM,PP);  PP <= P+L;
C     CWorkspace: need   max( min(P+L,M+N)+max(min(L,N),3*(M+N)-1),
C                              3*(P+L), 1 ) + LABCD2;
C                 prefer larger.
C
      CALL AG8BYZ( .TRUE., NN, MM, PP, SVLMAX, ZWORK(KABCD), LDABCD,
     $             E, LDE, NU, MU, NIZ, DINFZ, NKROL, INFZ, KRONL,
     $             TOLER, IWORK, DWORK, ZWORK(JWORK), LZWORK-JWORK+1,
     $             INFO )
C
      WRKOPT = MAX( WRKOPT, INT( ZWORK(JWORK) ) + JWORK - 1 )
C
C     Set the number of simple (nondynamic) infinite eigenvalues
C     and the normal rank of the system pencil.
C
      NSINFE = MU
      NRANK  = NN + MU
C
C     Pertranspose the system.
C
      CALL TB01XZ( 'D', NU, MM, MM, MAX( 0, NU-1 ), MAX( 0, NU-1 ),
     $              ZWORK(KABCD+LDABCD*MM), LDABCD,
     $              ZWORK(KABCD), LDABCD,
     $              ZWORK(KABCD+LDABCD*MM+NU), LDABCD,
     $              ZWORK(KABCD+NU), LDABCD, INFO )
      CALL MA02BZ( 'Right', NU+MM, MM, ZWORK(KABCD), LDABCD )
      CALL MA02BZ( 'Left',  MM, NU+MM, ZWORK(KABCD+NU), LDABCD )
      CALL MA02CZ( NU, 0, MAX( 0, NU-1 ), E, LDE )
C
      IF( MU.NE.MM ) THEN
         NN = NU
         PP = MM
         MM = MU
         KABCD = KABCD + ( PP - MM )*LDABCD
C
C        Extract the reduced pencil S3(lambda),
C
C             ( Br  Ar-lambda*Er ) ,
C             ( Dr      Cr       )
C
C        having the same finite Smith zeros as the pencil S(lambda),
C        but with Dr, an MU-by-MU invertible upper triangular matrix,
C        and Er, an NU-by-NU upper triangular nonsingular matrix.
C
C        IWorkspace: need   0;
C        RWorkspace: need   2*(M+N);
C        CWorkspace: need   max( 1, 3*(M+N) ) + LABCD2.
C                    prefer larger.
C
         CALL AG8BYZ( .FALSE., NN, MM, PP, SVLMAX, ZWORK(KABCD), LDABCD,
     $                E, LDE, NU, MU, I0, I1, NKROR, IWORK, KRONR,
     $                TOLER, IWORK, DWORK, ZWORK(JWORK), LZWORK-JWORK+1,
     $                INFO )
C
         WRKOPT = MAX( WRKOPT, INT( ZWORK(JWORK) ) + JWORK - 1 )
      END IF
C
      IF( NU.NE.0 ) THEN
C
C        Perform a unitary transformation on the columns of
C                     ( Br Ar-lambda*Er )
C                     ( Dr     Cr       )
C        in order to reduce it to
C                     ( *  Af-lambda*Ef )
C                     ( Y       0       )
C        with Y and Ef square invertible.
C
C        Compute Af by reducing  ( Br Ar ) to  ( *  Af ) .
C                                ( Dr Cr )     ( Y   0 )
C
         NUMU  = NU + MU
         IPD   = KABCD + NU
         ITAU  = JWORK
         JWORK = ITAU + MU
C
C        CWorkspace: need   LABCD2 + 2*min(M,P);
C                    prefer LABCD2 + min(M,P) + min(M,P)*NB.
C
         CALL ZTZRZF( MU, NUMU, ZWORK(IPD), LDABCD, ZWORK(ITAU),
     $                ZWORK(JWORK), LZWORK-JWORK+1, INFO )
         WRKOPT = MAX( WRKOPT, INT( ZWORK(JWORK) ) + JWORK - 1 )
C
C        CWorkspace: need   LABCD2 + min(M,P) + min(L,N);
C                    prefer LABCD2 + min(M,P) + min(L,N)*NB.
C
         CALL ZUNMRZ( 'Right', 'Conjugate transpose', NU, NUMU, MU, NU,
     $                ZWORK(IPD), LDABCD, ZWORK(ITAU), ZWORK(KABCD),
     $                LDABCD, ZWORK(JWORK), LZWORK-JWORK+1, INFO )
         WRKOPT = MAX( WRKOPT, INT( ZWORK(JWORK) ) + JWORK - 1 )
C
C        Save Af.
C
         CALL ZLACPY( 'Full', NU, NU, ZWORK(KABCD+LDABCD*MU), LDABCD, A,
     $                LDA )
C
C        Compute Ef by applying the saved transformations from previous
C        reduction to ( 0  Er ) .
C
         CALL ZLASET( 'Full', NU, MU, CZERO, CZERO, ZWORK(KABCD),
     $                LDABCD )
         CALL ZLACPY( 'Full', NU, NU, E, LDE, ZWORK(KABCD+LDABCD*MU),
     $                LDABCD )
C
         CALL ZUNMRZ( 'Right', 'Conjugate transpose', NU, NUMU, MU, NU,
     $                ZWORK(IPD), LDABCD, ZWORK(ITAU), ZWORK(KABCD),
     $                LDABCD, ZWORK(JWORK), LZWORK-JWORK+1, INFO )
C
C        Save Ef.
C
         CALL ZLACPY( 'Full', NU, NU, ZWORK(KABCD+LDABCD*MU), LDABCD, E,
     $                LDE )
      END IF
C
      NFZ = NU
C
C     Set right Kronecker indices (column indices).
C
      DO 10 I = 1, NKROR
         IWORK(I) = KRONR(I)
   10 CONTINUE
C
      J = 0
      DO 30 I = 1, NKROR
         DO 20 II = J + 1, J + IWORK(I)
            KRONR(II) = I - 1
   20    CONTINUE
         J = J + IWORK(I)
   30 CONTINUE
C
      NKROR = J
C
C     Set left Kronecker indices (row indices).
C
      DO 40 I = 1, NKROL
         IWORK(I) = KRONL(I)
   40 CONTINUE
C
      J = 0
      DO 60 I = 1, NKROL
         DO 50 II = J + 1, J + IWORK(I)
            KRONL(II) = I - 1
   50    CONTINUE
         J = J + IWORK(I)
   60 CONTINUE
C
      NKROL = J
C
C     Determine the number of simple infinite blocks
C     as the difference between the number of infinite blocks
C     of order greater than one and the order of Dr.
C
      NINFE = 0
      DO 70 I = 1, DINFZ
         NINFE = NINFE + INFZ(I)
   70 CONTINUE
      NINFE = NSINFE - NINFE
      DO 80 I = 1, NINFE
         INFE(I) = 1
   80 CONTINUE
C
C     Set the structure of infinite eigenvalues.
C
      DO 100 I = 1, DINFZ
         DO 90 II = NINFE + 1, NINFE + INFZ(I)
            INFE(II) = I + 1
   90    CONTINUE
         NINFE = NINFE + INFZ(I)
  100 CONTINUE
C
      IWORK(1) = NSINFE
      ZWORK(1) = WRKOPT
      RETURN
C *** Last line of AG08BZ ***
      END


      subroutine drspln(i1,i2,x,y,q,f)
      implicit real*8(a-h,o-z)
c   rspln computes cubic spline interpolation coefficients
c   for y(x) between grid points i1 and i2 saving them in q.  the
c   interpolation is continuous with continuous first and second
c   derivitives.  it agrees exactly with y at grid points and with the
c   three point first derivitives at both end points (i1 and i2).
c   x must be monotonic but if two successive values of x are equal
c   a discontinuity is assumed and seperate interpolation is done on
c   each strictly monotonic segment.  the arrays must be dimensioned at
c   least - x(i2), y(i2), q(3,i2), and f(3,i2).  f is working storage
c   for rspln.
c                                                     -rpb
      dimension x(1),y(1),q(3,1),f(3,1),yy(3)
      equivalence (yy(1),y0)
      data yy/3*0.d0/
      j1=i1+1
      y0=0.d0
c   bail out if there are less than two points total.
      if(i2-i1)13,17,8
 8    a0=x(j1-1)
c   search for discontinuities.
      do 3 i=j1,i2
      b0=a0
      a0=x(i)
      if(a0-b0)3,4,3
 3    continue
 17   j1=j1-1
      j2=i2-2
      go to 5
 4    j1=j1-1
      j2=i-3
c   see if there are enough points to interpolate (at least three).
 5    if(j2+1-j1)9,10,11
c   only two points.  use linear interpolation.
 10   j2=j2+2
      y0=(y(j2)-y(j1))/(x(j2)-x(j1))
      do 15 j=1,3
      q(j,j1)=yy(j)
 15   q(j,j2)=yy(j)
      go to 12
c   more than two points.  do spline interpolation.
 11   a0=0.d0
      h=x(j1+1)-x(j1)
      h2=x(j1+2)-x(j1)
      y0=h*h2*(h2-h)
      h=h*h
      h2=h2*h2
c   calculate derivitive at near end.
      b0=(y(j1)*(h-h2)+y(j1+1)*h2-y(j1+2)*h)/y0
      b1=b0
c   explicitly reduce banded matrix to an upper banded matrix.
      do 1 i=j1,j2
      h=x(i+1)-x(i)
      y0=y(i+1)-y(i)
      h2=h*h
      ha=h-a0
      h2a=h-2.d0*a0
      h3a=2.d0*h-3.*a0
      h2b=h2*b0
      q(1,i)=h2/ha
      q(2,i)=-ha/(h2a*h2)
      q(3,i)=-h*h2a/h3a
      f(1,i)=(y0-h*b0)/(h*ha)
      f(2,i)=(h2b-y0*(2.d0*h-a0))/(h*h2*h2a)
      f(3,i)=-(h2b-3.d0*y0*ha)/(h*h3a)
      a0=q(3,i)
 1    b0=f(3,i)
c   take care of last two rows.
      i=j2+1
      h=x(i+1)-x(i)
      y0=y(i+1)-y(i)
      h2=h*h
      ha=h-a0
      h2a=h*ha
      h2b=h2*b0-y0*(2.d0*h-a0)
      q(1,i)=h2/ha
      f(1,i)=(y0-h*b0)/h2a
      ha=x(j2)-x(i+1)
      y0=-h*ha*(ha+h)
      ha=ha*ha
c   calculate derivitive at far end.
      y0=(y(i+1)*(h2-ha)+y(i)*ha-y(j2)*h2)/y0
      q(3,i)=(y0*h2a+h2b)/(h*h2*(h-2.d0*a0))
      q(2,i)=f(1,i)-q(1,i)*q(3,i)
c   solve upper banded matrix by reverse iteration.
      do 2 j=j1,j2
      k=i-1
      q(1,i)=f(3,k)-q(3,k)*q(2,i)
      q(3,k)=f(2,k)-q(2,k)*q(1,i)
      q(2,k)=f(1,k)-q(1,k)*q(3,k)
 2    i=k
      q(1,i)=b1
c   fill in the last point with a linear extrapolation.
 9    j2=j2+2
      do 14 j=1,3
 14   q(j,j2)=yy(j)
c   see if this discontinuity is the last.
 12   if(j2-i2)6,13,13
c   no.  go back for more.
 6    j1=j2+2
      if(j1-i2)8,8,7
c   there is only one point left after the latest discontinuity.
 7    do 16 j=1,3
 16   q(j,i2)=yy(j)
c   fini.
 13   return
      end


c*****************************************************************
c* Subroutine CELLA:   Creates COMMON block /mata/ containing
c* all necessary information for anisotropy cellular grid
c* map on the sphere.
c* Call from command line: cell n_pntt lat_normal lon_normal azimuth
c* n_pntt             - define the total number of cells by formula:
c*                     n=6*(2*n_pntt +1)*(2*n_pntt +1)
c*****************************************************************
      SUBROUTINE CELLA(na_pntt)
      IMPLICIT NONE
      include "line.h"
      include "linea.h"
c TYPE definitions ++++++++++++++++++++++++++++++++++++++
      real*8    def
      real*8    dlincell,dsqcell,dd
      integer*4 i,k,na_pntt
c END TYPE definitions ++++++++++++++++++++++++++++++++++
c************* Input parameters**********************************
      k=na_pntt
c************* END input parameters**********************************
c* Spere radius sqrt(3)
      nda=2*k+1
      nnda=nda*nda
      do 10 i=0,k
      def=dpi*DFLOAT((2*i+1)*(2*i+1))/DFLOAT((2*k+1)*(2*k+1))/6.0d0
      dta(k+2+i)=DACOS(DCOS(def)/(1.d0 + DSIN(def)))
      dra(k+2+i)=DTAN(dta(k+2+i))/DSQRT(2.0d0)
   10 dra(k+1-i)=-dra(k+2+i)
      dd=360.d0/2.d0/dpi
      dd=dd*dd
      dsqcell=4.0d0*dpi*dd/FLOAT(nda)/FLOAT(nda)/6.0d0
      dlincell=DSQRT(dsqcell)
      write(8,'("Anisotropy grid cells:")')
      write(*,'("Anisotropy grid cells:")')
      write(*,'(" Average square of cells is:" f17.10," (deg**2)")') dsqcell
      write(8,'(" Average square of cells is:" f17.10," (deg**2)")') dsqcell
      write(*,'(" Average length of cells is:" f17.10," (deg)")') dlincell
      write(8,'(" Average length of cells is:" f17.10," (deg)")') dlincell
      return
      end
c********************************************************
      SUBROUTINE SQUAREA(i,j,k,sq)
      IMPLICIT NONE
      include "line.h"
      include "linea.h"
c TYPE definitions ++++++++++++++++++++++++++++++++++++++
      real*8 sq,s,st,a(3),b(3),c(3),d(3),e(3),ee(3),r
      integer*4 i,j,k,ia(3),ic,ii,ix,iy,iz,iver(10,3),jj
      integer*4 kk,ll,lll,nmin,nmax
c END TYPE definitions ++++++++++++++++++++++++++++++++++
      iver(1,1)=i
      iver(1,2)=j
      iver(1,3)=k
      ic=1
      do 10 ii=1,3
      do 10 jj=1,3
      do 10 kk=1,3
      ix=i+ii-2
      iy=j+jj-2
      iz=k+kk-2
      nmin=min0(ix,iy,iz)
      nmax=max0(ix,iy,iz)
      if(nmin.ne.1.and.nmax.ne.(nda+1)) goto 10
      if(nmin.lt.1.or.nmax.gt.(nda+1)) goto 10
      if(IABS(ix-i)+IABS(iy-j)+IABS(iz-k).ne.2) goto 10
      ic=ic+1
      iver(ic,1)=ix
      iver(ic,2)=iy
      iver(ic,3)=iz
   10 continue
cxx   write(*,'(4i3/10(3i3,2x))') ic,i,j,k,((iver(l,ll),ll=1,3),l=1,ic)
      s=0.d0
      do 50 ii=2,ic
      do  40 kk=1,3
      if(iver(1,kk).eq.iver(ii,kk)) goto 40
      do 20 ll=1,3
      if(iver(ii,ll)-iver(1,ll).eq.0) lll=ll
   20 continue
      if(iver(1,lll).ne.1.and.iver(1,lll).ne.(nda+1)) goto 40
      do 30 jj=1,3
   30 ia(jj)=iver(1,jj)
      ia(kk)=iver(ii,kk)
      a(1)=dra(iver(1,1))
      a(2)=dra(iver(1,2))
      a(3)=dra(iver(1,3))
      CALL NORM(a,a)
      b(1)=dra(iver(ii,1))
      b(2)=dra(iver(ii,2))
      b(3)=dra(iver(ii,3))
      CALL NORM(b,b)
      c(1)=dra(ia(1))
      c(2)=dra(ia(2))
      c(3)=dra(ia(3))
      st=0.d0
      CALL NORM(c,c)
      CALL NVECT(a,b,ee,d,r)
      CALL NVECT(c,b,ee,e,r)
      st=st+DACOS(d(1)*e(1)+d(2)*e(2)+d(3)*e(3))
      CALL NVECT(a,c,ee,d,r)
      CALL NVECT(b,c,ee,e,r)
      st=st+DACOS(d(1)*e(1)+d(2)*e(2)+d(3)*e(3))
      CALL NVECT(b,a,ee,d,r)
      CALL NVECT(c,a,ee,e,r)
      st=st+DACOS(d(1)*e(1)+d(2)*e(2)+d(3)*e(3))
      st=st-dpi
      s=s+st
   40 continue
   50 continue
      sq=s/(drad*drad*4.d0)
      return
      end


      MODULE MOD_ETLRAY

      CONTAINS

      SUBROUTINE ETLRAY(U,Z,OPA,OPAL,ETA,ETAL,XJLMEAN,RADIUS,ND,NP,JP,P,
     $                  UB,GA,H,QQ,S,V,VA,VB,VELO,GRADI,PP,
     $                  BMHO,BMNO,BMHI,BMNI,BCORE,DBDR,
     $                  XJCIND,ELEVEL,LOW,
     $                  PHI,PWEIGHT,NFL,DELTAX,XJ,XH,XK,XN,W0,W1,W2,W3,
     $                  NL, XLAM, LO)

!     LINE RADIATION TRANSFER IN THE COMOVING FRAME FROM A GIVEN SOURCE FUNCTION
!     FOR A GIVEN IMPACT-PARAMETER, THE INTEGRATION IS CARRIED OUT IN SPACE
!     AND FREQUENCY AND RESULTS ARE INTEGRATED UP TO YIELD THE MEAN INTENSITY
!     OF THE LINE, XJLMEAN = J-NUE-BAR, AND THE 0 TO 3 MOMENTS J, H, K, N

!     RINAT TAGIROV:
!     See Fig. 7-29 in Mihalas, Stellar Atmospheres, 2nd edition, 1978
!     for the geometry of the ray-by-ray solution as well as
!     Mihalas, Kunasz & Hummer, 1975, 202: 465 - 489
!     "Solution of the comoving-frame equation of transfer in spherically symmetric flows.
!     I.Computational method for equivalent-two-level-atom source functions" (MKH)

      use MOD_MOMADD
      use MOD_COFREQ
      use MOD_INVTRI
      use MOD_GMALU
      USE MOD_CALCLAMBDAS
      USE FILE_OPERATIONS
      USE UTILS
      USE MATOPER

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

      parameter (one = 1.0D0)

      DIMENSION U(ND),XJLMEAN(ND),RADIUS(ND),V(ND),Z(ND,NP)
      DIMENSION VELO(ND),GRADI(ND),PP(ND)
      DIMENSION PHI(NFL),PWEIGHT(NFL)
      DIMENSION BMHO(NFL),BMNO(NFL),BMHI(NFL),BMNI(NFL)
      DIMENSION XJ(NFL,ND),XH(NFL,ND),XK(NFL,ND),XN(NFL,ND)
      DIMENSION W0(ND),W1(ND),W2(ND),W3(ND)
      DIMENSION OPA(ND),OPAL(ND),ETA(ND),ETAL(ND)
      DIMENSION XJCIND(ND),ELEVEL(2)
      DIMENSION H(*), UB(*),S(*),QQ(*), P(*)

      DIMENSION VA(ND), VB(ND), GA(ND)

!     RINAT TAGIROV:
!     TA, TB, TC: see CMFSET.FOR
!     TAL, TBL, TCL are TA, TB and TC, but without the contribution from continuum.
!     They were introduced to implement the local approximate Lambda-operator for lines.
!     OPA = ZERO, ETA = ZERO for TAL, TBL, TCL (first call of CMFSET subroutine).
!     If OPA and ETA are not equal to zero it renders the calculation of the local approximate Lambda-operator impossible.

      REAL*8, ALLOCATABLE, DIMENSION(:) :: TA, TB, TC
      REAL*8, ALLOCATABLE, DIMENSION(:) :: TAL,TBL,TCL
      REAL*8, ALLOCATABLE, DIMENSION(:) :: ZERO

      logical THIN

!     Diagonal of the inverse of TRI(TAL, TBL, TCL), which is matrix T in MKH formulation (equation 2.39), for a particular frequency within a line
      REAL*8, ALLOCATABLE, DIMENSION(:) :: INV_T_DIAG

!     INV_T_DIAG averaged over the line profile and over all angles, i.e. the Local approximate lambda-Operator for a given line
      REAL*8, DIMENSION(ND), INTENT(INOUT) :: LO

      COMMON / COMFUN / DELTAV,XMIN

      LMAX = MIN0(NP + 1 - JP, ND)
      LZ = LMAX - 1

      ALLOCATE(ZERO(ND))

      ALLOCATE(INV_T_DIAG(LMAX))

      ALLOCATE(TA(LMAX))
      ALLOCATE(TB(LMAX))
      ALLOCATE(TC(LMAX))

      ALLOCATE(TAL(LMAX))
      ALLOCATE(TBL(LMAX))
      ALLOCATE(TCL(LMAX))

      ZERO(1 : ND) = 0.0D0
      INV_T_DIAG(1 : LMAX) = 0.0D0

      TA(1 : LMAX) = 0.0D0
      TB(1 : LMAX) = 0.0D0
      TC(1 : LMAX) = 0.0D0

      TAL(1 : LMAX) = 0.0D0
      TBL(1 : LMAX) = 0.0D0
      TCL(1 : LMAX) = 0.0D0

C***  BLUE-WING BOUNDARY CONDITION..  U AND V SPECIFIED
C***  THE FEAUTRIER-FLUX V (AT DEPTH INTERSTICES) IS DERIVED FROM U VIA THE DGL.
      DO 5 L=1,LZ
      X=0.5d0*(OPA(L)+OPA(L+1))
    5 V(L)=(U(L+1)-U(L))/X/(Z(L,JP)-Z(L+1,JP))

C***  PP(L) = VELOCITY GRADIENT, PROJECTED ON THE PRESENT RAY J, /DELTAX
      DO 4 L=1,LMAX
      RL=RADIUS(L)
      Y=Z(L,JP)/RL
      YY=Y*Y
    4 PP(L)=(YY*GRADI(L)+(one-YY)*VELO(L)/RL)/DELTAX

C***  GENERATING INTEGRATION WEIGHTS APPROPRIATE FOR THE CONSIDERED RAY
C***  WHICH WILL BE USED TO INTEGRATE THE 0. TO 3. MOMENTS
      CALL MOMADD(JP,LMAX,ND,NP,Z,RADIUS,P,W0,W1,W2,W3,WBMHO,WBMNO,WBMHI,WBMNI)

C***  LOOP FOR ALL (ORIGINAL) FREQUENCY POINTS
C***  THE CURRENT INDEX K REFERS TO THE RESULTING U,V , WHERE ALL QUANTITIES
C***  ARE TAKEN. THE FREQUENCY DERIVATIVE STRETCHES BACK TO K-1

      DO 1 K = 1, NFL

C***  OUTER BOUNDARY CONDITIONS
      XIMINUS=0.0d0

C***  FREQUENCY DERIVATIVE OF IMINUS
      IF (K .GT. 1) DXI = XILASTK - XIMINUS

      XILASTK = XIMINUS

      IF (K .EQ. 1) GOTO 2

      CALL CMFSET(PHI(K),Z(1,JP),ND,LMAX,TAL,TBL,TCL,UB,VA,VB,GA,H,S,ZERO,OPAL,ZERO,
     $            ETAL,PP,BCORE,DBDR,XIMINUS,DXI)

      INV_T_DIAG = INVTRIDIAG(TAL, TBL, TCL)

      call assert(.not. any(isnan(inv_t_diag)),     'etlray: inv_t_diag is NaN')
      call assert(.not. any(inv_t_diag .lt. 0.0d0), 'etlray: inv_t_diag is negative')

      CALL CMFSET(PHI(K),Z(1,JP),ND,LMAX,TA,TB,TC,UB,VA,VB,GA,H,S,OPA,OPAL,ETA,
     $            ETAL,PP,BCORE,DBDR,XIMINUS,DXI)

      CALL VMALV (VA,VB,V,QQ,LMAX)
      CALL VADD (QQ,S,LMAX) ! QQ = QQ + S
      CALL MDV (UB,U,LMAX)
      CALL VADD (U,QQ,LMAX) ! U = U + QQ
      CALL INVTRI (TA,TB,TC,U,LMAX)

C***  NOW U IS THE FIELD AT THE NEW INDEX K
      CALL MDV (H,V,LZ)
      CALL GMALU (GA,U,S,LMAX)
      CALL VADD (V,S,LZ) ! V = V + S

C***  ADDING THE NEW U(L) TO THE MEAN INTENSITY XJMEAN
C***  AND TO THE 0. AND 2. MOMENTS XJ AND XK
    2 DO 8 L = 1, LMAX

      LO(L) = LO(L) + INV_T_DIAG(L) * W0(L) * PWEIGHT(K)

      XJLMEAN(L) = XJLMEAN(L) + U(L) * W0(L) * PWEIGHT(K)

      XJ(K,L)=XJ(K,L)+W0(L)*U(L)
    8 XK(K,L)=XK(K,L)+W2(L)*U(L)

C***  ADDING THE NEW V TO THE 1. AND 3. MOMENTS XH AND XN
      DO 9 L=1,LZ
      XH(K,L)=XH(K,L)+W1(L)*V(L)
    9 XN(K,L)=XN(K,L)+W3(L)*V(L)
C***  ADDING U(1) TO THE BOUNDARY MOMENTS H AND N (BMH, BMN)
C***  MODIFICATION FOR NONZERO INCIDENT RADIATION FROM TRUNCATED LAYERS
      BMHO(K)=BMHO(K)+WBMHO*(U(1)-XIMINUS)
      BMNO(K)=BMNO(K)+WBMNO*(U(1)-XIMINUS)
      IF (LMAX.LT.ND) GOTO 1
      BMHI(K)=BMHI(K)+WBMHI*U(ND)
      BMNI(K)=BMNI(K)+WBMNI*U(ND)
    1 CONTINUE

      DEALLOCATE(ZERO)

      DEALLOCATE(INV_T_DIAG)

      DEALLOCATE(TA)
      DEALLOCATE(TB)
      DEALLOCATE(TC)

      DEALLOCATE(TAL)
      DEALLOCATE(TBL)
      DEALLOCATE(TCL)

      RETURN

10    FORMAT(I3,8x,I2,8x,I2,8x,I2,8x,E15.7,8x,E15.7,8x,E15.7,8x,E15.7)

      END SUBROUTINE

      SUBROUTINE CMFSET(PHIK,Z,ND,LMAX,TA,TB,TC,UB,VA,VB,GA,H,S,OPA,OPAL,
     $                  ETA,ETAL,PP,BCORE,DBDR,XIMINUS,DXI)

!     THIS SUBROUTINE IS TO SET UP THE ARRAY ELEMENTS FOR THE CMF FORMALISM

!     RINAT TAGIROV:
!     It follows formalism described in Mihalas, Kunasz & Hummer, 1975, 202: 465 - 489
!     "Solution of the comoving-frame equation of transfer in spherically symmetric flows.
!     I.Computational method for equivalent-two-level-atom source functions" (MKH),
!     but with the source function of general form, i.e the following equation is solved:
!     T_{k,j}u_{k,j} + U_{k,j}u_{k-1,j} + V_{k,j}v_{k-1,j} = S_{k,j}
!     instead of Eq. (2.39) in MKH.
!     Specifically see their Eq. (2.31) and Appendix C.
!     TA, TB, TC are the diagonals of matrix T_{k,j} (tridiagonal).
!     VA, VB are the diagonals of matrix V_{k,j} (bidiagonal).
!     UB is the matrix U_{k,j} (diagonal).
!     H is the matrix H_{k,j} (diagonal).
!     GA is matrix G_{k,j} which is bidiagonal but its diagonal element
!     is minus one multiplied by the non-diagonal one, so only GA array is needed here.
!     The signs do not match their formulation because apparently the routine is written
!     for the aforementioned matrix equation having slightly different
!     form with some signs taken out of the matrix elements
!     and put directly into the equation.

      implicit real*8(a-h,o-z)

      parameter (half=0.5d0, one=1.0d0, two=2.0d0)

      DIMENSION S(ND),OPA(ND),OPAL(ND),ETA(ND),ETAL(ND),VA(ND),VB(ND)
      DIMENSION UB(ND),GA(ND),H(ND)
      DIMENSION PP(ND),Z(ND)

      DIMENSION TA(LMAX), TB(LMAX), TC(LMAX)

      LZ = LMAX - 1

!     OUTER BOUNDARY CONDITION - FIRST ORDER
      AK=OPA(1)+PHIK*OPAL(1)
      AZ=half*(AK+OPA(2)+PHIK*OPAL(2))
      TAUZ=Z(1)-Z(2)
      DX=PP(1)/AK
      S(1)=XIMINUS+DX*DXI
      TC(1)=one/AK/TAUZ
      TB(1)=TC(1)+DX+one
      UB(1)=DX
      VB(1)=0.0

!     FOR G AND H THE MATRIX ELEMENT S ARE NOT DIFFERENT FROM INNER POINTS
      DTZM=one/AZ/TAUZ
      DXZM=(PP(1)+PP(2))/AZ/two
      DAZM=DTZM/(one+DXZM)
      DBZM=DXZM/(one+DXZM)
      GA(1)=-DAZM
      H(1)=DBZM
      IF(LZ.LT.2) GOTO 2

!     NON - BOUNDARY POINTS
      DO 1 L=2,LZ
      AK=OPA(L)+PHIK*OPAL(L)
      EK=ETA(L)+PHIK*ETAL(L)
      S(L)=EK/AK
      AZ=half*(AK+OPA(L+1)+PHIK*OPAL(L+1))
      AZM=half*(AK+OPA(L-1)+PHIK*OPAL(L-1))
      TAU=half*(Z(L-1)-Z(L+1))
      TAUZ=Z(L)-Z(L+1)
      TAUZM=Z(L-1)-Z(L)
      DT=one/AK/TAU
      DTZ=one/(AZ*TAUZ)
      DTZM=one/(AZM*TAUZM)
      DX=PP(L)/AK
      DXZ=(PP(L)+PP(L+1))*half/AZ
      DXZM=(PP(L)+PP(L-1))*half/AZM
      DAZ=DTZ/(one+DXZ)
      DAZM=DTZM/(one+DXZM)
      DBZ=DXZ/(one+DXZ)
      DBZM=DXZM/(one+DXZM)

      TA(L)=DT*DAZM
      TC(L)=DT*DAZ
      TB(L)=TA(L)+TC(L)+DX+one

      UB(L)=DX

      VA(L)=-DT*DBZM
      VB(L)=DT*DBZ

      GA(L)=-DAZ

      H(L)=DBZ

    1 CONTINUE

    2 L = LMAX
      IF (LMAX .LT. ND) GOTO 4

!     INNER BOUNDARY CONDITION (CORE RAYS) - ONLY TO FIRST ORDER
      AK=OPA(ND)+PHIK*OPAL(ND)
      S(ND)=BCORE+DBDR*Z(ND)/AK
      TAUZ=Z(ND-1)-Z(ND)
      DT=one/TAUZ/AK
      DX=PP(L)/AK
      TA(L)=DT
      TB(L)=DT+DX+one
      UB(L)=DX
      VA(L)=0.0d0

      RETURN

!     INNER BOUNDARY CONDITION (NON-CORE RAYS) - SECOND ORDER
    4 AK=OPA(LMAX)+PHIK*OPAL(LMAX)
      EK=ETA(L)+PHIK*ETAL(L)
      S(L)=EK/AK
      TAUZ=Z(LZ)
      DT=one/AK/TAUZ
      DX=PP(L)/AK
      DA=DT/(one+DX)
      DB=DX/(one+DX)
      TA(L)=two*DT*DA
      TB(L)=TA(L)+DX+one
      UB(L)=DX
      VA(L)=-two*DT*DB

      RETURN

      END SUBROUTINE

      END MODULE


      subroutine halopotential(halomass, haloedge)

      include 'commonblocks'

      real halopot(20,0:nmax), halofr(20,0:nmax)
      real m200

      idiskflagint = 0
      ibulgeflagint = 0
      ihaloflagint = 1
      ibhflagint = 0

c Now get the harmonics of the density in this potential --> adens
      ntheta=lmax*4+2
      eps = 0.0001
      adens(1,0)=halodens(eps,0.)*sqrt(4.*pi)
      do l=2,lmax,2
         adens(l/2+1,0)=0
         enddo
      do ir=1,nr
         adens(1,ir)=0
         enddo
c nrmx will mark the outermost radial bin with non-zero density.
      nrmx=nr
      do l=0,lmax,2
c integrate density * spherical harmonic function over quadrant
         do ir=1,nrmx
            r=ir*dr
            s=0
            dctheta=1.0/ntheta
            s=s+polarhalodens(r,1.0,l)+polarhalodens(r,0.0,l)
            do is=1,ntheta-1,2
               ctheta=is*dctheta
               s=s+4*polarhalodens(r,ctheta,l)
            enddo
            do is=2,ntheta-2,2
               ctheta=is*dctheta
               s=s+2*polarhalodens(r,ctheta,l)
            enddo
            s=s*dctheta/3.
            s=s*4*pi
            adens(l/2+1,ir)=s
            enddo
 77      enddo
c     now get the potential harmonics of this new density. Simpson's
c     rule integration. (BT 2-208)
      do l=0,lmax,2
         s1(0)=0
         do ir=2,nr,2
            r=ir*dr
            s1(ir)=s1(ir-2)+(dr/3.)*
     +           (adens(l/2+1,ir-2)*(r-2*dr)**(l+2)+
     +           4*adens(l/2+1,ir-1)*(r-dr)**(l+2)+
     +           adens(l/2+1,ir)*r**(l+2))
            enddo
         s2(nr)=0
         do ir=nr-2,2,-2
            r=ir*dr
            s2(ir)=s2(ir+2)+(dr/3.)*
     +           (adens(l/2+1,ir+2)*(r+2*dr)**(1-l)+
     +           4*adens(l/2+1,ir+1)*(r+dr)**(1-l)+
     +           adens(l/2+1,ir)*r**(1-l))
            enddo
         do ir=2,nr,2
            halopot(l/2+1,ir)=-4*pi/(2.*l+1.)*
     +              (s1(ir)/(ir*dr)**(l+1)+s2(ir)*(ir*dr)**l)
            enddo
c
c  Calculate the radial gradients
c
         do ir=2,nr,2
            halofr(l/2+1,ir)=-4*pi/(2.*l+1.)*
     +              (-(l+1)*s1(ir)/(ir*dr)**(l+2)+
     +           l*s2(ir)*(ir*dr)**(l-1))
            enddo
         enddo

c     now interpolate the gaps first quadratically interpolate the
c     monopole back to the origin.  the remaining multipoles are zero
c     there.

         apot(1,0)=3*(apot(1,2)-apot(1,4))+apot(1,6)
         fr(1,0)=0.0
         do l=2,lmax,2
            halopot(l/2+1,0)=0
            halofr(l/2+1,0)=0
         enddo
         do ir=1,nr-1,2
            do l=0,lmax,2
               halopot(l/2+1,ir)=(halopot(l/2+1,ir-1)+halopot(l/2+1,ir+1
     $              ))/2.
               halofr(l/2+1,ir)=(halofr(l/2+1,ir-1)+halofr(l/2+1,ir+1))
     $              /2.
            enddo
         enddo
         a00=halopot(1,0)
         do ir=0,nr
            halopot(1,ir)=halopot(1,ir)-a00
         enddo
c write halo final potential.
c
c Reset the potentials so that phi is 0 at infinity
c
      redge = nr*dr
      do l=0,lmax,2
          c0 = halopot(l/2+1,nr) + halofr(l/2+1,nr)*redge/(l+1)
          do i=0,nr
              halopot(l/2+1,i) = halopot(l/2+1,i) - c0
          enddo
      enddo

      open(11,file='h.dat',status='unknown')

      write(11,'('' # chalo,v0,a,nnn,v0bulge,abulge,dr,nr,lmax='')')
      write(11,'('' #'',7g15.5,i6,i4)') chalo,v0,a,nnn,v0bulge,abulge,
     +     dr,nr,lmax
      write(11,'('' # psi0, haloconst, bulgeconst:'')')
      write(11,'('' #'',3g15.5)') psi0,haloconst,bulgeconst
      write(11,'('' # Mdisk, rdisk, zdisk, outdisk, drtrunc'')')
      write(11,'('' #'',5g15.5)') rmdisk, rdisk, zdisk, outdisk, drtrunc
      write(11,'('' # psic,bhmass'')')
      write(11,'('' #'',3g15.5)') psic,psi0-psid,bhmass
      write(11,'('' #'',4i5)') idiskflagint, ibulgeflagint,
     +     ihaloflagint, ibhflagint
      write(11,'('' #  OUTPUT FROM DBH8. TOTAL POTENTIAL.'')')
      do ir=0,nr
         write(11,'(8g16.8)') ir*dr,(adens(l/2+1,ir),l=0,lmax,2)
         enddo
      write(11,*)
      write(11,*)
      do ir=0,nr
         write(11,'(8g16.8)') ir*dr,(halopot(l/2+1,ir),l=0,lmax,2)
         enddo
      write(11,*)
      write(11,*)
      do ir=0,nr
         write(11,'(8g16.8)') ir*dr,(halofr(l/2+1,ir),l=0,lmax,2)
         enddo
      close(11)
      halomass = halofr(1,nr)/sqrt(4*pi)*(nr*dr)**2
      do ir=1, nr
         r = ir*dr
         if( adens(1,ir) .eq. 0.0 ) then
            haloedge = ir*dr
            goto 999
         endif
      enddo

      haloedge = nr*dr
999   write(*,*) 'Halo mass =', halomass
      write(*,*) 'Halo edge radius =', haloedge
c      write(*,*) 'r200 and m200 =',r200, m200, density200, virialmass
      write(*,*) 'Halo harmonics written to file ''h.dat''.'
      return
      end


           program demo_u2d
           use M_time, only : u2d, d2u, fmtdate, realtime
           implicit none
           real(kind=realtime) :: today
           integer :: dat(8)
              ! get the date using intrinsic
              call date_and_time(values=dat)
              ! convert today to Julian Date
              today=d2u(dat)
              write(*,*)'Today=',fmtdate(u2d(today))
              ! subtract day
              write(*,*)'Yesterday=',fmtdate(u2d(today-86400.0d0))
              ! add day
              write(*,*)'Tomorrow=',fmtdate(u2d(today+86400.0d0))
           end program demo_u2d


PROGRAM msckb

! Code converted using TO_F90 by Alan Miller
! Date: 2004-06-28  Time: 12:58:12

!     ============================================================
!     Purpose: This program computes the expansion coefficients
!     of the prolate and oblate spheroidal functions,
!     c2k, using subroutine SCKB
!     Input :  m  --- Mode parameter
!     n  --- Mode parameter
!     c  --- Spheroidal parameter
!     cv --- Characteristic value
!     KD --- Function code
!     KD=1 for prolate; KD=-1 for oblate
!     Output:  CK(k) --- Expansion coefficients ck;
!     CK(1), CK(2), ... correspond to
!     c0, c2, ...
!     Example: Compute the first 13 expansion coefficients C2k for
!     KD= 1, m=2, n=3, c=3.0 and cv=14.8277782138; and
!     KD=-1, m=2, n=3, c=3.0 and cv=8.80939392077

!     Coefficients of Prolate and oblate functions

!     k         C2k(c)              C2k(-ic)
!     ---------------------------------------------
!     0     .9173213327D+01     .2489664942D+02
!     1     .4718258929D+01    -.1205287032D+02
!     2     .9841212916D+00     .2410564082D+01
!     3     .1151870224D+00    -.2735821590D+00
!     4     .8733916403D-02     .2026057157D-01
!     5     .4663888254D-03    -.1061946315D-02
!     6     .1853910398D-04     .4158091152D-04
!     7     .5708084895D-06    -.1264400411D-05
!     8     .1402786472D-07     .3074963448D-07
!     9     .2817194508D-09    -.6120579463D-09
!     10     .4712094447D-11     .1015900041D-10
!     11     .6667838485D-13    -.1427953361D-12
!     12     .8087995432D-15     .1721924955D-14
!     ============================================================

IMPLICIT DOUBLE PRECISION (a-h,o-z)
DIMENSION ck(200),df(200),eg(200)
WRITE(*,*)'Please KD, m, n and c '
!     READ(*,*)KD,M,N,C
kd=1
m=2
n=3
c=3.0
CALL segv(m,n,c,kd,cv,eg)
WRITE(*,30)kd,m,n,c,cv
CALL sdmn(m,n,c,cv,kd,df)
CALL sckb(m,n,c,df,ck)
WRITE(*,*)
IF (kd == 1) THEN
  WRITE(*,*)'Coefficients of Prolate function'
  WRITE(*,*)
  WRITE(*,*)'   k            C2k(c)'
ELSE
  WRITE(*,*)'Coefficients of Oblate function'
  WRITE(*,*)
  WRITE(*,*)'   k           C2k(-ic)'
END IF
WRITE(*,*)'----------------------------'
nm=25+INT((n-m)/2+c)
DO  k=1,nm
  WRITE(*,20)k-1,ck(k)
END DO
20   FORMAT(2X,i3,4X,d18.10)
30   FORMAT(1X,3HKD=,i3,',  ',2HM=,i3,',  ',2HN=,i3,  &
    ',  ',2HC=,f5.1,',  ',4HCV =,f18.10)
END PROGRAM msckb

SUBROUTINE sckb(m,n,c,df,ck)

!     ======================================================
!     Purpose: Compute the expansion coefficients of the
!     prolate and oblate spheroidal functions, c2k
!     Input :  m  --- Mode parameter
!     n  --- Mode parameter
!     c  --- Spheroidal parameter
!     DF(k) --- Expansion coefficients dk
!     Output:  CK(k) --- Expansion coefficients ck;
!     CK(1), CK(2), ... correspond to
!     c0, c2, ...
!     ======================================================

INTEGER, INTENT(IN)                      :: m
INTEGER, INTENT(IN)                      :: n
DOUBLE PRECISION, INTENT(IN OUT)         :: c
DOUBLE PRECISION, INTENT(IN)             :: df(200)
DOUBLE PRECISION, INTENT(OUT)            :: ck(200)
IMPLICIT DOUBLE PRECISION (a-h,o-z)

sw=0.0
IF (c <= 1.0D-10) c=1.0D-10
nm=25+INT(0.5*(n-m)+c)
ip=1
IF (n-m == 2*INT((n-m)/2)) ip=0
fac=-0.5D0**m
reg=1.0D0
IF (m+nm > 80) reg=1.0D-200
DO  k=0,nm-1
  fac=-fac
  i1=2*k+ip+1
  r=reg
  DO  i=i1,i1+2*m-1
    r=r*i
  END DO
  i2=k+m+ip
  DO  i=i2,i2+k-1
    r=r*(i+0.5D0)
  END DO
  sum=r*df(k+1)
  DO  i=k+1,nm
    d1=2.0D0*i+ip
    d2=2.0D0*m+d1
    d3=i+m+ip-0.5D0
    r=r*d2*(d2-1.0D0)*i*(d3+k)/(d1*(d1-1.0D0)*(i-k)*d3)
    sum=sum+r*df(i+1)
    IF (DABS(sw-sum) < DABS(sum)*1.0D-14) EXIT
    sw=sum
  END DO
  25    r1=reg
  DO  i=2,m+k
    r1=r1*i
  END DO
  ck(k+1)=fac*sum/r1
END DO
RETURN
END SUBROUTINE sckb

SUBROUTINE sdmn(m,n,c,cv,kd,df)

!     =====================================================
!     Purpose: Compute the expansion coefficients of the
!     prolate and oblate spheroidal functions
!     Input :  m  --- Mode parameter
!     n  --- Mode parameter
!     c  --- Spheroidal parameter
!     cv --- Characteristic value
!     KD --- Function code
!     KD=1 for prolate; KD=-1 for oblate
!     Output:  DF(k) --- Expansion coefficients dk;
!     DF(1), DF(2), ... correspond to
!     d0, d2, ... for even n-m and d1,
!     d3, ... for odd n-m
!     =====================================================

INTEGER, INTENT(IN)                      :: m
INTEGER, INTENT(IN)                      :: n
DOUBLE PRECISION, INTENT(IN)             :: c
DOUBLE PRECISION, INTENT(IN OUT)         :: cv
INTEGER, INTENT(IN)                      :: kd
DOUBLE PRECISION, INTENT(OUT)            :: df(200)
IMPLICIT DOUBLE PRECISION (a-h,o-z)
DIMENSION a(200),d(200),g(200)

sw=0.0
fl=0.0
nm=25+INT(0.5*(n-m)+c)
IF (c < 1.0D-10) THEN
  DO  i=1,nm
    df(i)=0D0
  END DO
  df((n-m)/2+1)=1.0D0
  RETURN
END IF
cs=c*c*kd
ip=1
IF (n-m == 2*INT((n-m)/2)) ip=0
DO  i=1,nm+2
  IF (ip == 0) k=2*(i-1)
  IF (ip == 1) k=2*i-1
  dk0=m+k
  dk1=m+k+1
  dk2=2*(m+k)
  d2k=2*m+k
  a(i)=(d2k+2.0)*(d2k+1.0)/((dk2+3.0)*(dk2+5.0))*cs
  d(i)=dk0*dk1+(2.0*dk0*dk1-2.0*m*m-1.0)/((dk2-1.0) *(dk2+3.0))*cs
  g(i)=k*(k-1.0)/((dk2-3.0)*(dk2-1.0))*cs
END DO
fs=1.0D0
f1=0.0D0
f0=1.0D-100
kb=0
df(nm+1)=0.0D0
DO  k=nm,1,-1
  f=-((d(k+1)-cv)*f0+a(k+1)*f1)/g(k+1)
  IF (DABS(f) > DABS(df(k+1))) THEN
    df(k)=f
    f1=f0
    f0=f
    IF (DABS(f) > 1.0D+100) THEN
      DO  k1=k,nm
        df(k1)=df(k1)*1.0D-100
      END DO
      f1=f1*1.0D-100
      f0=f0*1.0D-100
    END IF
  ELSE
    kb=k
    fl=df(k+1)
    f1=1.0D-100
    f2=-(d(1)-cv)/a(1)*f1
    df(1)=f1
    IF (kb == 1) THEN
      fs=f2
    ELSE IF (kb == 2) THEN
      df(2)=f2
      fs=-((d(2)-cv)*f2+g(2)*f1)/a(2)
    ELSE
      df(2)=f2
      DO  j=3,kb+1
        f=-((d(j-1)-cv)*f2+g(j-1)*f1)/a(j-1)
        IF (j <= kb) df(j)=f
        IF (DABS(f) > 1.0D+100) THEN
          DO  k1=1,j
            df(k1)=df(k1)*1.0D-100
          END DO
          f=f*1.0D-100
          f2=f2*1.0D-100
        END IF
        f1=f2
        f2=f
      END DO
      fs=f
    END IF
    EXIT
  END IF
END DO
35   su1=0.0D0
r1=1.0D0
DO  j=m+ip+1,2*(m+ip)
  r1=r1*j
END DO
su1=df(1)*r1
DO  k=2,kb
  r1=-r1*(k+m+ip-1.5D0)/(k-1.0D0)
  su1=su1+r1*df(k)
END DO
su2=0.0D0
DO  k=kb+1,nm
  IF (k /= 1) r1=-r1*(k+m+ip-1.5D0)/(k-1.0D0)
  su2=su2+r1*df(k)
  IF (DABS(sw-su2) < DABS(su2)*1.0D-14) EXIT
  sw=su2
END DO
55   r3=1.0D0
DO  j=1,(m+n+ip)/2
  r3=r3*(j+0.5D0*(n+m+ip))
END DO
r4=1.0D0
DO  j=1,(n-m-ip)/2
  r4=-4.0D0*r4*j
END DO
s0=r3/(fl*(su1/fs)+su2)/r4
DO  k=1,kb
  df(k)=fl/fs*s0*df(k)
END DO
DO  k=kb+1,nm
  df(k)=s0*df(k)
END DO
RETURN
END SUBROUTINE sdmn

SUBROUTINE segv(m,n,c,kd,cv,eg)

!     =========================================================
!     Purpose: Compute the characteristic values of spheroidal
!     wave functions
!     Input :  m  --- Mode parameter
!     n  --- Mode parameter
!     c  --- Spheroidal parameter
!     KD --- Function code
!     KD=1 for Prolate; KD=-1 for Oblate
!     Output:  CV --- Characteristic value for given m, n and c
!     EG(L) --- Characteristic value for mode m and n'
!     ( L = n' - m + 1 )
!     =========================================================

INTEGER, INTENT(IN)                      :: m
INTEGER, INTENT(IN)                      :: n
DOUBLE PRECISION, INTENT(IN)             :: c
INTEGER, INTENT(IN)                      :: kd
DOUBLE PRECISION, INTENT(OUT)            :: cv
DOUBLE PRECISION, INTENT(OUT)            :: eg(200)
IMPLICIT DOUBLE PRECISION (a-h,o-z)
DIMENSION b(100),h(100),d(300),e(300),f(300),cv0(100),a(300) ,g(300)

IF (c < 1.0D-10) THEN
  DO  i=1,n
    eg(i)=(i+m)*(i+m-1.0D0)
  END DO
ELSE
  icm=INT((n-m+2)/2)
  nm=10+INT(0.5*(n-m)+c)
  cs=c*c*kd
  DO  l=0,1
    DO  i=1,nm
      IF (l == 0) k=2*(i-1)
      IF (l == 1) k=2*i-1
      dk0=m+k
      dk1=m+k+1
      dk2=2*(m+k)
      d2k=2*m+k
      a(i)=(d2k+2.0)*(d2k+1.0)/((dk2+3.0)*(dk2+5.0))*cs
      d(i)=dk0*dk1+(2.0*dk0*dk1-2.0*m*m-1.0)/((dk2-1.0) *(dk2+3.0))*cs
      g(i)=k*(k-1.0)/((dk2-3.0)*(dk2-1.0))*cs
    END DO
    DO  k=2,nm
      e(k)=DSQRT(a(k-1)*g(k))
      f(k)=e(k)*e(k)
    END DO
    f(1)=0.0D0
    e(1)=0.0D0
    xa=d(nm)+DABS(e(nm))
    xb=d(nm)-DABS(e(nm))
    nm1=nm-1
    DO  i=1,nm1
      t=DABS(e(i))+DABS(e(i+1))
      t1=d(i)+t
      IF (xa < t1) xa=t1
      t1=d(i)-t
      IF (t1 < xb) xb=t1
    END DO
    DO  i=1,icm
      b(i)=xa
      h(i)=xb
    END DO
    DO  k=1,icm
      DO  k1=k,icm
        IF (b(k1) < b(k)) THEN
          b(k)=b(k1)
          EXIT
        END IF
      END DO
      35      IF (k /= 1.AND.h(k) < h(k-1)) h(k)=h(k-1)
      DO WHILE (1==1)
        40       x1=(b(k)+h(k))/2.0D0
        cv0(k)=x1
        IF (DABS((b(k)-h(k))/x1) < 1.0D-14) EXIT
        j=0
        s=1.0D0
        DO  i=1,nm
          IF (s == 0.0D0) s=s+1.0D-30
          t=f(i)/s
          s=d(i)-t-x1
          IF (s < 0.0D0) j=j+1
        END DO
        IF (j < k) THEN
          h(k)=x1
        ELSE
          b(k)=x1
          IF (j >= icm) THEN
            b(icm)=x1
          ELSE
            IF (h(j+1) < x1) h(j+1)=x1
            IF (x1 < b(j)) b(j)=x1
          END IF
        END IF
      END DO
      50      cv0(k)=x1
      IF (l == 0) eg(2*k-1)=cv0(k)
      IF (l == 1) eg(2*k)=cv0(k)
    END DO
  END DO
END IF
70   cv=eg(n-m+1)
RETURN
END SUBROUTINE segv


SUBROUTINE formku(ku,km,g)
!
! This subroutine assembles element matrices into symmetrical
! global matrix (stored as an upper rectangle).
!
 IMPLICIT NONE
 INTEGER,PARAMETER::iwp=SELECTED_REAL_KIND(15)
 REAL(iwp),INTENT(IN)::km(:,:)
 REAL(iwp),INTENT(OUT)::ku(:,:)
 INTEGER,INTENT(IN)::g(:)
 INTEGER::i,j,icd,ndof
 ndof=UBOUND(km,1)
 DO i=1,ndof
   IF(g(i)/=0)THEN
     DO j=1,ndof
       IF(g(j)/=0)THEN
         icd=g(j)-g(i)+1
         IF(icd>=1)ku(g(i),icd)=ku(g(i),icd)+km(i,j)
       END IF
     END DO
   END IF
 END DO
RETURN
END SUBROUTINE formku


      program P0203
c>> 1997-06-20 Krogh Generate plots for ch02-03.tex
      integer MAXPT
      real RMAXPT, XA, XB, XSIZE, YSIZE
      real YMAX
      parameter (MAXPT=101, RMAXPT=101.E0)
      parameter (XA = 0.0E0, XB = 8.0E0)
      parameter (XSIZE=3.0E0, YSIZE=2.5E0)
      parameter (YMAX=10.0E0)
      real DX, OPT(16), X(MAXPT), Y(MAXPT, 2)
      external SGAMMA, SLGAMA
      real SGAMMA, SLGAMA
      integer I
      character COPTA*46
      real PLOTXT, PLONY, PLOBOR, PLOYMX
      parameter (PLOTXT=14.E0, PLONY=2.E0, PLOBOR=4.E0,
     1   PLOYMX=9.E0 )
      data OPT / 0.E0, PLONY, RMAXPT, 2.E0, PLOTXT, 3.4E0, 8.0E0, 0.E0,
     1   PLOTXT, 6.0E0, 7.0E0, 0.E0, PLOYMX, -2.E0, 10.E0, 0.E0 /
c
      data COPTA /'F{pl02-03a.tex}{$\Gamma(x)$}{$\ln \Gamma(x)$}'/
c
      DX = (XB - XA) / (MAXPT)
      do 100 I = 1, MAXPT
         X(I) = real(I) * DX
         Y(I,1) = min(SGAMMA(X(I)), YMAX + 4.E0)
         Y(I,2) = SLGAMA(X(I))
  100 continue
      call SPLOT(XSIZE, YSIZE, X, MAXPT, Y, OPT, COPTA)
      stop
      end


!* Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions.
!* See https://llvm.org/LICENSE.txt for license information.
!* SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception

!       OpenMP Reductions
!       Array reduction variables (extension)

module data
integer ir(10,10),nr(10)
integer, parameter :: NTESTS=10
integer,dimension(NTESTS) :: expect = (/10,20,30,40,50,60,70,80,90,100/)
contains
    subroutine init
	do i = 1, 10
	   do j = 1, 10
	       ir(i,j) = j
	   enddo
	   nr(i) = 0
	enddo
    end subroutine
endmodule

program red01
use data
call init
!$omp parallel do reduction(nr)
do i = 1, 10
    nr = nr + ir(i,:)
enddo
!$omp end parallel do
!print *, nr
call check(nr, expect, NTESTS)
end


SUBROUTINE fmglem(fnxe,fnye,lnxe,g_num,lifts)
! Used in p69
! This subroutine returns g_num for the mesh.
!
 IMPLICIT NONE
 INTEGER,INTENT(IN)::fnxe,fnye,lnxe,lifts
 ! output: g_num matrix
 INTEGER,INTENT(OUT)::g_num(:,:)
 INTEGER::ig,i,j,ii,ilast
 ig=0
 DO i=1,fnye
   DO j=1,fnxe
     ig=ig+1
     g_num(1,ig)=(j*2-1)+(i-1)*(fnxe+1)+(i-1)*(2*fnxe+1)
     g_num(8,ig)=g_num(1,ig)+1
     g_num(7,ig)=g_num(1,ig)+2
     g_num(2,ig)=i*(2*fnxe+1)+j+(i-1)*(fnxe+1)
     g_num(6,ig)=g_num(2,ig)+1
     g_num(3,ig)=i*(2*fnxe+1)+i*(fnxe+1)+(j*2-1)
     g_num(4,ig)=g_num(3,ig)+1
     g_num(5,ig)=g_num(3,ig)+2
   END DO
 END DO
 ilast=g_num(5,ig)
 DO ii=1,lifts-1
   DO j=1,lnxe-(ii-1)*1
     ig=ig+1
     g_num(1,ig)=ilast-(lnxe-ii+1)*2+(j-1)*2
     g_num(8,ig)=g_num(1,ig)+1
     g_num(7,ig)=g_num(1,ig)+2
     g_num(2,ig)=ilast+j
     g_num(6,ig)=g_num(2,ig)+1
     g_num(3,ig)=ilast+(lnxe-ii+1)+1+(j*2-1)
     g_num(4,ig)=g_num(3,ig)+1
     g_num(5,ig)=g_num(3,ig)+2
   END DO
   ilast=g_num(5,ig)
 END DO
RETURN
END SUBROUTINE fmglem


*DECK COMBAK
      SUBROUTINE COMBAK (NM, LOW, IGH, AR, AI, INT, M, ZR, ZI)
C***BEGIN PROLOGUE  COMBAK
C***PURPOSE  Form the eigenvectors of a complex general matrix from the
C            eigenvectors of a upper Hessenberg matrix output from
C            COMHES.
C***LIBRARY   SLATEC (EISPACK)
C***CATEGORY  D4C4
C***TYPE      COMPLEX (ELMBAK-S, COMBAK-C)
C***KEYWORDS  EIGENVALUES, EIGENVECTORS, EISPACK
C***AUTHOR  Smith, B. T., et al.
C***DESCRIPTION
C
C     This subroutine is a translation of the ALGOL procedure COMBAK,
C     NUM. MATH. 12, 349-368(1968) by Martin and Wilkinson.
C     HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 339-358(1971).
C
C     This subroutine forms the eigenvectors of a COMPLEX GENERAL
C     matrix by back transforming those of the corresponding
C     upper Hessenberg matrix determined by  COMHES.
C
C     On INPUT
C
C        NM must be set to the row dimension of the two-dimensional
C          array parameters, AR, AI, ZR and ZI, as declared in the
C          calling program dimension statement.  NM is an INTEGER
C          variable.
C
C        LOW and IGH are two INTEGER variables determined by the
C          balancing subroutine  CBAL.  If  CBAL  has not been used,
C          set LOW=1 and IGH equal to the order of the matrix.
C
C        AR and AI contain the multipliers which were used in the
C           reduction by  COMHES  in their lower triangles below
C           the subdiagonal.  AR and AI are two-dimensional REAL
C           arrays, dimensioned AR(NM,IGH) and AI(NM,IGH).
C
C        INT contains information on the rows and columns
C          interchanged in the reduction by  COMHES.  Only
C          elements LOW through IGH are used.  INT is a
C          one-dimensional INTEGER array, dimensioned INT(IGH).
C
C        M is the number of eigenvectors to be back transformed.
C          M is an INTEGER variable.
C
C        ZR and ZI contain the real and imaginary parts, respectively,
C          of the eigenvectors to be back transformed in their first M
C          columns.  ZR and ZI are two-dimensional REAL arrays,
C          dimensioned ZR(NM,M) and ZI(NM,M).
C
C     On OUTPUT
C
C        ZR and ZI contain the real and imaginary parts, respectively,
C          of the transformed eigenvectors in their first M columns.
C
C     Questions and comments should be directed to B. S. Garbow,
C     APPLIED MATHEMATICS DIVISION, ARGONNE NATIONAL LABORATORY
C     ------------------------------------------------------------------
C
C***REFERENCES  B. T. Smith, J. M. Boyle, J. J. Dongarra, B. S. Garbow,
C                 Y. Ikebe, V. C. Klema and C. B. Moler, Matrix Eigen-
C                 system Routines - EISPACK Guide, Springer-Verlag,
C                 1976.
C***ROUTINES CALLED  (NONE)
C***REVISION HISTORY  (YYMMDD)
C   760101  DATE WRITTEN
C   890831  Modified array declarations.  (WRB)
C   890831  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   920501  Reformatted the REFERENCES section.  (WRB)
C***END PROLOGUE  COMBAK
C
      INTEGER I,J,M,LA,MM,MP,NM,IGH,KP1,LOW,MP1
      REAL AR(NM,*),AI(NM,*),ZR(NM,*),ZI(NM,*)
      REAL XR,XI
      INTEGER INT(*)
C
C***FIRST EXECUTABLE STATEMENT  COMBAK
      IF (M .EQ. 0) GO TO 200
      LA = IGH - 1
      KP1 = LOW + 1
      IF (LA .LT. KP1) GO TO 200
C     .......... FOR MP=IGH-1 STEP -1 UNTIL LOW+1 DO -- ..........
      DO 140 MM = KP1, LA
         MP = LOW + IGH - MM
         MP1 = MP + 1
C
         DO 110 I = MP1, IGH
            XR = AR(I,MP-1)
            XI = AI(I,MP-1)
            IF (XR .EQ. 0.0E0 .AND. XI .EQ. 0.0E0) GO TO 110
C
            DO 100 J = 1, M
               ZR(I,J) = ZR(I,J) + XR * ZR(MP,J) - XI * ZI(MP,J)
               ZI(I,J) = ZI(I,J) + XR * ZI(MP,J) + XI * ZR(MP,J)
  100       CONTINUE
C
  110    CONTINUE
C
         I = INT(MP)
         IF (I .EQ. MP) GO TO 140
C
         DO 130 J = 1, M
            XR = ZR(I,J)
            ZR(I,J) = ZR(MP,J)
            ZR(MP,J) = XR
            XI = ZI(I,J)
            ZI(I,J) = ZI(MP,J)
            ZI(MP,J) = XI
  130    CONTINUE
C
  140 CONTINUE
C
  200 RETURN
      END


!===============================================================================
! One of Andy Nowacki's Fortran utility modules for dealing with seismic
! anisotropy and other problems.
!
! Andy Nowacki <andy.nowacki@bristol.ac.uk>
!
! See the file LICENCE for licence details.
!===============================================================================
program PREM_vals

use global_1d_models

implicit none

character(len=50) :: arg
character(len=19), parameter :: fmt_iso = '(3f7.3, f6.1, f6.2)'
character(len=25), parameter :: fmt_iso_depth = '(3f7.3, f6.1, f6.2, f9.3)'
character(len=31), parameter :: fmt_ani = '(4f7.3, f7.4, f7.3, f6.1, f6.2)'
character(len=37), parameter :: fmt_ani_depth = '(4f7.3, f7.4, f7.3, f6.1, f6.2, f9.3)'
character(len=33), parameter :: hdr_iso = '#    vp     vs    rho     P     g'
character(len=54), parameter :: hdr_ani = '#   vph    vpv    vsh    vsv    eta    rho     P     g'
character(len=6) :: label = ' depth'
real(8) :: depth, vp, vs, rho, P, g, vph, vpv, vsh, vsv, eta
integer :: iostatus
logical :: aniso = .false., header = .true., radius = .false., read_stdin = .true.

call get_args

!  Use the argument on the command line
if (.not. read_stdin) then
   if (radius) depth = PREM_radius_km - depth
   if (aniso) then
      if (header) write(*,'(a)') hdr_ani
      call prem(depth, vph=vph, vpv=vpv, vsh=vsh, vsv=vsv, eta=eta, rho=rho, g=g)
   else
      if (header) write(*,'(a)') hdr_iso
      call prem(depth, vp=vp, vs=vs, rho=rho, g=g)
   endif
   P = pressure(depth, model='PREM')
   if (aniso) then
      write(*,fmt_ani) vph, vpv, vsh, vsv, eta, rho, P, g
   else
      write(*,fmt_iso) vp, vs, rho, P, g
   endif

else

   if (aniso) then
      if (header) write(*,'(a," ",a)') hdr_ani, trim(label)
   else
      if (header) write(*,'(a," ",a)') hdr_iso, trim(label)
   endif
   iostatus = 0
   do while (iostatus == 0)
      read(*,*,iostat=iostatus) depth
      if (iostatus < 0) stop
      if (iostatus > 0) then
         write(0,'(a)') 'prem: Error: Problem reading value of depth on stdin'
         error stop
      endif
      if (radius) depth = PREM_radius_km - depth
      if (aniso) then
         call prem(depth, vph=vph, vpv=vpv, vsh=vsh, vsv=vsv, eta=eta, rho=rho, g=g)
      else
         call prem(depth, vp=vp, vs=vs, rho=rho, g=g)
      endif
      P = pressure(depth,model='PREM')
      if (radius) depth = PREM_radius_km - depth
      if (aniso) then
         write(*,fmt_ani_depth) vph, vpv, vsh, vsv, eta, rho, P, g, depth
      else
         write(*,fmt_iso_depth) vp, vs, rho, P, g, depth
      endif
   enddo

endif

contains
   subroutine usage
      write(0,'(a)') &
         'Usage: prem (options) [depth / km]', &
         '   or: prem (options) < [depth(s) on stdin]', &
         'Returns the values of PREM (Dziewonski & Anderson, 1981) at a given depth,', &
         'in km/s and g/cm^3, and the pressure and gravity predicted by them.', &
         'If reading values from stdin, the depths are also written out as the final column.', &
         'Options:', &
         '   -a:  Evaluate anisotropic PREM, writing out Vph, Vpv, Vsh, Vsv, eta, rho, P and g', &
         '   -n:  Do not print the header', &
         '   -r:  Read radi(us/i) instead of depth(s), in km'
      error stop
   end subroutine usage

   subroutine get_args
      integer :: iarg, narg
      character(len=250) :: arg
      narg = command_argument_count()
      if (narg == 0) then
         read_stdin = .true.
         return
      endif

      iarg = 1
      do while (iarg <= narg)
         call get_command_argument(iarg, arg)
         select case(arg)
            case ('-a')
               aniso = .true.
               iarg = iarg + 1
            case ('-n')
               header = .false.
               iarg = iarg + 1
            case ('-r')
               radius = .true.
               label = 'radius'
               iarg = iarg + 1
            case default
               if (iarg /= narg) call usage
               read_stdin = .false.
               read(arg,*,iostat=iostatus) depth
               if (iostatus /= 0) then
                  write(0,'(a)') 'prem: Error: Cannot get value of depth from argument "' &
                     // trim(arg) // '"'
                  call usage
               endif
               return
         end select
      enddo
   end subroutine get_args

end program PREM_vals


C***********************************************************************
C    Module:  spline.f
C
C    Copyright (C) 2011 Mark Drela
C
C    This program is free software; you can redistribute it and/or modify
C    it under the terms of the GNU General Public License as published by
C    the Free Software Foundation; either version 2 of the License, or
C    (at your option) any later version.
C
C    This program is distributed in the hope that it will be useful,
C    but WITHOUT ANY WARRANTY; without even the implied warranty of
C    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
C    GNU General Public License for more details.
C
C    You should have received a copy of the GNU General Public License
C    along with this program; if not, write to the Free Software
C    Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
C***********************************************************************

      SUBROUTINE SPLINE(X,XS,S,N)
      IMPLICIT REAL (A-H,M,O-Z)
      DIMENSION X(N),XS(N),S(N)
      PARAMETER (NMAX=1000)
      COMMON /SPLCOM/ A(NMAX),B(NMAX),C(NMAX)
C-------------------------------------------------------
C     Calculates spline coefficients for X(S).          |
C     Zero 2nd derivative end conditions are used.      |
C     To evaluate the spline at some value of S,        |
C     use SEVAL and/or DEVAL.                           |
C                                                       |
C     S        independent variable array (input)       |
C     X        dependent variable array   (input)       |
C     XS       dX/dS array                (calculated)  |
C     N        number of points           (input)       |
C                                                       |
C-------------------------------------------------------
      IF(N.GT.NMAX) STOP 'SPLINE: array overflow, increase NMAX'
C
      IF(N.EQ.1) THEN
       XS(1) = 0.
       RETURN
      ENDIF
C
      DO 1 I=2, N-1
        DSM = S(I) - S(I-1)
        DSP = S(I+1) - S(I)
        B(I) = DSP
        A(I) = 2.0*(DSM+DSP)
        C(I) = DSM
        XS(I) = 3.0*((X(I+1)-X(I))*DSM/DSP + (X(I)-X(I-1))*DSP/DSM)
    1 CONTINUE
C
C---- set zero second derivative end conditions
      A(1) = 2.0
      C(1) = 1.0
      XS(1) = 3.0*(X(2)-X(1)) / (S(2)-S(1))
      B(N) = 1.0
      A(N) = 2.0
      XS(N) = 3.0*(X(N)-X(N-1)) / (S(N)-S(N-1))
C
C---- solve for derivative array XS
      CALL TRISOL(A,B,C,XS,N)
C
      RETURN
      END ! SPLINE

      SUBROUTINE SPLIND(X,XS,S,N,XS1,XS2)
      IMPLICIT REAL (A-H,M,O-Z)
      DIMENSION X(N),XS(N),S(N)
      PARAMETER (NMAX=1000)
      COMMON /SPLCOM/ A(NMAX),B(NMAX),C(NMAX)
C-------------------------------------------------------
C     Calculates spline coefficients for X(S).          |
C     Specified 1st derivative and/or zero 2nd          |
C     or 3rd derivative end conditions can be used.     |
C     To evaluate the spline at some value of S,        |
C     use SEVAL and/or DEVAL.                           |
C                                                       |
C     S        independent variable array (input)       |
C     X        dependent variable array   (input)       |
C     XS       dX/dS array                (calculated)  |
C     N        number of points           (input)       |
C     XS1,XS2  endpoint derivatives       (input)       |
C              If =  999.0, use zero 2nd derivative     |
C              If = -999.0, use zero 3rd derivative     |
C                                                       |
C-------------------------------------------------------
      IF(N.GT.NMAX) STOP 'SPLIND: array overflow, increase NMAX'
C
      IF(N.EQ.1) THEN
       XS(1) = 0.
       RETURN
      ENDIF
C
      DO 1 I=2, N-1
        DSM = S(I) - S(I-1)
        DSP = S(I+1) - S(I)
        B(I) = DSP
        A(I) = 2.0*(DSM+DSP)
        C(I) = DSM
        XS(I) = 3.0*((X(I+1)-X(I))*DSM/DSP + (X(I)-X(I-1))*DSP/DSM)
    1 CONTINUE
C
C---- set left end condition
      IF(XS1.EQ.999.0) THEN
C----- zero 2nd derivative
       A(1) = 2.0
       C(1) = 1.0
       XS(1) = 3.0*(X(2)-X(1)) / (S(2)-S(1))
      ELSE IF(XS1.EQ.-999.0) THEN
C----- set zero 3rd derivative
       A(1) = 1.0
       C(1) = 1.0
       XS(1) = 2.0*(X(2)-X(1)) / (S(2)-S(1))
      ELSE
C----- specified 1st derivative
       A(1) = 1.0
       C(1) = 0.
       XS(1) = XS1
      ENDIF
C
C---- set right end condition
      IF(XS2.EQ.999.0) THEN
C----- zero 2nd derivative
       B(N) = 1.0
       A(N) = 2.0
       XS(N) = 3.0*(X(N)-X(N-1)) / (S(N)-S(N-1))
      ELSE IF(XS2.EQ.-999.0) THEN
C----- zero 3rd derivative
       B(N) = 1.0
       A(N) = 1.0
       XS(N) = 2.0*(X(N)-X(N-1)) / (S(N)-S(N-1))
      ELSE
C----- specified 1st derivative
       A(N) = 1.0
       B(N) = 0.
       XS(N) = XS2
      ENDIF
C
C---- if only two points, cannot have zero third derivatives at both ends
      IF(N.EQ.2 .AND. XS1.EQ.-999.0 .AND. XS2.EQ.-999.0) THEN
C----- set zero 2nd derivative at right end (left end will also be zero)
       B(N) = 1.0
       A(N) = 2.0
       XS(N) = 3.0*(X(N)-X(N-1)) / (S(N)-S(N-1))
      ENDIF
C
C---- solve for derivative array XS
      CALL TRISOL(A,B,C,XS,N)
C
      RETURN
      END ! SPLIND

      SUBROUTINE SPLINA(X,XS,S,N)
      DIMENSION X(N),XS(N),S(N)
      LOGICAL LEND
C-------------------------------------------------------
C     Calculates spline coefficients for X(S).          |
C     A simple averaging of adjacent segment slopes     |
C     is used to achieve non-oscillatory curve          |
C     End conditions are set by end segment slope       |
C     To evaluate the spline at some value of S,        |
C     use SEVAL and/or DEVAL.                           |
C                                                       |
C     S        independent variable array (input)       |
C     X        dependent variable array   (input)       |
C     XS       dX/dS array                (calculated)  |
C     N        number of points           (input)       |
C                                                       |
C-------------------------------------------------------
C
      IF(N.EQ.1) THEN
       XS(1) = 0.
       RETURN
      ENDIF
C
      LEND = .TRUE.
      DO 1 I=1, N-1
        DS = S(I+1)-S(I)
        IF (DS.EQ.0.) THEN
          XS(I) = XS1
          LEND = .TRUE.
         ELSE
          DX = X(I+1)-X(I)
          XS2 = DX / DS
          IF (LEND) THEN
            XS(I) = XS2
            LEND = .FALSE.
           ELSE
            XS(I) = 0.5*(XS1 + XS2)
          ENDIF
        ENDIF
        XS1 = XS2
    1 CONTINUE
      XS(N) = XS1
C
      RETURN
      END ! SPLINA

      SUBROUTINE TRISOL(A,B,C,D,KK)
      IMPLICIT REAL (A-H,M,O-Z)
      DIMENSION A(KK),B(KK),C(KK),D(KK)
C-----------------------------------------
C     Solves KK long, tri-diagonal system |
C                                         |
C             A C          D              |
C             B A C        D              |
C               B A .      .              |
C                 . . C    .              |
C                   B A    D              |
C                                         |
C     The righthand side D is replaced by |
C     the solution.  A, C are destroyed.  |
C-----------------------------------------
C
      DO 1 K=2, KK
        KM = K-1
        C(KM) = C(KM) / A(KM)
        D(KM) = D(KM) / A(KM)
        A(K) = A(K) - B(K)*C(KM)
        D(K) = D(K) - B(K)*D(KM)
    1 CONTINUE
C
      D(KK) = D(KK)/A(KK)
C
      DO 2 K=KK-1, 1, -1
        D(K) = D(K) - C(K)*D(K+1)
    2 CONTINUE
C
      RETURN
      END ! TRISOL

      FUNCTION SEVAL(SS,X,XS,S,N)
      IMPLICIT REAL (A-H,M,O-Z)
      DIMENSION X(N),XS(N),S(N)
C--------------------------------------------------
C     Calculates X(SS)                             |
C     XS array must have been calculated by SPLINE |
C--------------------------------------------------
      IF(N.EQ.1) THEN
       SEVAL = X(1)
       RETURN
      ENDIF
C
      ILOW = 1
      I = N
C
   10 IF(I-ILOW .LE. 1) GO TO 11
C
      IMID = (I+ILOW)/2
      IF(SS .LT. S(IMID)) THEN
       I = IMID
      ELSE
       ILOW = IMID
      ENDIF
      GO TO 10
C
   11 DS = S(I) - S(I-1)
      T = (SS - S(I-1)) / DS
      CX1 = DS*XS(I-1) - X(I) + X(I-1)
      CX2 = DS*XS(I)   - X(I) + X(I-1)
      SEVAL = T*X(I) + (1.0-T)*X(I-1) + (T-T*T)*((1.0-T)*CX1 - T*CX2)
      RETURN
      END ! SEVAL

      FUNCTION DEVAL(SS,X,XS,S,N)
      IMPLICIT REAL (A-H,M,O-Z)
      DIMENSION X(N),XS(N),S(N)
C--------------------------------------------------
C     Calculates dX/dS(SS)                         |
C     XS array must have been calculated by SPLINE |
C--------------------------------------------------
      IF(N.EQ.1) THEN
       DEVAL = XS(1)
       RETURN
      ENDIF
C
      ILOW = 1
      I = N
C
   10 IF(I-ILOW .LE. 1) GO TO 11
C
      IMID = (I+ILOW)/2
      IF(SS .LT. S(IMID)) THEN
       I = IMID
      ELSE
       ILOW = IMID
      ENDIF
      GO TO 10
C
   11 DS = S(I) - S(I-1)
      T = (SS - S(I-1)) / DS
      CX1 = DS*XS(I-1) - X(I) + X(I-1)
      CX2 = DS*XS(I)   - X(I) + X(I-1)
      DEVAL = X(I) - X(I-1) + (1.-4.0*T+3.0*T*T)*CX1 + T*(3.0*T-2.)*CX2
      DEVAL = DEVAL/DS
      RETURN
      END ! DEVAL

      FUNCTION D2VAL(SS,X,XS,S,N)
      IMPLICIT REAL (A-H,M,O-Z)
      DIMENSION X(N),XS(N),S(N)
C--------------------------------------------------
C     Calculates d2X/dS2(SS)                       |
C     XS array must have been calculated by SPLINE |
C--------------------------------------------------
      IF(N.EQ.1) THEN
       D2VAL = 0.
       RETURN
      ENDIF
C
      ILOW = 1
      I = N
C
   10 IF(I-ILOW .LE. 1) GO TO 11
C
      IMID = (I+ILOW)/2
      IF(SS .LT. S(IMID)) THEN
       I = IMID
      ELSE
       ILOW = IMID
      ENDIF
      GO TO 10
C
   11 DS = S(I) - S(I-1)
      T = (SS - S(I-1)) / DS
      CX1 = DS*XS(I-1) - X(I) + X(I-1)
      CX2 = DS*XS(I)   - X(I) + X(I-1)
      D2VAL = (6.*T-4.)*CX1 + (6.*T-2.0)*CX2
      D2VAL = D2VAL/DS**2
      RETURN
      END ! D2VAL

      SUBROUTINE SEVALL(SS,X,XS,S,N,
     &                  XX, XXS, XXSS )
      IMPLICIT REAL (A-H,M,O-Z)
      DIMENSION X(N),XS(N),S(N)
C--------------------------------------------------
C     Calculates all spline derivatives.           |
C     (Combines SEVAL, DEVAL, D2VAL)               |
C     XS array must have been calculated by SPLINE |
C--------------------------------------------------
      IF(N.EQ.1) THEN
       XX = X(1)
       XXS = XS(1)
       XXSS = 0.
       RETURN
      ENDIF
C
      ILOW = 1
      I = N
C
   10 IF(I-ILOW .LE. 1) GO TO 11
C
      IMID = (I+ILOW)/2
      IF(SS .LT. S(IMID)) THEN
       I = IMID
      ELSE
       ILOW = IMID
      ENDIF
      GO TO 10
C
   11 DS = S(I) - S(I-1)
      T = (SS - S(I-1)) / DS
C
      F0 = X(I-1)
      F1 = DS*XS(I-1)
      F2 = -DS*(2.0*XS(I-1) + XS(I)) + 3.0*(X(I) - X(I-1))
      F3 =  DS*(    XS(I-1) + XS(I)) - 2.0*(X(I) - X(I-1))
C
      XX = F0 + T*(F1 + T*(    F2 + T*    F3))
      XXS =        F1 + T*(2.0*F2 + T*3.0*F3)
      XXSS =               2.0*F2 + T*6.0*F3
C
      XXS = XXS/DS
      XXSS = XXSS/DS**2
C
      RETURN
      END ! SEVALL

      FUNCTION CURV(SS,X,XS,Y,YS,S,N)
      IMPLICIT REAL (A-H,M,O-Z)
      DIMENSION X(N), XS(N), Y(N), YS(N), S(N)
C-----------------------------------------------
C     Calculates curvature of splined 2-D curve |
C     at S = SS                                 |
C                                               |
C     S        arc length array of curve        |
C     X, Y     coordinate arrays of curve       |
C     XS,YS    derivative arrays                |
C              (calculated earlier by SPLINE)   |
C-----------------------------------------------
      IF(N.EQ.1) THEN
       CURV = 0.
       RETURN
      ENDIF
C
      ILOW = 1
      I = N
C
   10 IF(I-ILOW .LE. 1) GO TO 11
C
      IMID = (I+ILOW)/2
      IF(SS .LT. S(IMID)) THEN
       I = IMID
      ELSE
       ILOW = IMID
      ENDIF
      GO TO 10
C
   11 DS = S(I) - S(I-1)
      T = (SS - S(I-1)) / DS
C
      CX1 = DS*XS(I-1) - X(I) + X(I-1)
      CX2 = DS*XS(I)   - X(I) + X(I-1)
      XD = X(I) - X(I-1) + (1.0-4.0*T+3.0*T*T)*CX1 + T*(3.0*T-2.0)*CX2
      XDD = (6.0*T-4.0)*CX1 + (6.0*T-2.0)*CX2
C
      CY1 = DS*YS(I-1) - Y(I) + Y(I-1)
      CY2 = DS*YS(I)   - Y(I) + Y(I-1)
      YD = Y(I) - Y(I-1) + (1.0-4.0*T+3.0*T*T)*CY1 + T*(3.0*T-2.0)*CY2
      YDD = (6.0*T-4.0)*CY1 + (6.0*T-2.0)*CY2
C
      CURV = (XD*YDD - YD*XDD) / SQRT((XD*XD + YD*YD)**3)
C
      RETURN
      END ! CURV

      FUNCTION CURVS(SS,X,XS,Y,YS,S,N)
      IMPLICIT REAL (A-H,M,O-Z)
      DIMENSION X(N), XS(N), Y(N), YS(N), S(N)
C-----------------------------------------------
C     Calculates curvature derivative of        |
C     splined 2-D curve at S = SS               |
C                                               |
C     S        arc length array of curve        |
C     X, Y     coordinate arrays of curve       |
C     XS,YS    derivative arrays                |
C              (calculated earlier by SPLINE)   |
C-----------------------------------------------
      IF(N.EQ.1) THEN
       CURVS = 0.
       RETURN
      ENDIF
C
      ILOW = 1
      I = N
C
   10 IF(I-ILOW .LE. 1) GO TO 11
C
      IMID = (I+ILOW)/2
      IF(SS .LT. S(IMID)) THEN
       I = IMID
      ELSE
       ILOW = IMID
      ENDIF
      GO TO 10
C
   11 DS = S(I) - S(I-1)
      T = (SS - S(I-1)) / DS
C
      CX1 = DS*XS(I-1) - X(I) + X(I-1)
      CX2 = DS*XS(I)   - X(I) + X(I-1)
      XD = X(I) - X(I-1) + (1.0-4.0*T+3.0*T*T)*CX1 + T*(3.0*T-2.0)*CX2
      XDD = (6.0*T-4.0)*CX1 + (6.0*T-2.0)*CX2
      XDDD = 6.0*CX1 + 6.0*CX2
C
      CY1 = DS*YS(I-1) - Y(I) + Y(I-1)
      CY2 = DS*YS(I)   - Y(I) + Y(I-1)
      YD = Y(I) - Y(I-1) + (1.0-4.0*T+3.0*T*T)*CY1 + T*(3.0*T-2.0)*CY2
      YDD = (6.0*T-4.0)*CY1 + (6.0*T-2.0)*CY2
      YDDD = 6.0*CY1 + 6.0*CY2
C
      SQRTB = SQRT(XD*XD + YD*YD)
      BOT = SQRTB**3
      DBOTDT = 3.0*SQRTB*(XD*XDD + YD*YDD)
C
      TOP = XD*YDD - YD*XDD
      DTOPDT = XD*YDDD - YD*XDDD
C
      CURVS = (DTOPDT*BOT - DBOTDT*TOP) / BOT**2  / DS
C
      RETURN
      END ! CURVS

      SUBROUTINE SINVRT(SI,XI,X,XS,S,N)
      IMPLICIT REAL (A-H,M,O-Z)
      DIMENSION X(N),XS(N),S(N)
C----------------------------------------------------
C     Calculates the "inverse" spline function S(X). |
C     Since S(X) can be multi-valued or not defined, |
C      this is not a "black-box" routine.  The call- |
C      ing program must pass via SI a sufficiently   |
C      good initial guess for S(XI).                 |
C                                                    |
C     XI      specified X value       (input)        |
C     SI      calculated S(XI) value  (input,output) |
C     X,XS,S  usual spline arrays     (input)        |
C                                                    |
C----------------------------------------------------
C
      DO 10 ITER=1, 10
        RES  = SEVAL(SI,X,XS,S,N) - XI
        RESP = DEVAL(SI,X,XS,S,N)
        DS = -RES/RESP
        SI = SI + DS
        IF(ABS(DS/(S(N)-S(1))) .LT. 1.0E-5) RETURN
   10 CONTINUE
      WRITE(*,*) 'SINVRT: spline inversion failed.  Continuing...'
      RETURN
C
      END ! SINVRT

      SUBROUTINE SCALC(X,Y,S,N)
      IMPLICIT REAL (A-H,M,O-Z)
      DIMENSION X(N),Y(N),S(N)
C----------------------------------------
C     Calculates the arc length array S  |
C     for a 2-D array of points (X,Y).   |
C----------------------------------------
C
      S(1) = 0.
      DO 10 I=2, N
        S(I) = S(I-1) + SQRT((X(I)-X(I-1))**2 + (Y(I)-Y(I-1))**2)
   10 CONTINUE
C
      RETURN
      END ! SCALC

      SUBROUTINE SEGSPL(X,XS,S,N)
      IMPLICIT REAL (A-H,M,O-Z)
      DIMENSION X(N),XS(N),S(N)
C-----------------------------------------------
C     Splines X(S) array just like SPLINE,      |
C     but allows derivative discontinuities     |
C     at segment joints.  Segment joints are    |
C     defined by identical successive S values. |
C-----------------------------------------------
      IF(N.EQ.1) THEN
       XS(1) = 0.
       RETURN
      ENDIF
C
      IF(S(1).EQ.S(2)  ) STOP 'SEGSPL:  First input point duplicated'
      IF(S(N).EQ.S(N-1)) STOP 'SEGSPL:  Last  input point duplicated'
C
      ISEG0 = 1
      DO 10 ISEG=2, N-2
        IF(S(ISEG).EQ.S(ISEG+1)) THEN
         NSEG = ISEG - ISEG0 + 1
ccc         CALL SPLINE(X(ISEG0),XS(ISEG0),S(ISEG0),NSEG)
         CALL SPLIND(X(ISEG0),XS(ISEG0),S(ISEG0),NSEG,-999.0,-999.0)
         ISEG0 = ISEG+1
        ENDIF
   10 CONTINUE
C
      NSEG = N - ISEG0 + 1
ccc      CALL SPLINE(X(ISEG0),XS(ISEG0),S(ISEG0),NSEG)
      CALL SPLIND(X(ISEG0),XS(ISEG0),S(ISEG0),NSEG,-999.0,-999.0)
C
      RETURN
      END ! SEGSPL

      SUBROUTINE INTERS(OK,SS1,SS2,
     &                  X1,XS1,Y1,YS1,S1,N1,
     &                  X2,XS2,Y2,YS2,S2,N2 )
      IMPLICIT REAL (A-H,M,O-Z)
      LOGICAL OK
      DIMENSION X1(N1),XS1(N1),Y1(N1),YS1(N1),S1(N1)
      DIMENSION X2(N2),XS2(N2),Y2(N2),YS2(N2),S2(N2)
C-------------------------------------------------------
C     Finds spline coordinate values SS1, SS2 at the
C     intersection of two space curves (X1,Y1), (X2,Y2).
C-------------------------------------------------------
      LOGICAL CLIP1, CLIP2
      DATA EPS / 1.0E-5 /
C
      OK = .TRUE.
ccc      SS1 = S1(1)
ccc      SS2 = S2(1)
      RS1 = 1.0E12
      RS2 = 1.0E12
      DS1 = 0.0
      DS2 = 0.0
C
      EPS1 = EPS*ABS(S1(N1)-S1(1))
      EPS2 = EPS*ABS(S2(N2)-S2(1))
C
      DO 1000 ITER=1, 12
C
        RLX = 1.0
        SS1OLD = SS1
        SS2OLD = SS2
        RS1OLD = ABS(RS1)
        RS2OLD = ABS(RS2)
C
        DO 10 IRLX=1, 16
C
          CLIP1 = .FALSE.
          CLIP2 = .FALSE.
          SS1 = SS1OLD + RLX*DS1
          SS2 = SS2OLD + RLX*DS2
C
          IF(SS1.LT.S1(1) .OR. SS1.GT.S1(N1)) THEN
           CLIP1 = .TRUE.
           SS1 = MAX(SS1,S1(1 ))
           SS1 = MIN(SS1,S1(N1))
          ENDIF
          IF(SS2.LT.S2(1) .OR. SS2.GT.S2(N2)) THEN
           CLIP2 = .TRUE.
           SS2 = MAX(SS2,S2(1 ))
           SS2 = MIN(SS2,S2(N2))
          ENDIF
C
          XX1 = SEVAL(SS1,X1,XS1,S1,N1)
          XX2 = SEVAL(SS2,X2,XS2,S2,N2)
          YY1 = SEVAL(SS1,Y1,YS1,S1,N1)
          YY2 = SEVAL(SS2,Y2,YS2,S2,N2)
C
          RS1 = XX1 - XX2
          RS2 = YY1 - YY2
C
          IF(ABS(RS1).LE.RS1OLD+EPS1 .AND.
     &       ABS(RS2).LE.RS2OLD+EPS2      ) GO TO 11
C
          RLX = 0.5*RLX
C
 10     CONTINUE
        WRITE(*,*) 'INTERS: Under-relaxation loop failed.'
 11     CONTINUE
C
        A11 =  DEVAL(SS1,X1,XS1,S1,N1)
        A12 = -DEVAL(SS2,X2,XS2,S2,N2)
        A21 =  DEVAL(SS1,Y1,YS1,S1,N1)
        A22 = -DEVAL(SS2,Y2,YS2,S2,N2)
C
        DET =   A11*A22 - A12*A21
        DS1 = -(RS1*A22 - A12*RS2)/DET
        DS2 = -(A11*RS2 - RS1*A21)/DET
C
        IF(ABS(DS1) .LT. EPS1 .AND.
     &     ABS(DS2) .LT. EPS2       ) RETURN
C
 1000 CONTINUE
      WRITE(*,*) 'INTERS: Convergence failed. Res =', RS1, RS2
C
      IF(CLIP1)
     & WRITE(*,*)'        S1 clip:', S1(1), S1(N1), SS1, DS1
      IF(CLIP2)
     & WRITE(*,*)'        S2 clip:', S2(1), S2(N2), SS2, DS2
      OK = .FALSE.
C
      RETURN
      END ! INTERS

      SUBROUTINE NEARPT(XPNT,YPNT,SNEAR,X,XP,Y,YP,S,N)
      IMPLICIT REAL (A-H,M,O-Z)
      DIMENSION X(N),XP(N),Y(N),YP(N),S(N)
C========================================================
C     Finds arc length position S=SNEAR of a point
C     on a 2-D splined curve X(S),Y(S) nearest the
C     specified point XPNT,YPNT.
C
C     Assumes the value passed in via SNEAR is a good
C     initial guess.
C========================================================
C
C---- convergence tolerance
      EPS = 1.0E-4 * (S(N) - S(1))
C
C---- Newton iteration loop
      DO 215 IPASS=1, 10
        CALL SEVALL(SNEAR,X,XP,S,N,XXI,XPI,X2I)
        CALL SEVALL(SNEAR,Y,YP,S,N,YYI,YPI,Y2I)
C
C------ residual is dot product with curve tangent vector
        RES   = (XXI-XPNT)*XPI + (YYI-YPNT)*YPI
C
        RES_S = (XPI     )*XPI + (YPI     )*YPI
     &        + (XXI-XPNT)*X2I + (YYI-YPNT)*Y2I
C
        DSN = -RES/RES_S
        SNEAR = SNEAR + DSN
        IF(ABS(DSN) .LT. EPS) GO TO 216
C
  215 CONTINUE
      WRITE(*,*) 'NEARPT: Convergence failed.  Continuing...'
  216 CONTINUE
C
      RETURN
      END ! NEARPT

      SUBROUTINE SEVLIN(SS,X,S,N, XX,XXS)
      DIMENSION X(N),S(N)
C------------------------------------------------------------
C     Calculates X(SS) and dX/ds(SS) using piecewise-linear  |
C     interpolation. This is intended for intepolating very  |
C     noisy data for which a cubic spline is inappropriate.  |
C------------------------------------------------------------
      ILOW = 1
      I = N
C
   10 IF(I-ILOW .LE. 1) GO TO 11
C
      IMID = (I+ILOW)/2
      IF(SS .LT. S(IMID)) THEN
       I = IMID
      ELSE
       ILOW = IMID
      ENDIF
      GO TO 10
C
   11 DS = S(I) - S(I-1)
      T = (SS - S(I-1)) / DS
      XX = T*X(I) + (1.0-T)*X(I-1)
      XXS =  (X(I) - X(I-1))/DS
C
      RETURN
      END ! SEVLIN

      FUNCTION SSEVLIN(SS,X,S,N)
      DIMENSION X(N),S(N)
C------------------------------------------------------------
C     Calculates X(SS) using piecewise-linear                |
C     interpolation. This is intended for intepolating very  |
C     noisy data for which a cubic spline is inappropriate.  |
C------------------------------------------------------------
      ILOW = 1
      I = N
C
   10 IF(I-ILOW .LE. 1) GO TO 11
C
      IMID = (I+ILOW)/2
      IF(SS .LT. S(IMID)) THEN
       I = IMID
      ELSE
       ILOW = IMID
      ENDIF
      GO TO 10
C
   11 DS = S(I) - S(I-1)
      T = (SS - S(I-1)) / DS
      XX = T*X(I) + (1.0-T)*X(I-1)
      XXS =  (X(I) - X(I-1))/DS
      SSEVLIN = XX
C
      RETURN
      END ! SSEVLIN

      FUNCTION DSEVLIN(SS,X,S,N)
      DIMENSION X(N),S(N)
C------------------------------------------------------------
C     Calculates dX/ds(SS) using piecewise-linear            |
C     interpolation. This is intended for intepolating very  |
C     noisy data for which a cubic spline is inappropriate.  |
C------------------------------------------------------------
      ILOW = 1
      I = N
C
   10 IF(I-ILOW .LE. 1) GO TO 11
C
      IMID = (I+ILOW)/2
      IF(SS .LT. S(IMID)) THEN
       I = IMID
      ELSE
       ILOW = IMID
      ENDIF
      GO TO 10
C
   11 DS = S(I) - S(I-1)
      T = (SS - S(I-1)) / DS
ccc   XX = T*X(I) + (1.0-T)*X(I-1)
      XXS =  (X(I) - X(I-1))/DS
      DSEVLIN = XXS
C
      RETURN
      END ! DSEVLIN


  SUBROUTINE midplane_properties_fixedalpha(tauplus)
! Routine calculates state properties of the midplane
! tauplus is passed in case there is a layer above
  use gravdata
  use unitdata

    implicit none

    real,dimension(nmax) :: tauplus
    real(kind=8) :: twoDint,fine,oldtry
    real(kind=8) :: rho, Teff
    integer :: i

    coolfunc(:) = 0.0

!$OMP PARALLEL &
  !$OMP shared(isr,ier,cs,sigma,kappa,mu,gamma,omegaK)&
  !$OMP shared(Tc,tau,nu_tc,tcool,T_source,alpha_g)&
  !$OMP shared(tauplus) &
  !$OMP private(H,rho,coolfunc,Teff,twoDint,i)
  !$OMP DO SCHEDULE(runtime)
  do i = isr, ier

     omegaK(i) = Sqrt(G*mstar/rz(i)**3.0d0)

     IF(Tc(i) < T_source(i)) Tc(i) = T_source(i)
     cs(i) = sqrt(gamma(i)*k_B*Tc(i)/(mu(i)*m_H))

     H(i) = cs(i)/omegaK(i)

     IF(H(i)>1.0e-30) THEN
        rho = 0.5d0*sigma(i)/H(i)
     ELSE
        rho = 0.0
     ENDIF

     !	Interpolate over rho,T to get cs,kappa, mu, gamma

     IF(rho>=1.0e-25) THEN

        call eos_T(rho,cs(i),Tc(i),kappa(i),mu(i),gamma(i),cp(i))

        ! Calculate Q
        Q(i) = cs(i)*omegaK(i)/(pi*G*sigma(i))
!        write(77,*) t,i, rho,cs(i),H/AU, Tc(i),Q(i)

        ! Now calculate cooling time
        tau(i) = kappa(i)*sigma(i) + tauplus(i)

        ! Cooling function for disc
        coolfunc(i) = 16.0d0/3.0d0*stefan*(Tc(i)**4.0d0-T_source(i)**4.0d0)
        coolfunc(i) = coolfunc(i)*tau(i)/(1.0d0+tau(i)**2.0d0)

        Teff = Tc(i)**4.0d0*tau(i)/(1.0d0+tau(i)**2.0d0)
        Teff = Teff**0.25d0

        twoDint = cs(i)**2.0*sigma(i)/gamma(i)/(gamma(i)-1.0d0)

        If (coolfunc(i).ne.0.0d0) Then
           tcool(i) = twoDint/coolfunc(i)
        Else
           tcool(i) = 1.0d35
        EndIf

     ELSE
        Tc(i) = T_source(i)
        mu(i) = 2.4
        gamma(i) = 1.666
        cs(i) = sqrt(gamma(i)*k_B*Tc(i)/(mu(i)*m_H))
        H(i) = cs(i)/omegaK(i)
        kappa(i) = 0.0
        Q(i) = 0.0
        tau(i) = 0.0
        tcool(i) = 1.0d35
        coolfunc(i) = 0.0
     ENDIF

     alpha_g(i) = alpha_visc

     nu_tc(i) = alpha_g(i)*cs(i)*cs(i)/omegaK(i)

  enddo
  !$OMP END DO
  !$OMP END PARALLEL

  omegak(isr-1) = omegak(isr)
  cs(isr-1) = cs(isr)

return

END SUBROUTINE midplane_properties_fixedalpha


program bwtest
  ! tests the stair-FLIPS bandwidth system
  use flips

  implicit none

  type(flips_s) :: ss

  real(sp), dimension(:,:), allocatable :: amat,bmat,cmat
  real, dimension(:), allocatable :: sol,meas, vec,cov1

  ! amat diagonal
  ! bmat low bw
  ! cmat one full row

  integer :: n = 1000

  ! n problem size

  integer :: st(10),en,i

  allocate(amat(n,n),bmat(n,n),cmat(10,n),sol(n),meas(2*n+10),vec(n),cov1(n*(n+1)/2))
  amat = 0.0
  bmat = 0.0
  cmat = 0.0

  ! solution
  sol = 1.0

  ! amat is a diagonal matrix
  do i = 1,n
     call random_number(vec(1))
     amat(i,i) = vec(1)
  end do

  ! bmat has bw of 9 elements
  do i = 5,n-4
     call random_number(vec(1:9))
     bmat(i,(i-4):(i+4)) = vec(1:9)
  end do

  do i = 1,4
     call random_number(vec(1:4))
     bmat(i,1:i) = vec(1:i)
  end do

  do i = n-3,n
     call random_number(vec(n-3:n))
     bmat(i,i:n) = vec(i:n)
  end do

  ! cmat has random bw
  do i = 1,10
     call random_number(vec(1))
     st(i) = 500.0*vec(1) + 1
     call random_number(vec(1:st(i)))
     cmat(i,1:st(i)) = vec(1:st(i))
  end do

  ! measurement

  meas(1:n) = matmul(amat,sol)
  meas(n+1:2*n) = matmul(bmat,sol)
  meas(2*n+1:2*n+10) = matmul(cmat,sol)

  ! Initializing FLIPS with bw 1
  call flips_init(ss,n,1,bandwidth=1)

  ! Add amat and measuremnts, chech bw
  do i = 1,n-1
     call flips_add(ss,1,amat(i,:),meas(i))
  end do
  call flips_add(ss,1,amat(n,:),meas(n),force_rotations=.TRUE.)

  write(*,*) 'Diagonal matrix added. BW=',ss%bw

  ! Add bmat and meas, check bw
  do i = 1,n-1
     call flips_add(ss,1,bmat(i,:),meas(n+i))
  end do
  call flips_add(ss,1,bmat(n,:),meas(2*n),force_rotations=.TRUE.)

  write(*,*) 'Band matrix added. BW=',ss%bw

  ! Add cmat row by row
  do i = 1,10
     call flips_add(ss,1,cmat(i,:),meas(2*n+i),force_rotations=.TRUE.)
     write(*,*) 'Row length=',st(i)
     write(*,*) 'BW=',ss%bw
  end do

  ! Solve and check solution
  call flips_solve(ss)

  write(*,*) 'Max. error=',maxval(sol-ss%solmat)

  call flips_calc_cov(ss,.TRUE.)

  cov1=ss%cmat

  call flips_kill(ss)

  ! Calculate in trad way
  call flips_init(ss,n,1)

  do i = 1,n-1
     call flips_add(ss,1,amat(i,:),meas(i))
  end do
  call flips_add(ss,1,amat(n,:),meas(n),force_rotations=.TRUE.)

  do i = 1,n-1
     call flips_add(ss,1,bmat(i,:),meas(n+i))
  end do
  call flips_add(ss,1,bmat(n,:),meas(2*n),force_rotations=.TRUE.)

  do i = 1,10
     call flips_add(ss,1,cmat(i,:),meas(2*n+i),force_rotations=.TRUE.)
  end do

  write(*,*) '--------------------------------------------------'
  write(*,*) 'BW=',ss%bw

  call flips_solve(ss)

   write(*,*) 'Max. error=',maxval(sol-ss%solmat)

   call flips_calc_cov(ss,.TRUE.)

   write(*,*) 'Cov diff =', maxval(cov1-ss%cmat)

   call flips_kill(ss)

end program bwtest


      MODULE global
      IMPLICIT NONE
      SAVE
      REAL*8,ALLOCATABLE :: NI(:,:), NEH(:,:), NEC(:,:), VX(:,:)
      REAL*8,ALLOCATABLE :: FD0(:,:), FD1(:,:), FD2(:,:)
      REAL*8,ALLOCATABLE :: PHM(:,:), VXM(:,:), NIM(:,:)
      REAL*8,ALLOCATABLE :: NEHM(:,:), NECM(:,:), PH(:,:)
      REAL*8 :: BTH, BTC, ALPH, ALPC

      INTEGER   :: NX, KH, KC, DC, PRC
      INTEGER   :: CC,  NXP1, NXP2, NXP3, NXP4, J, CJ
      INTEGER   :: TIDATA, NTIME, FFTSRT, TIMAT, TRES

      REAL*8    :: DX, DT, LX, PHE, BH, XC, DN, EX0, T1, T2, LO, TOL, W
      REAL*8    :: NEH0, NEC0, NI0, DNEH, DNEC, DNI, L0EH, L0EC, L0I
      REAL*8    :: N0EH, N0EC, N0I, L0V, DNV, PC, BC, TU, F, VX0
      CHARACTER*4 :: FOLDERN ! 4 change with the number of charectors in folder name

      END MODULE global