      SUBROUTINE MB04VD( MODE, JOBQ, JOBZ, M, N, RANKE, A, LDA, E, LDE,
     $                   Q, LDQ, Z, LDZ, ISTAIR, NBLCKS, NBLCKI, IMUK,
     $                   INUK, IMUK0, MNEI, TOL, IWORK, INFO )
C
C     SLICOT RELEASE 5.7.
C
C     Copyright (c) 2002-2020 NICONET e.V.
C
C     PURPOSE
C
C     To compute orthogonal transformations Q and Z such that the
C     transformed pencil Q'(sE-A)Z is in upper block triangular form,
C     where E is an M-by-N matrix in column echelon form (see SLICOT
C     Library routine MB04UD) and A is an M-by-N matrix.
C
C     If MODE = 'B', then the matrices A and E are transformed into the
C     following generalized Schur form by unitary transformations Q1
C     and Z1 :
C
C                      | sE(eps,inf)-A(eps,inf) |      X     |
C        Q1'(sE-A)Z1 = |------------------------|------------|.   (1)
C                      |            O           | sE(r)-A(r) |
C
C     The pencil sE(eps,inf)-A(eps,inf) is in staircase form, and it
C     contains all Kronecker column indices and infinite elementary
C     divisors of the pencil sE-A. The pencil sE(r)-A(r) contains all
C     Kronecker row indices and elementary divisors of sE-A.
C     Note: X is a pencil.
C
C     If MODE = 'T', then the submatrices having full row and column
C     rank in the pencil sE(eps,inf)-A(eps,inf) in (1) are
C     triangularized by applying unitary transformations Q2 and Z2 to
C     Q1'*(sE-A)*Z1.
C
C     If MODE = 'S', then the pencil sE(eps,inf)-A(eps,inf) in (1) is
C     separated into sE(eps)-A(eps) and sE(inf)-A(inf) by applying
C     unitary transformations Q3 and Z3 to Q2'*Q1'*(sE-A)*Z1*Z2.
C
C     This gives
C
C                | sE(eps)-A(eps) |        X       |      X     |
C                |----------------|----------------|------------|
C                |        O       | sE(inf)-A(inf) |      X     |
C     Q'(sE-A)Z =|=================================|============| (2)
C                |                                 |            |
C                |                O                | sE(r)-A(r) |
C
C     where Q = Q1*Q2*Q3 and Z = Z1*Z2*Z3.
C     Note: the pencil sE(r)-A(r) is not reduced further.
C
C     ARGUMENTS
C
C     Mode Parameters
C
C     MODE    CHARACTER*1
C             Specifies the desired structure of the transformed
C             pencil Q'(sE-A)Z to be computed as follows:
C             = 'B':  Basic reduction given by (1);
C             = 'T':  Further reduction of (1) to triangular form;
C             = 'S':  Further separation of sE(eps,inf)-A(eps,inf)
C                     in (1) into the two pencils in (2).
C
C     JOBQ    CHARACTER*1
C             Indicates whether the user wishes to accumulate in a
C             matrix Q the orthogonal row transformations, as follows:
C             = 'N':  Do not form Q;
C             = 'I':  Q is initialized to the unit matrix and the
C                     orthogonal transformation matrix Q is returned;
C             = 'U':  The given matrix Q is updated by the orthogonal
C                     row transformations used in the reduction.
C
C     JOBZ    CHARACTER*1
C             Indicates whether the user wishes to accumulate in a
C             matrix Z the orthogonal column transformations, as
C             follows:
C             = 'N':  Do not form Z;
C             = 'I':  Z is initialized to the unit matrix and the
C                     orthogonal transformation matrix Z is returned;
C             = 'U':  The given matrix Z is updated by the orthogonal
C                     transformations used in the reduction.
C
C     Input/Output Parameters
C
C     M       (input) INTEGER
C             The number of rows in the matrices A, E and the order of
C             the matrix Q.  M >= 0.
C
C     N       (input) INTEGER
C             The number of columns in the matrices A, E and the order
C             of the matrix Z.  N >= 0.
C
C     RANKE   (input) INTEGER
C             The rank of the matrix E in column echelon form.
C             RANKE >= 0.
C
C     A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
C             On entry, the leading M-by-N part of this array must
C             contain the matrix to be row compressed.
C             On exit, the leading M-by-N part of this array contains
C             the matrix that has been row compressed while keeping
C             matrix E in column echelon form.
C
C     LDA     INTEGER
C             The leading dimension of array A.  LDA >= MAX(1,M).
C
C     E       (input/output) DOUBLE PRECISION array, dimension (LDE,N)
C             On entry, the leading M-by-N part of this array must
C             contain the matrix in column echelon form to be
C             transformed equivalent to matrix A.
C             On exit, the leading M-by-N part of this array contains
C             the matrix that has been transformed equivalent to matrix
C             A.
C
C     LDE     INTEGER
C             The leading dimension of array E.  LDE >= MAX(1,M).
C
C     Q       (input/output) DOUBLE PRECISION array, dimension (LDQ,*)
C             On entry, if JOBQ = 'U', then the leading M-by-M part of
C             this array must contain a given matrix Q (e.g. from a
C             previous call to another SLICOT routine), and on exit, the
C             leading M-by-M part of this array contains the product of
C             the input matrix Q and the row transformation matrix used
C             to transform the rows of matrices A and E.
C             On exit, if JOBQ = 'I', then the leading M-by-M part of
C             this array contains the matrix of accumulated orthogonal
C             row transformations performed.
C             If JOBQ = 'N', the array Q is not referenced and can be
C             supplied as a dummy array (i.e. set parameter LDQ = 1 and
C             declare this array to be Q(1,1) in the calling program).
C
C     LDQ     INTEGER
C             The leading dimension of array Q. If JOBQ = 'U' or
C             JOBQ = 'I', LDQ >= MAX(1,M); if JOBQ = 'N', LDQ >= 1.
C
C     Z       (input/output) DOUBLE PRECISION array, dimension (LDZ,*)
C             On entry, if JOBZ = 'U', then the leading N-by-N part of
C             this array must contain a given matrix Z (e.g. from a
C             previous call to another SLICOT routine), and on exit, the
C             leading N-by-N part of this array contains the product of
C             the input matrix Z and the column transformation matrix
C             used to transform the columns of matrices A and E.
C             On exit, if JOBZ = 'I', then the leading N-by-N part of
C             this array contains the matrix of accumulated orthogonal
C             column transformations performed.
C             If JOBZ = 'N', the array Z is not referenced and can be
C             supplied as a dummy array (i.e. set parameter LDZ = 1 and
C             declare this array to be Z(1,1) in the calling program).
C
C     LDZ     INTEGER
C             The leading dimension of array Z. If JOBZ = 'U' or
C             JOBZ = 'I', LDZ >= MAX(1,N); if JOBZ = 'N', LDZ >= 1.
C
C     ISTAIR  (input/output) INTEGER array, dimension (M)
C             On entry, this array must contain information on the
C             column echelon form of the unitary transformed matrix E.
C             Specifically, ISTAIR(i) must be set to +j if the first
C             non-zero element E(i,j) is a corner point and -j
C             otherwise, for i = 1,2,...,M.
C             On exit, this array contains no useful information.
C
C     NBLCKS  (output) INTEGER
C             The number of submatrices having full row rank greater
C             than or equal to 0 detected in matrix A in the pencil
C             sE(x)-A(x),
C                where  x = eps,inf  if MODE = 'B' or 'T',
C                or     x = eps      if MODE = 'S'.
C
C     NBLCKI  (output) INTEGER
C             If MODE = 'S', the number of diagonal submatrices in the
C             pencil sE(inf)-A(inf). If MODE = 'B' or 'T' then
C             NBLCKI = 0.
C
C     IMUK    (output) INTEGER array, dimension (MAX(N,M+1))
C             The leading NBLCKS elements of this array contain the
C             column dimensions mu(1),...,mu(NBLCKS) of the submatrices
C             having full column rank in the pencil sE(x)-A(x),
C                where  x = eps,inf  if MODE = 'B' or 'T',
C                or     x = eps      if MODE = 'S'.
C
C     INUK    (output) INTEGER array, dimension (MAX(N,M+1))
C             The leading NBLCKS elements of this array contain the
C             row dimensions nu(1),...,nu(NBLCKS) of the submatrices
C             having full row rank in the pencil sE(x)-A(x),
C                where  x = eps,inf  if MODE = 'B' or 'T',
C                or     x = eps      if MODE = 'S'.
C
C     IMUK0   (output) INTEGER array, dimension (limuk0),
C             where limuk0 = N if MODE = 'S' and 1, otherwise.
C             If MODE = 'S', then the leading NBLCKI elements of this
C             array contain the dimensions mu0(1),...,mu0(NBLCKI)
C             of the square diagonal submatrices in the pencil
C             sE(inf)-A(inf).
C             Otherwise, IMUK0 is not referenced and can be supplied
C             as a dummy array.
C
C     MNEI    (output) INTEGER array, dimension (3)
C             If MODE = 'B' or 'T' then
C             MNEI(1) contains the row dimension of
C                     sE(eps,inf)-A(eps,inf);
C             MNEI(2) contains the column dimension of
C                     sE(eps,inf)-A(eps,inf);
C             MNEI(3) = 0.
C             If MODE = 'S', then
C             MNEI(1) contains the row    dimension of sE(eps)-A(eps);
C             MNEI(2) contains the column dimension of sE(eps)-A(eps);
C             MNEI(3) contains the order of the regular pencil
C                     sE(inf)-A(inf).
C
C     Tolerances
C
C     TOL     DOUBLE PRECISION
C             A tolerance below which matrix elements are considered
C             to be zero. If the user sets TOL to be less than (or
C             equal to) zero then the tolerance is taken as
C             EPS * MAX( ABS(A(I,J)), ABS(E(I,J)) ), where EPS is the
C             machine precision (see LAPACK Library routine DLAMCH),
C             I = 1,2,...,M and J = 1,2,...,N.
C
C     Workspace
C
C     IWORK   INTEGER array, dimension (N)
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             > 0:  if incorrect rank decisions were revealed during the
C                   triangularization phase. This failure is not likely
C                   to occur. The possible values are:
C             = 1:  if incorrect dimensions of a full column rank
C                   submatrix;
C             = 2:  if incorrect dimensions of a full row rank
C                   submatrix.
C
C     METHOD
C
C     Let sE - A be an arbitrary pencil. Prior to calling the routine,
C     this pencil must be transformed into a pencil with E in column
C     echelon form. This may be accomplished by calling the SLICOT
C     Library routine MB04UD. Depending on the value of MODE,
C     submatrices of A and E are then reduced to one of the forms
C     described above. Further details can be found in [1].
C
C     REFERENCES
C
C     [1] Beelen, Th. and Van Dooren, P.
C         An improved algorithm for the computation of Kronecker's
C         canonical form of a singular pencil.
C         Linear Algebra and Applications, 105, pp. 9-65, 1988.
C
C     NUMERICAL ASPECTS
C
C     It is shown in [1] that the algorithm is numerically backward
C     stable. The operations count is proportional to (MAX(M,N))**3.
C
C     FURTHER COMMENTS
C
C     The difference mu(k)-nu(k), for k = 1,2,...,NBLCKS, is the number
C     of elementary Kronecker blocks of size k x (k+1).
C
C     If MODE = 'B' or 'T' on entry, then the difference nu(k)-mu(k+1),
C     for k = 1,2,...,NBLCKS, is the number of infinite elementary
C     divisors of degree k (with mu(NBLCKS+1) = 0).
C
C     If MODE = 'S' on entry, then the difference mu0(k)-mu0(k+1),
C     for k = 1,2,...,NBLCKI, is the number of infinite elementary
C     divisors of degree k (with mu0(NBLCKI+1) = 0).
C     In the pencil sE(r)-A(r), the pencils sE(f)-A(f) and
C     sE(eta)-A(eta) can be separated by pertransposing the pencil
C     sE(r)-A(r) and calling the routine with MODE set to 'B'. The
C     result has got to be pertransposed again. (For more details see
C     [1]).
C
C     CONTRIBUTOR
C
C     Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Jan. 1998.
C     Based on Release 3.0 routine MB04TD modified by A. Varga,
C     German Aerospace Research Establishment, Oberpfaffenhofen,
C     Germany, Nov. 1997, as follows:
C     1) NBLCKI is added;
C     2) the significance of IMUK0 and MNEI is changed;
C     3) INUK0 is removed.
C
C     REVISIONS
C
C     V. Sima, Aug. 2011.
C     A. Varga, May 2017
C
C     KEYWORDS
C
C     Generalized eigenvalue problem, orthogonal transformation,
C     staircase form.
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION  ZERO, ONE
      PARAMETER         ( ZERO = 0.0D0, ONE = 1.0D0 )
C     .. Scalar Arguments ..
      CHARACTER         JOBQ, JOBZ, MODE
      INTEGER           INFO, LDA, LDE, LDQ, LDZ, M, N, NBLCKI, NBLCKS,
     $                  RANKE
      DOUBLE PRECISION  TOL
C     .. Array Arguments ..
      INTEGER           IMUK(*), IMUK0(*), INUK(*), ISTAIR(*), IWORK(*),
     $                  MNEI(*)
      DOUBLE PRECISION  A(LDA,*), E(LDE,*), Q(LDQ,*), Z(LDZ,*)
C     .. Local Scalars ..
      LOGICAL           FIRST, FIRSTI, LJOBQI, LJOBZI, LMODEB, LMODES,
     $                  LMODET, UPDATQ, UPDATZ
      INTEGER           I, IFICA, IFIRA, ISMUK, ISNUK, JK, K, NCA, RANKA
      DOUBLE PRECISION  TOLER
C     .. Local Arrays ..
      DOUBLE PRECISION  DWORK(1)
C     .. External Functions ..
      LOGICAL           LSAME
      DOUBLE PRECISION  DLAMCH, DLANGE
      EXTERNAL          DLAMCH, DLANGE, LSAME
C     .. External Subroutines ..
      EXTERNAL          DLASET, MB04TT, MB04TY, MB04VX, XERBLA
C     .. Intrinsic Functions ..
      INTRINSIC         ABS, MAX
C     .. Executable Statements ..
C
      INFO = 0
      LMODEB = LSAME( MODE, 'B' )
      LMODET = LSAME( MODE, 'T' )
      LMODES = LSAME( MODE, 'S' )
      LJOBQI = LSAME( JOBQ, 'I' )
      UPDATQ = LJOBQI.OR.LSAME( JOBQ, 'U' )
      LJOBZI = LSAME( JOBZ, 'I' )
      UPDATZ = LJOBZI.OR.LSAME( JOBZ, 'U' )
C
C     Test the input scalar arguments.
C
      IF( .NOT.LMODEB .AND. .NOT.LMODET .AND. .NOT.LMODES ) THEN
         INFO = -1
      ELSE IF( .NOT.UPDATQ .AND. .NOT.LSAME( JOBQ, 'N' ) ) THEN
         INFO = -2
      ELSE IF( .NOT.UPDATZ .AND. .NOT.LSAME( JOBZ, 'N' ) ) THEN
         INFO = -3
      ELSE IF( M.LT.0 ) THEN
         INFO = -4
      ELSE IF( N.LT.0 ) THEN
         INFO = -5
      ELSE IF( RANKE.LT.0 ) THEN
         INFO = -6
      ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
         INFO = -8
      ELSE IF( LDE.LT.MAX( 1, M ) ) THEN
         INFO = -10
      ELSE IF( .NOT.UPDATQ .AND. LDQ.LT.1 .OR.
     $              UPDATQ .AND. LDQ.LT.MAX( 1, M ) ) THEN
         INFO = -12
      ELSE IF( .NOT.UPDATZ .AND. LDZ.LT.1 .OR.
     $              UPDATZ .AND. LDZ.LT.MAX( 1, N ) ) THEN
         INFO = -14
      END IF
C
      IF ( INFO.NE.0 ) THEN
C
C        Error return.
C
         CALL XERBLA( 'MB04VD', -INFO )
         RETURN
      END IF
C
C     Initialize Q and Z to the identity matrices, if needed.
C
      IF ( LJOBQI )
     $   CALL DLASET( 'Full', M, M, ZERO, ONE, Q, LDQ )
      IF ( LJOBZI )
     $   CALL DLASET( 'Full', N, N, ZERO, ONE, Z, LDZ )
C
C     Quick return if possible.
C
      NBLCKS = 0
      NBLCKI = 0
C
      IF ( N.EQ.0 ) THEN
         MNEI(1) = 0
         MNEI(2) = 0
         MNEI(3) = 0
         RETURN
      END IF
C
      IF ( M.EQ.0 ) THEN
         NBLCKS  = 1
         IMUK(1) = N
         INUK(1) = 0
         MNEI(1) = 0
         MNEI(2) = N
         MNEI(3) = 0
         RETURN
      END IF
C
      TOLER = TOL
      IF ( TOLER.LE.ZERO )
     $   TOLER = DLAMCH( 'Epsilon' )*
     $                    MAX( DLANGE( 'M', M, N, A, LDA, DWORK ),
     $                         DLANGE( 'M', M, N, E, LDE, DWORK ) )
C
C     A(k) is the submatrix in A that will be row compressed.
C
C     ISMUK = sum(i=1,..,k) MU(i), ISNUK = sum(i=1,...,k) NU(i),
C     IFIRA, IFICA: first row and first column index of A(k) in A.
C     NCA: number of columns in A(k).
C
      IFIRA = 1
      IFICA = 1
      NCA = N - RANKE
      ISNUK = 0
      ISMUK = 0
      K = 0
C
C     Initialization of the arrays INUK and IMUK.
C
      DO 20 I = 1, M + 1
         INUK(I) = -1
   20 CONTINUE
C
C     Note: it is necessary that array INUK has DIMENSION M+1 since it
C           is possible that M = 1 and NBLCKS = 2.
C           Example sE-A = (0 0 s -1).
C
      DO 40 I = 1, N
         IMUK(I) = -1
   40 CONTINUE
C
C     Compress the rows of A while keeping E in column echelon form.
C
C     REPEAT
C
   60 K = K + 1
         CALL MB04TT( UPDATQ, UPDATZ, M, N, IFIRA, IFICA, NCA, A, LDA,
     $                E, LDE, Q, LDQ, Z, LDZ, ISTAIR, RANKA, TOLER,
     $                IWORK )
         IMUK(K) = NCA
         ISMUK = ISMUK + NCA
C
         INUK(K) = RANKA
         ISNUK  = ISNUK  + RANKA
         NBLCKS = NBLCKS + 1
C
C        If the rank of A(k) is nra then A has full row rank;
C        JK = the first column index (in A) after the right most column
C        of matrix A(k+1). (In case A(k+1) is empty, then JK = N+1.)
C
         IFIRA = 1 + ISNUK
         IFICA = 1 + ISMUK
         IF ( IFIRA.GT.M ) THEN
            JK = N + 1
         ELSE
            JK = ABS( ISTAIR(IFIRA) )
         END IF
         NCA = JK - 1 - ISMUK
C
C        If NCA > 0 then there can be done some more row compression
C        of matrix A while keeping matrix E in column echelon form.
C
         IF ( NCA.GT.0 ) GO TO 60
C     UNTIL NCA <= 0
C
C     Matrix E(k+1) has full column rank since NCA = 0.
C     Reduce A and E by ignoring all rows and columns corresponding
C     to E(k+1). Ignoring these columns in E changes the ranks of the
C     submatrices E(i), (i=1,...,k-1).
C
      MNEI(1) = ISNUK
      MNEI(2) = ISMUK
      MNEI(3) = 0
C
      IF ( LMODEB )
     $   RETURN
C
C     Triangularization of the submatrices in A and E.
C
      CALL MB04TY( UPDATQ, UPDATZ, M, N, NBLCKS, INUK, IMUK, A, LDA, E,
     $             LDE, Q, LDQ, Z, LDZ, INFO )
C
      IF ( INFO.GT.0 .OR. LMODET )
     $   RETURN
C
C     Save the row dimensions of the diagonal submatrices in pencil
C     sE(eps,inf)-A(eps,inf).
C
      DO 80 I = 1, NBLCKS
         IMUK0(I) = INUK(I)
   80 CONTINUE
C
C     Reduction to square submatrices E(k)'s in E.
C
      CALL MB04VX( UPDATQ, UPDATZ, M, N, NBLCKS, INUK, IMUK, A, LDA, E,
     $             LDE, Q, LDQ, Z, LDZ, MNEI )
C
C     Determine the dimensions of the inf diagonal submatrices and
C     update block numbers if necessary.
C
      FIRST  = .TRUE.
      FIRSTI = .TRUE.
      NBLCKI = NBLCKS
      K = NBLCKS
C
      DO 100 I = K, 1, -1
         IMUK0(I) = IMUK0(I) - INUK(I)
         IF ( FIRSTI .AND. IMUK0(I).EQ.0 ) THEN
            NBLCKI = NBLCKI - 1
         ELSE
            FIRSTI = .FALSE.
         END IF
         IF ( FIRST .AND. IMUK(I).EQ.0 ) THEN
            NBLCKS = NBLCKS - 1
         ELSE
            FIRST = .FALSE.
         END IF
  100 CONTINUE
C
      RETURN
C *** Last line of MB04VD ***
      END


      subroutine quinn (x, rs, wp, ef, ei)
      implicit double precision (a-h, o-z)

c     input  x, rs, wp, ef
c     output ei

c***********************************************************************
c
c     quinn: calculates low energy gamma (approx. proportional to e**2)
c             formula taken from john j. quinn, phys. rev. 126,
c             1453 (1962); equation (7).
c             a cut-off is set up at quinn's cutoff + ef = ekc; it is a
c             rounded inverted step function (a fermi function)
c             theta = 1/( 1 + exp((e-ekc)/gam)) )
c             where the rounding factor gam is set to be about 0.3 ekc.
c     modified by j. rehr (oct 1991) based on coding of r. albers
c     subroutines quinn.f and quinnc.f
c
c     variables:
c        x  = p/pf
c        rs = ws density parameter
c        ei = imaginary self energy
c        pfqryd = quinn's prefactor in atomic-rydberg units
c        wkc = quinn's plasmon threshold
c
c***********************************************************************

      include '../HEADERS/const.h'

      parameter (alphaq = 1/ fa)

c     calculate quinn prefactor in atomin Hartree units
      pisqrt = sqrt(pi)
      pfq = pisqrt / (32 * (alphaq*rs)**1.5)
      temp1 = atan (sqrt (pi / (alphaq*rs)))
      temp2 = sqrt(alphaq*rs/pi) / (1 + alphaq*rs/pi)
      pfq = pfq * (temp1 + temp2)

c     calculate quinn cutoff
c     wkc = quinn's plasmon threshold
c     wkc is cut-off of quinn, pr126, 1453, 1962, eq. (11)
c     in formulae below wp=omegap/ef
      wkc = (sqrt(1+wp) - 1)**2
      wkc = (1 + (6./5.) * wkc / wp**2) * wp * ef

c     we add fermi energy to get correct energy for
c     plasma excitations to turn on
      ekc = wkc + ef

c     calculate gamma
c     gamryd = 2 * (pfqryd/x) * (x**2-1)**2
      gam = (pfq/x) * (x**2-1)**2

c     put in fermi function cutoff
      eabs = ef * x**2
      arg = (eabs-ekc) / (0.3*ekc)
      f = 0
      if (arg .lt. 80)  f = 1 / (1 + exp(arg))

      ei = -gam * f / 2

      return
      end


      subroutine phi3m0(xth,xphi,p0,p1,p2,wt,*)
c     massive particle p0 in rest frame
c     decaying into p1 fixed mass 0 and p2 fixed mass 0.
c     vectors returned p1 and p2 are in the frame in which
C     p0 is supplied
c result is 1/8/pi * 2|p|/sqrts  * domega/(4*pi)
c     factor of (2*pi)^4 included in definition of phase space
c     Expression evaluated is
c     d^4 p1 d^4 p2 (2 pi)^4 delta(p0-p1-p2)/(2 pi)^6
c     delta(p2^2) delta(p3^2)
      implicit none
      include 'constants.f'
      include 'process.f'
      double precision p0(4),p1(4),p2(4),p1cm(4)
      double precision xth,xphi,phi,s,roots,costh,sinth
      double precision wt0,wt
      integer j
      parameter(wt0=one/eight/pi)
      wt=0d0

      s=p0(4)**2-p0(1)**2-p0(2)**2-p0(3)**2
      if (s .lt. zip) then
       if (case(1:5) .ne. 'vlchk') then
        write(6,*) 's<0 in phi3m0',s
       endif
       return 1
      endif

      roots=dsqrt(s)
      costh=two*xth-one
      sinth=dsqrt(one-costh**2)
      phi=twopi*xphi

      wt=wt0

      p1cm(4)=roots/two
      p1cm(1)=roots/two*sinth*dsin(phi)
      p1cm(2)=roots/two*sinth*dcos(phi)
      p1cm(3)=roots/two*costh

c      write(6,*) 'e',roots/two*(s+m1sq-m2sq)/s
c      write(6,*) 'p',roots/two*lambda/s

c      write(6,*) 'sinth',sinth
c      write(6,*) 'costh',costh
c      write(6,*) 'p1cm**2',p1cm(4)**2-p1cm(1)**2-p1cm(2)**2-p1cm(3)**2
c      pause

      call boost(roots,p0,p1cm,p1)
      do j=1,4
      p2(j)=p0(j)-p1(j)
      enddo

      if (  (p0(4) .lt. 0d0)
     & .or. (p1(4) .lt. 0d0)
     & .or. (p2(4) .lt. 0d0)) then
      write(6,*) 'p0',p0(4),p0(4)**2-p0(1)**2-p0(2)**2-p0(3)**2,s
      write(6,*) 'p1',p1(4),p1(4)**2-p1(1)**2-p1(2)**2-p1(3)**2
      write(6,*) 'p2',p2(4),p2(4)**2-p2(1)**2-p2(2)**2-p2(3)**2
      write(6,*) 'in phi3m0'
      endif
      return
      end


      SUBROUTINE MB04QS( TRANC, TRAND, TRANU, M, N, ILO, V, LDV, W, LDW,
     $                   C, LDC, D, LDD, CS, TAU, DWORK, LDWORK, INFO )
C
C     SLICOT RELEASE 5.7.
C
C     Copyright (c) 2002-2020 NICONET e.V.
C
C     PURPOSE
C
C     Overwrites general real m-by-n/n-by-m matrices C and D with
C
C               [ op(C) ]
C         U  *  [       ]   if TRANU = 'N', or
C               [ op(D) ]
C
C          T    [ op(C) ]
C         U  *  [       ]   if TRANU = 'T',
C               [ op(D) ]
C
C     where U is defined as the product of symplectic reflectors and
C     Givens rotations,
C
C         U = diag( H(1),H(1) ) G(1) diag( F(1),F(1) )
C             diag( H(2),H(2) ) G(2) diag( F(2),F(2) )
C                               ....
C             diag( H(k),H(k) ) G(k) diag( F(k),F(k) ),
C
C     with k = m-1, as returned by the SLICOT Library routines MB04PU
C     or MB04RU.
C
C     ARGUMENTS
C
C     Mode Parameters
C
C     TRANC   CHARACTER*1
C             Specifies the form of op( C ) as follows:
C             = 'N':  op( C ) = C;
C             = 'T':  op( C ) = C';
C             = 'C':  op( C ) = C'.
C
C     TRAND   CHARACTER*1
C             Specifies the form of op( D ) as follows:
C             = 'N':  op( D ) = D;
C             = 'T':  op( D ) = D';
C             = 'C':  op( D ) = D'.
C
C     TRANU   CHARACTER*1
C             Specifies whether U or U' is applied as follows:
C             = 'N':  apply U;
C             = 'T':  apply U'.
C
C     Input/Output Parameters
C
C     M       (input) INTEGER
C             The number of rows of the matrices op(C) and op(D).
C             M >= 0.
C
C     N       (input) INTEGER
C             The number of columns of the matrices op(C) and op(D).
C             N >= 0.
C
C     ILO     (input) INTEGER
C             ILO must have the same value as in the previous call of
C             MB04PU or MB04RU. U is equal to the unit matrix except in
C             the submatrix
C             U([ilo+1:m m+ilo+1:2*m], [ilo+1:m m+ilo+1:2*m]).
C             1 <= ILO <= M+1.
C
C     V       (input) DOUBLE PRECISION array, dimension (LDV,M)
C             On entry, the leading M-by-M part of this array must
C             contain in its columns the vectors which define the
C             elementary reflectors H(i).
C
C     LDV     INTEGER
C             The leading dimension of the array V.  LDV >= MAX(1,M).
C
C     W       (input) DOUBLE PRECISION array, dimension (LDW,M)
C             On entry, the leading M-by-M part of this array must
C             contain in its columns the vectors which define the
C             elementary reflectors F(i).
C
C     LDW     INTEGER
C             The leading dimension of the array W.  LDW >= MAX(1,M).
C
C     C       (input/output) DOUBLE PRECISION array, dimension
C                     (LDC,N) if TRANC = 'N',
C                     (LDC,M) if TRANC = 'T' or TRANC = 'C'.
C             On entry with TRANC = 'N', the leading M-by-N part of this
C             array must contain the matrix C.
C             On entry with TRANC = 'T' or TRANC = 'C', the leading
C             N-by-M part of this array must contain the transpose of
C             the matrix C.
C             On exit with TRANC = 'N', the leading M-by-N part of this
C             array contains the updated matrix C.
C             On exit with TRANC = 'T' or TRANC = 'C', the leading
C             N-by-M part of this array contains the transpose of the
C             updated matrix C.
C
C     LDC     INTEGER
C             The leading dimension of the array C.
C             LDC >= MAX(1,M),  if TRANC = 'N';
C             LDC >= MAX(1,N),  if TRANC = 'T' or TRANC = 'C'.
C
C     D       (input/output) DOUBLE PRECISION array, dimension
C                     (LDD,N) if TRAND = 'N',
C                     (LDD,M) if TRAND = 'T' or TRAND = 'C'.
C             On entry with TRAND = 'N', the leading M-by-N part of this
C             array must contain the matrix D.
C             On entry with TRAND = 'T' or TRAND = 'C', the leading
C             N-by-M part of this array must contain the transpose of
C             the matrix D.
C             On exit with TRAND = 'N', the leading M-by-N part of this
C             array contains the updated matrix D.
C             On exit with TRAND = 'T' or TRAND = 'C', the leading
C             N-by-M part of this array contains the transpose of the
C             updated matrix D.
C
C     LDD     INTEGER
C             The leading dimension of the array D.
C             LDD >= MAX(1,M),  if TRAND = 'N';
C             LDD >= MAX(1,N),  if TRAND = 'T' or TRAND = 'C'.
C
C     CS      (input) DOUBLE PRECISION array, dimension (2*N-2)
C             On entry, the first 2*N-2 elements of this array must
C             contain the cosines and sines of the symplectic Givens
C             rotations G(i), as returned by MB04PU or MB04RU.
C
C     TAU     (input) DOUBLE PRECISION array, dimension (N-1)
C             On entry, the first N-1 elements of this array must
C             contain the scalar factors of the elementary reflectors
C             F(i), as returned by MB04PU or MB04RU.
C
C     Workspace
C
C     DWORK   DOUBLE PRECISION array, dimension (LDWORK)
C             On exit, if INFO = 0,  DWORK(1)  returns the optimal value
C             of LDWORK.
C             On exit, if  INFO = -18,  DWORK(1)  returns the minimum
C             value of LDWORK.
C
C     LDWORK  INTEGER
C             The length of the array DWORK.  LDWORK >= MAX(1,N).
C
C             If LDWORK = -1, then a workspace query is assumed;
C             the routine only calculates the optimal size of the
C             DWORK array, returns this value as the first entry of
C             the DWORK array, and no error message related to LDWORK
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     CONTRIBUTORS
C
C     D. Kressner (Technical Univ. Berlin, Germany) and
C     P. Benner (Technical Univ. Chemnitz, Germany), December 2003.
C
C     REVISIONS
C
C     V. Sima, Nov. 2011 (SLICOT version of the HAPACK routine DOSMPV).
C
C     KEYWORDS
C
C     Elementary matrix operations, orthogonal symplectic matrix.
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION  ONE
      PARAMETER         ( ONE = 1.0D+0 )
C     .. Scalar Arguments ..
      CHARACTER         TRANC, TRAND, TRANU
      INTEGER           ILO, INFO, LDC, LDD, LDV, LDW, LDWORK, M, N
C     .. Array Arguments ..
      DOUBLE PRECISION  C(LDC,*), CS(*), D(LDD,*), DWORK(*), TAU(*),
     $                  V(LDV,*), W(LDW,*)
C     .. Local Scalars ..
      LOGICAL           LQUERY, LTRC, LTRD, LTRU
      INTEGER           IC, ID, IERR, JC, JD, MH, MINWRK
C     .. External Functions ..
      LOGICAL           LSAME
      EXTERNAL          LSAME
C     .. External Subroutines ..
      EXTERNAL          MB04QB, XERBLA
C     .. Intrinsic Functions ..
      INTRINSIC         DBLE, INT, MAX
C
C     .. Executable Statements ..
C
C     Decode the scalar input parameters.
C
      INFO  = 0
      LTRC = LSAME( TRANC, 'T' ) .OR. LSAME( TRANC, 'C' )
      LTRD = LSAME( TRAND, 'T' ) .OR. LSAME( TRAND, 'C' )
      LTRU = LSAME( TRANU, 'T' )
      MH = MAX( 0, M - ILO )
C
C     Check the scalar input parameters.
C
      IF (      .NOT.( LTRC .OR. LSAME( TRANC, 'N' ) ) ) THEN
         INFO = -1
      ELSE IF ( .NOT.( LTRD .OR. LSAME( TRAND, 'N' ) ) ) THEN
         INFO = -2
      ELSE IF ( .NOT.( LTRU .OR. LSAME( TRANU, 'N' ) ) ) THEN
         INFO = -3
      ELSE IF ( M.LT.0 ) THEN
         INFO = -4
      ELSE IF ( N.LT.0 ) THEN
         INFO = -5
      ELSE IF ( ILO.LT.1 .OR. ILO.GT.M+1 ) THEN
         INFO = -6
      ELSE IF ( LDV.LT.MAX( 1, M ) ) THEN
         INFO = -8
      ELSE IF ( LDW.LT.MAX( 1, M ) ) THEN
         INFO = -10
      ELSE IF ( ( LTRC .AND. LDC.LT.MAX( 1, N ) ).OR.
     $     ( .NOT.LTRC .AND. LDC.LT.MAX( 1, M ) ) ) THEN
         INFO = -12
      ELSE IF ( ( LTRD .AND. LDD.LT.MAX( 1, N ) ).OR.
     $     ( .NOT.LTRD .AND. LDD.LT.MAX( 1, M ) ) ) THEN
         INFO = -14
      ELSE
         LQUERY = LDWORK.EQ.-1
         MINWRK = MAX( 1, N )
         IF ( LDWORK.LT.MINWRK .AND. .NOT.LQUERY ) THEN
            DWORK(1) = DBLE( MINWRK )
            INFO = -18
         ELSE IF( LQUERY ) THEN
            IF ( M.LE.ILO .OR. N.EQ.0 ) THEN
               DWORK(1) = ONE
            ELSE
               CALL MB04QB( TRANC, TRAND, TRANU, 'C', 'C', MH, N, MH, V,
     $                      LDV, W, LDW, C, LDC, D, LDD, CS, TAU, DWORK,
     $                      -1, IERR )
               DWORK(1) = MAX( MINWRK, INT( DWORK(1) ) )
            END IF
            RETURN
         END IF
      END IF
C
C     Return if there were illegal values.
C
      IF ( INFO.NE.0 ) THEN
         CALL XERBLA( 'MB04QS', -INFO )
         RETURN
      END IF
C
C     Quick return if possible.
C
      IF ( M.LE.ILO .OR. N.EQ.0 ) THEN
         DWORK(1) = ONE
         RETURN
      END IF
C
      IF ( LTRC ) THEN
         IC = 1
         JC = ILO + 1
      ELSE
         IC = ILO + 1
         JC = 1
      END IF
      IF ( LTRD ) THEN
         ID = 1
         JD = ILO + 1
      ELSE
         ID = ILO + 1
         JD = 1
      END IF
C
      CALL MB04QB( TRANC, TRAND, TRANU, 'Columnwise', 'Columnwise', MH,
     $             N, MH, V(ILO+1,ILO), LDV, W(ILO+1,ILO), LDW,
     $             C(IC,JC), LDC, D(ID,JD), LDD, CS(2*ILO-1), TAU(ILO),
     $             DWORK, LDWORK, IERR )
      RETURN
C *** Last line of MB04QS ***
      END


SUBROUTINE BND_WATERLEVEL(T0,HH2)
USE FLOATPRECISION
USE PARAMETERS
USE ARRAYSIZE
USE BOUNDARY
USE DEPTH
IMPLICIT NONE
REAL(FP) , DIMENSION(:,:) , POINTER :: HH2
REAL(FP)                            :: T0
INTEGER                             :: K , I , J , I1 , I2 , J1 , J2

DO K = 1 , BNDNOS
    IF(BNDSTP(1,K)==BNDEDP(1,K)) THEN
        I = BNDSTP(1,K)
        J1 = BNDSTP(2,K)
        J2 = BNDEDP(2,K)
        DO J = J1 , J2 , 1
            HH2(I,J) = 0.5D0*SIN(T0*TDFQ) + DEP0(I,J)
        END DO
    ELSE
        J = BNDSTP(2,K)
        I1 = BNDSTP(1,K)
        I2 = BNDEDP(1,K)
        DO I = I1 , I2 , 1
            HH2(I,J) = 0.5D0*SIN(T0*TDFQ) + DEP0(I,J)
        END DO
    END IF
END DO

RETURN
END SUBROUTINE BND_WATERLEVEL


C     ( Last modified on 23 Dec 2000 at 22:01:38 )
      PROGRAM GENMA
C
C  Generic package driver (example) for applying package GEN to problems
C  from SIF files.
C
C  Ph. Toint, December 2000 / D. Orban, August 2002
C
      IMPLICIT NONE
      INTEGER           NMAX, MMAX
CTOY  PARAMETER       ( NMAX =   10, MMAX = 10   )
CMED  PARAMETER       ( NMAX =  100, MMAX = 100  )
CBIG  PARAMETER       ( NMAX = 3500, MMAX = 3500 )
CCUS  PARAMETER       ( NMAX =  200, MMAX = 200  )
      INTEGER           INSPEC, INPUT, IOUT, N, M
      PARAMETER       ( INSPEC = 46, INPUT = 47, IOUT = 6 )
      INTEGER           NLIN, NEQ, NBNDS, EXITCODE
CS    REAL              DUMMY
CS    REAL              X(NMAX), BL(NMAX), BU(NMAX)
CS    REAL              V(MMAX), CL(MMAX), CU(MMAX)
      REAL              CPU( 2 ), CALLS( 7 )
CD    DOUBLE PRECISION  DUMMY
CD    DOUBLE PRECISION  X(NMAX), BL(NMAX), BU(NMAX)
CD    DOUBLE PRECISION  V(MMAX), CL(MMAX), CU(MMAX)
      CHARACTER*10      PNAME, VNAMES(NMAX), GNAMES(MMAX)
      LOGICAL           EFIRST, LFIRST, NVFRST
      LOGICAL           EQUATN(MMAX), LINEAR(MMAX)
      LOGICAL           CONSTRAINED
C
C  Open the Spec file for the method (typically called METHOD.SPC)
C
      CALL GENSPC( INSPEC, 'GEN.SPC' )
C
C  Open the relevant problem file.
C
      OPEN ( INPUT, FILE = 'OUTSDIF.d', FORM = 'FORMATTED',
     .       STATUS = 'OLD' )
      REWIND INPUT
C
C  Get problem dimensions and determine which tools to use
C
      CALL CDIMEN( INPUT, N, M )
      IF( M .EQ. 0 ) THEN
         CONSTRAINED = .FALSE.
      ELSE IF( M .GT. 0 ) THEN
         CONSTRAINED = .TRUE.
      ELSE
         WRITE( 6, '(A)' ) 'Error reading OUTSDIF.d'
         STOP
      ENDIF
C
C  Set up parameters
C
      EFIRST = .TRUE.
      LFIRST = .FALSE.
      NVFRST = .FALSE.
C
C  Set up SIF data from the problem file
C
      IF( CONSTRAINED ) THEN
         CALL CSETUP( INPUT, IOUT, N, M, X, BL, BU, NMAX, EQUATN,
     .        LINEAR, V, CL, CU, MMAX, EFIRST, LFIRST, NVFRST )
      ELSE
         CALL USETUP( INPUT, IOUT, N, X, BL, BU, NMAX )
      ENDIF
C
C  Obtain problem/variables/constraints names.
C
      IF( CONSTRAINED ) THEN
         CALL CNAMES( N, M, PNAME, VNAMES, GNAMES )
      ELSE
         CALL UNAMES( N, PNAME, VNAMES )
      ENDIF
C
C  Obtain info on the problem
C
      NLIN  = 0
      NEQ   = 0
      NBNDS = 0
      IF( CONSTRAINED ) THEN
         CALL GETINFO( N, M, BL, BU, EQUATN, LINEAR, NLIN, NEQ, NBNDS )
      ELSE
         EQUATN( 1 ) = .FALSE.
         LINEAR( 1 ) = .FALSE.
         CALL GETINFO( N, 1, BL, BU, EQUATN, LINEAR, NLIN, NEQ, NBNDS )
      ENDIF
C
C  Call the optimizer.
C
      CALL GEN( DUMMY )
      EXITCODE = 0
C
C  Close the problem file
C
      CLOSE( INPUT  )
C
C  Write the standard statistics (of which some may be irrelevant)
C
C    CALLS( 1 ): number of calls to the objective function
C    CALLS( 2 ): number of calls to the objective gradient
C    CALLS( 3 ): number of calls to the objective Hessian
C    CALLS( 4 ): number of Hessian times vector products
C           --constrained problems only--
C    CALLS( 5 ): number of calls to the constraint functions
C    CALLS( 6 ): number of calls to the constraint gradients
C    CALLS( 7 ): number of calls to the constraint Hessians
C           -----------------------------
C
C    CPU( 1 ) : CPU time (in seconds) for USETUP or CSETUP
C    CPU( 2 ) : CPU time ( in seconds) since the end of USETUP or CSETUP
C
C  Note that each constraint function is counted separately.
C  Evaluating all the constraints thus results in PNC evaluations, where
C  PNC is the number of constraints in the problem.  Note that PNC does not
C  include repetitions for constraints having full ranges.

C  (N, is the dimension of the problem, M is the number of constraints,
C   DUMMY is the final value of the objective function)
C
      IF( CONSTRAINED ) THEN
         CALL CREPRT( CALLS, CPU )
      ELSE
         CALL UREPRT( CALLS, CPU )
      ENDIF
      WRITE ( IOUT, 2000 ) PNAME, N, M, NLIN, NEQ, M-NEQ, NBNDS,
     .     CALLS( 1 ), CALLS( 2 ), CALLS( 3 ), CALLS( 5 ), CALLS( 6 ),
     .     CALLS( 7 )
      WRITE ( IOUT, 2001 ) EXITCODE, DUMMY, CPU( 1 ), CPU( 2 )
C
C  Exit
C
      STOP
C
C  Non-executable statements.
C
C  The following is the complete standard statistics output format: select
C  the items that are relevant to the type of problems solved and adapt the
C  name of the code.
C
C  The only reason for breaking the format in two is for compilers
C  which do not accept more than 19 continuation lines.
C
 2000 FORMAT( /, 24('*'), ' CUTEr statistics ', 24('*') //
     *    ,' Code used                :  GEN',    /
     *    ,' Variant                  :  name of a variant, if needed',/
     *    ,' Problem                  :  ', A10,    /
     *    ,' # variables              =      ', I10 /
     *    ,' # constraints            =      ', I10 /
     *    ,' # linear constraints     =      ', I10 /
     *    ,' # equality constraints   =      ', I10 /
     *    ,' # inequality constraints =      ', I10 /
     *    ,' # bounds                 =      ', I10 /
     *    ,' # objective functions    =        ', F8.2 /
     *    ,' # objective gradients    =        ', F8.2 /
     *    ,' # objective Hessians     =        ', F8.2 /
     *    ,' # constraints functions  =        ', F8.2 /
     *    ,' # constraints gradients  =        ', F8.2 /
     *    ,' # constraints Hessians   =        ', F8.2 )
 2001 FORMAT(
     *     ' Exit code                =      ', I10 /
     *    ,' Final f                  = ', E15.7 /
     *    ,' Set up time              =      ', 0P, F10.2, ' seconds'/
     *     ' Solve time               =      ', 0P, F10.2, ' seconds'//
     *     66('*') / )
      END


!==============================================================================
!   This a sample code to create simple geometries to be used in MF-LBM
!==============================================================================

module wall
    implicit none
    integer :: nx,ny,nz
    integer(kind=1), allocatable, dimension(:,:,:) :: walls    ! kind=1 to reduce file size
end module wall

!**********************main***************************
program Main
    use wall
    integer :: i,j,k, inlet_buffer, outlet_buffer
    double precision :: r1, r2, xc, yc, zc

    ! domain dimension
    nx = 60
    ny = 60
    nz = 80   ! flow direction

    ! create inlet/outlet reservoirs
    inlet_buffer = 5
    outlet_buffer = 5

    allocate(walls(1:nx,1:ny,1:nz))

    walls=0

    xc = 0.5d0 * (nx + 1)
    yc = 0.5d0 * (ny + 1)
    zc = 0.5d0 * (nz + 1)
    r1 = xc
    r2 = 0.3d0 * xc

    ! change the square duct to a tube and place a sphere obstacle in the center
    do k=1,nz
        do j=1,ny
            do i=1,nx
                if(( i - xc )**2+( j - yc )**2 > r1**2)then  ! tube
                    walls(i,j,k)=1
                endif
                if(( i - xc )**2 + ( j - yc )**2 + ( k - zc )**2 < r2**2)then   !sphere
                    walls(i,j,k)=1
                endif
                !create inlet/outlet reservoirs
                if( k<=inlet_buffer .or. k>=nz-outlet_buffer+1)then
                    walls(i,j,k)=0
                endif
            enddo
        enddo
    enddo

    !apply channel walls
    walls(1,:,:)=1
    walls(nx,:,:)=1
    walls(:,1,:)=1
    walls(:,ny,:)=1

    call VTK_walls_bin

    call write_walls('walls.dat')

    deallocate(walls)

end program Main
!**********************main***************************

!**********************write walls***************************
subroutine write_walls(filename)
    use wall
    integer :: i,j,k
    character(len=*) :: filename

    open(11, file=filename, status='replace',form='unformatted',access='stream')    ! default geometry file format used in MF-LBM
    write(11)nx,ny,nz
    write(11)(((walls(i,j,k),i=1,nx),j=1,ny),k=1,nz)
    !!
    close(11)

    return
end subroutine write_walls
!**********************write walls***************************

!*******************************************visualization**************************************************
subroutine VTK_walls_bin   !solid geometry
    use wall
    IMPLICIT NONE
    integer :: i,j,k
    character :: buffer*80, lf*1, str1*10, str2*10, str3*10
    integer   :: ivtk = 9, int

    open(unit=ivtk,file='./walls_bin.vtk',FORM='unformatted',access='stream',status='replace',convert='BIG_ENDIAN')

    lf = char(10) ! line feed character

    buffer = '# vtk DataFile Version 3.0'//lf                            ; write(ivtk) trim(buffer)
    buffer = 'vtk output'//lf                                             ; write(ivtk) trim(buffer)
    buffer = 'BINARY'//lf                                                 ; write(ivtk) trim(buffer)
    buffer = 'DATASET STRUCTURED_POINTS '//lf                              ; write(ivtk) trim(buffer)

    write(str1(1:10),'(i10)')nx
    write(str2(1:10),'(i10)')ny
    write(str3(1:10),'(i10)')nz
    buffer = 'DIMENSIONS '//str1//' '//str2//' '//str3//lf                 ; write(ivtk) trim(buffer)

    write(str1(1:10),'(i10)')1
    write(str2(1:10),'(i10)')1
    write(str3(1:10),'(i10)')1
    buffer = 'ORIGIN '//str1//' '//str2//' '//str3//lf                         ; write(ivtk) trim(buffer)

    write(str1(1:10),'(i10)')1
    write(str2(1:10),'(i10)')1
    write(str3(1:10),'(i10)')1
    buffer = 'SPACING '//str1//' '//str2//' '//str3//lf                          ; write(ivtk) trim(buffer)

    write(str1(1:10),'(i10)')nx*ny*nz
    buffer = 'POINT_DATA '//str1//lf                                               ; write(ivtk) trim(buffer)

    !scalar - walls
    buffer = 'SCALARS walls int'//lf                                          ; write(ivtk) trim(buffer)
    buffer = 'LOOKUP_TABLE default'//lf                                          ; write(ivtk) trim(buffer)
    write(ivtk)(((int(walls(i,j,k)),i=1,nx),j=1,ny),k=1,nz)

    close(ivtk)

    return
end subroutine VTK_walls_bin
!*******************************************visualization**************************************************


subroutine setprob

    use adjoint_module, only: read_adjoint_data
    implicit none

    character*25 :: fname
    integer :: iunit

    real(kind=8) :: rho,bulk,cc,zz
    common /cparam/ rho,bulk,cc,zz

    ! Set the material parameters for the acoustic equations

    iunit = 7
    fname = 'setprob.data'
    call opendatafile(iunit, fname)

    ! Density and bulk modulus:

    read(7,*) rho
    read(7,*) bulk

    ! Compute sound speed and impendance:

    cc = dsqrt(bulk/rho)
    zz = rho*cc

end subroutine setprob


module uops
   implicit none
   interface operator (.foo.)
      module procedure myfoo
   end interface

   interface operator (*)
      module procedure boolmul
   end interface

   interface assignment (=)
      module procedure int2bool
   end interface

contains
function myfoo (lhs, rhs)
   implicit none
   integer myfoo
   integer, intent(in) :: lhs, rhs

   myfoo = lhs + rhs
end function

! This is deliberately different from integer multiplication
function boolmul (lhs, rhs)
   implicit none
   logical boolmul
   logical, intent(IN) :: lhs, rhs

   boolmul = lhs .and. .not. rhs
end function

subroutine int2bool (lhs, rhs)
   implicit none
   logical, intent(out) :: lhs
   integer, intent(in) :: rhs

   lhs = rhs .ne. 0
end subroutine
end module

program me
   use uops
   implicit none
   integer i, j
   logical b, c

   b = .true.
   c = .true.
   if (b * c) call abort
   c = .false.
   if (.not. (b * c)) call abort
   if (c * b) call abort
   b = .false.
   if (b * c) call abort

   i = 0
   b = i
   if (b) call abort
   i = 2
   b = i
   if (.not. b) call abort

   j = 3
   if ((i .foo. j) .ne. 5) call abort
end program


! High Performance Computing F19 (41391)
! Svend Andersen
!   This Fortran program solves a unsteady, two-dimensional diffusion problem.
!   The program is parallelized using the MPI API and thus depends on this.
!
!   BUILD:
!   To build the program simply run 'make', which has been written for the
!   sun compiler mpi90.  Subsequently the program may be executed by:
!   'mpirun -np [number of procs] ./bin'.
!
!   PROGRAM STRUCTURE:
!   The core files of this program is
!   * main.f90
!   * sub_init.f90
!   * mod_iteration.f90
!     - subr: iterate
!     - subr: par_iterate
!     - subr: stitch
!
!   NOTE: If the file 'T_np01.dat' is not present, the error cannot be
!   calculated.  The file may be recreated by running the program with '-np 1'
!
!   The speed-up study was performed using the 'test_utility.sh' script, and
!   the resulting graph is found in 'speed-up.pdf'.  The result is suprising in
!   that it seems that one does not gain much efficiency using more than 3
!   processors.  This is likely due to the increasing communication overhead.

program main
  use globdata
  use iteration
  use timetools, only: timing_mpi
  use io, only: output, print_array, output_t, read_t
  implicit none
  include "mpif.h"

  real(8),  dimension(:, :), allocatable :: T_np1 ! Array used in comparison
  character(len=128) :: p_name ! Processor name
  integer :: pn_le, info       ! Proc name string length

  call MPI_Init(info); if(info .ne. 0) write(*,'("MPI ERROR Init")')
  call MPI_Comm_rank(MPI_comm_world, rank, info)   ! Get rank number
  call MPI_Comm_size(MPI_comm_world, pnum, info)   ! Get number of procs
  call MPI_Get_processor_name(p_name, pn_le, info) ! Get name of processor

  ! Print MPI status
  if ( rank == 0 ) write(*,'(/3ai2.2a/)') 'RUNNING ON PROCESSOR ',&
    p_name(1:pn_le),' WITH ',pnum,' CORE(S)'

  call init             ! Initialize problem
  if ( pnum == 1 ) then
    call timing_mpi     ! Tic
    call iterate        ! Perform single-proc iteration
    call timing_mpi     ! Toc
    call output_T       ! Output T for comparison
  else
    call timing_mpi     ! Tic
    call par_iterate    ! Perform multi-proc iteration
    call timing_mpi     ! Toc
    call stitch         ! Collect and stitch data
  endif

  ! Compute RMS error to validate parallel solution
  !if (rank == 0) then
  !  call read_T(T_np1, 'T_np01.dat') ! Read seq. field for comparison
  !  write(*,'("Error was: "e9.2/)') sqrt(1.0_mkd/real(nx*ny))*(sum(T-T_np1)**2)
  !  !call output
  !endif

  call MPI_Finalize(info); if ( info.ne.0 ) write(*,'("MPI ERROR Finalize")')
end program main


program shallow

!> @mainpage BENCHMARK WEATHER PREDICTION PROGRAM FOR COMPARING THE
!! PREFORMANCE OF CURRENT SUPERCOMPUTERS. THE MODEL IS
!! BASED OF THE PAPER - THE DYNAMICS OF FINITE-DIFFERENCE
!! MODELS OF THE SHALLOW-WATER EQUATIONS, BY ROBERT SADOURNY
!! J. ATM. SCIENCES, VOL 32, NO 4, APRIL 1975.
!!
!! CODE BY PAUL N. SWARZTRAUBER, NATIONAL CENTER FOR
!! ATMOSPHERIC RESEARCH, BOULDER, CO,  OCTOBER 1984.
!! Modified by Juliana Rew, NCAR, January 2006
!
!     In this version, shallow4.f, initial and calculated values
!     of U, V, and P are written to a netCDF file
!     for later use in visualizing the results. The netCDF data
!     management library is freely available from
!     http://www.unidata.ucar.edu/software/netcdf
!     This code is still serial but has been brought up to modern
!     Fortran constructs and uses portable intrinsic Fortran 90 timing routines
!     This can be compiled on the IBM SP using:
!     xlf90 -qmaxmem=-1 -g -o shallow4 -qfixed=132 -qsclk=micro \
!     -I/usr/local/include shallow4.f -L/usr/local/lib32/r4i4 -l netcdf
!     where the -L and -I point to local installation of netCDF
!
!     Changes from shallow4.f (Annette Osprey, January 2010):
!     - Converted to free-form fortran 90.
!     - Some tidying up of old commented-out code.
!     - Explicit type declarations.
!     - Variables n, m, itmax and mprint read in from namelist.
!     - Dynamic array allocation.
!     - Only write to netcdf at mprint timesteps.
!     - Don't write wrap-around points to NetCDF file.
!     - Use 8-byte reals.
!
!     This version heavily modified as part of the GOcean-2D project
!     with the mantra "all computation must occur in a kernel."
!     Andrew Porter, April 2014

  use shallow_io_mod
  use dl_timer
  use gocean_mod, only: model_write_log, gocean_initialise, &
                        gocean_finalise
  use model_mod
  use grid_mod
  use field_mod
  use initial_conditions_mod
  use time_smooth_mod,  only: time_smooth
  use apply_bcs_mod,    only: invoke_apply_bcs
  use compute_cu_mod,   only: compute_cu
  use compute_cv_mod,   only: compute_cv
  use compute_z_mod,    only: compute_z
  use compute_h_mod,    only: compute_h
  use compute_unew_mod, only: compute_unew
  use compute_vnew_mod, only: compute_vnew
  use compute_pnew_mod, only: compute_pnew
  use infrastructure_mod,only: copy
  implicit none

  type(grid_type), target :: model_grid
  !> Pressure at {current,previous,next} time step
  type(r2d_field) :: p_fld, pold_fld, pnew_fld
  !> Velocity in x direction at {current,previous,next} time step
  type(r2d_field) :: u_fld, uold_fld, unew_fld
  !> Velocity in x direction at {current,previous,next} time step
  type(r2d_field) :: v_fld, vold_fld, vnew_fld
  !> Mass flux in x and y directions
  type(r2d_field) :: cu_fld, cv_fld
  !> Potential vorticity
  type(r2d_field) :: z_fld
  !> Surface height
  type(r2d_field) :: h_fld
  !> Stream function
  type(r2d_field) :: psi_fld

  !> Loop counter for time-stepping loop
  INTEGER :: ncycle

  !> Integer tags for timers
  INTEGER :: idxt0, idxt1

  call gocean_initialise()
  ! Create the model grid
  !> \todo The call to grid_type here should *not* specify the grid
  !! offset choice as that is an implementation detail. PSyclone
  !! should re-write this call to pass the offset information after it
  !! has examined the kernels to see what they are expecting.
  model_grid = grid_type(GO_ARAKAWA_C,                           &
                         (/GO_BC_PERIODIC,GO_BC_PERIODIC,GO_BC_NONE/), &
                         GO_OFFSET_SW)

  !  ** Initialisations of model parameters (dt etc) **
  CALL model_init(model_grid)

  ! Create fields on this grid
  p_fld    = r2d_field(model_grid, GO_T_POINTS)
  pold_fld = r2d_field(model_grid, GO_T_POINTS)
  pnew_fld = r2d_field(model_grid, GO_T_POINTS)

  u_fld    = r2d_field(model_grid, GO_U_POINTS)
  uold_fld = r2d_field(model_grid, GO_U_POINTS)
  unew_fld = r2d_field(model_grid, GO_U_POINTS)

  v_fld    = r2d_field(model_grid, GO_V_POINTS)
  vold_fld = r2d_field(model_grid, GO_V_POINTS)
  vnew_fld = r2d_field(model_grid, GO_V_POINTS)

  cu_fld = r2d_field(model_grid, GO_U_POINTS)

  cv_fld = r2d_field(model_grid, GO_V_POINTS)

  z_fld = r2d_field(model_grid, GO_F_POINTS)

  h_fld = r2d_field(model_grid, GO_T_POINTS)

  psi_fld = r2d_field(model_grid, GO_F_POINTS)

  ! NOTE BELOW THAT TWO DELTA T (TDT) IS SET TO DT ON THE FIRST
  ! CYCLE AFTER WHICH IT IS RESET TO DT+DT.
  tdt = dt

  !     INITIAL VALUES OF THE STREAM FUNCTION AND P

  call init_initial_condition_params(p_fld)
  call invoke_init_stream_fn_kernel(psi_fld)
  call init_pressure(p_fld)

  !     INITIALIZE VELOCITIES

  call init_velocity_u(u_fld, psi_fld)
  call init_velocity_v(v_fld, psi_fld)

  !     PERIODIC CONTINUATION
  call invoke_apply_bcs(u_fld)
  call invoke_apply_bcs(v_fld)

  ! Generate and output checksums of initial fields
  CALL model_write_log("('psi initial CHECKSUM = ',E24.16)", &
                       field_checksum(psi_fld))
  CALL model_write_log("('P initial CHECKSUM = ',E24.16)",   &
                         field_checksum(p_fld))
  CALL model_write_log("('U initial CHECKSUM = ',E24.16)",   &
                       field_checksum(u_fld))
  CALL model_write_log("('V initial CHECKSUM = ',E24.16)",   &
                       field_checksum(v_fld))

  ! Initialise fields that will hold data at previous time step
  CALL copy_field(u_fld, uold_fld)
  CALL copy_field(v_fld, vold_fld)
  CALL copy_field(p_fld, pold_fld)

  ! Write intial values of p, u, and v into a netCDF file
  call ascii_write(0, 'psifld.dat', psi_fld%data,            &
                   psi_fld%internal%nx, psi_fld%internal%ny, &
                   psi_fld%internal%xstart, psi_fld%internal%ystart)
  CALL model_write(0, p_fld, u_fld, v_fld)

  !     Start timer
  CALL timer_start(idxt0, label='Time-stepping')

  !  ** Start of time loop **
  DO ncycle=1,itmax

    ! COMPUTE CAPITAL U, CAPITAL V, Z AND H

    CALL timer_start(idxt1, label='Compute c{u,v},z,h')

    call invoke( compute_cu(CU_fld, p_fld, u_fld),      &
                 compute_cv(CV_fld, p_fld, v_fld),      &
                 compute_z(z_fld, p_fld, u_fld, v_fld), &
                 compute_h(h_fld, p_fld, u_fld, v_fld) )

    call timer_stop(idxt1)

    ! PERIODIC CONTINUATION

    call timer_start(idxt1, label='PBCs-1')
    ! This call could be generated automatically by PSyclone
    call invoke_apply_bcs(CU_fld)
    call invoke_apply_bcs(CV_fld)
    call invoke_apply_bcs(H_fld)
    call invoke_apply_bcs(Z_fld)
    call timer_stop(idxt1)

    ! COMPUTE NEW VALUES U,V AND P

    call timer_start(idxt1, label='Compute new fields')
    call invoke( compute_unew(unew_fld, uold_fld, z_fld, cv_fld, h_fld, tdt), &
                 compute_vnew(vnew_fld, vold_fld, z_fld, cu_fld, h_fld, tdt), &
                 compute_pnew(pnew_fld, pold_fld, cu_fld, cv_fld, tdt) )
    call timer_stop(idxt1)

    ! PERIODIC CONTINUATION
    call timer_start(idxt1, label='PBCs-2')
    ! This call could be generated by PSyclone
    call invoke_apply_bcs(UNEW_fld)
    call invoke_apply_bcs(VNEW_fld)
    call invoke_apply_bcs(PNEW_fld)
    call timer_stop(idxt1)

    ! Time is in seconds but we never actually need it
    !time = time + dt

    call model_write(ncycle, p_fld, u_fld, v_fld)

    ! TIME SMOOTHING AND UPDATE FOR NEXT CYCLE
    if(NCYCLE .GT. 1) then

      call timer_start(idxt1, label='Time smoothing')

      call invoke( time_smooth(u_fld, UNEW_fld, UOLD_fld), &
                   time_smooth(v_fld, VNEW_fld, VOLD_fld), &
                   time_smooth(p_fld, PNEW_fld, POLD_fld) )

      call timer_stop(idxt1)

    else ! ncycle == 1

      ! Make TDT actually = 2*DT
       tdt = tdt + dt

    endif ! ncycle > 1

    call timer_start(idxt1, label='Field copy')

    call invoke(                       &
                copy(u_fld, unew_fld), &
                copy(v_fld, vnew_fld), &
                copy(p_fld, pnew_fld)  &
               )
!    call copy_field(UNEW_fld, U_fld)
!    call copy_field(VNEW_fld, V_fld)
!    call copy_field(PNEW_fld, p_fld)

    call timer_stop(idxt1)

  end do

  !  ** End of time loop **

  call timer_stop(idxt0)

  ! Output field checksums at end of run for correctness check
  call model_write_log("('P CHECKSUM after ',I6,' steps = ',E24.16)", &
                       itmax, field_checksum(pnew_fld))
  call model_write_log("('U CHECKSUM after ',I6,' steps = ',E24.16)", &
                       itmax, field_checksum(unew_fld))
  call model_write_log("('V CHECKSUM after ',I6,' steps = ',E24.16)", &
                       itmax, field_checksum(vnew_fld))

  call model_finalise()
  call gocean_finalise()

end program shallow


!
!     CalculiX - A 3-dimensional finite element program
!              Copyright (C) 1998-2015 Guido Dhondt
!
!     This program is free software; you can redistribute it and/or
!     modify it under the terms of the GNU General Public License as
!     published by the Free Software Foundation(version 2);
!
!
!     This program is distributed in the hope that it will be useful,
!     but WITHOUT ANY WARRANTY; without even the implied warranty of
!     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
!     GNU General Public License for more details.
!
!     You should have received a copy of the GNU General Public License
!     along with this program; if not, write to the Free Software
!     Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
!
!
!     author: Yannick Muller
!
      subroutine wpi(W, PI, Q, SQTT,kappa,RGAS)
!
!-----------------------------------------------------------------------
!                                                                      |
!     Dieses Unterprogramm berechnet die Stroemungs-Geschwindigkeit    |
!     fuer das eingegebene Druckverhaeltnis PI.                        |
!                                                                      |
!     Eingabe-Groessen:                                                |
!       PI     = Druckverhaeltnis PS/PT                                |
!       Q      = reduzierter Durchsatz                                 |
!       SQTT   = SQRT (Totaltemperatur)                                |
!                                                                      |
!     Ausgabe-Groessen:                                                |
!       W      = Stroemungs-Geschwindigkeit                            |
!                                                                      |
!-----------------------------------------------------------------------
!
      IMPLICIT CHARACTER*1 (A-Z)
!       INCLUDE 'comkapfk.inc'
      real*8    W, PI, Q, SQTT,kappaq,kappa,RGAS,pikrit,kappah,wkritf
!
!-----------------------------------------------------------------------
!
      kappaq = 1/kappa
      PIKRIT = (2./(KAPPA+1.)) ** (KAPPA/(KAPPA-1.))
!
      KAPPAH = 2. * KAPPA / (KAPPA + 1.)
      WKRITF = SQRT( KAPPAH * RGAS )
!
      IF (PI.GE.1.) THEN
!       Druckverhaeltnis groesser gleich 1
        W    = 0.
      ELSEIF (PI.GT.PIKRIT) THEN
!       Druckverhaeltnis unterkritisch
        IF (Q.GT.0.) THEN
          W    = Q * RGAS * SQTT * PI**(-KAPPAQ)
        ELSE
          W    = 0.
        ENDIF
      ELSEIF (PI.GT.0.) THEN
!       Druckverhaeltnis ueberkritisch
        W    = WKRITF * SQTT
      ELSE
!       Druckverhaeltnis ungueltig
        W    = 1.E20
      ENDIF
!
      RETURN
      END


************************************************************************
*
*     Function EXPON                                Called by: TAC_LOAD
*
*     compute unbiased estimate of EXP(A1*SIGMA+B1*SIGMA^2), assuming
*     S2 is a GAMMA(ALPHA,SIGMA^2*KAPPA) random variable.  Result is
*     exact aside from machine error
*
*     S2       sample estimate of SIGMA^2
*     ALPHA    parameter of GAMMA distribution = (N-1)/2 in std. model
*     KAPPA    parameter of gamma distribution = 2/(N-1) in std. model
*     B1       coefficient in front of SIGMA^2
*     A1       coefficient in front of SIGMA
*
************************************************************************
      DOUBLE PRECISION FUNCTION EXPON(S2,ALPHA,KAPPA,B1,A1)
*
*     subroutine args
*
      DOUBLE PRECISION S2,ALPHA,KAPPA,B1,A1
*
*     local vars
*
      INTEGER*4 K,N,ISTEP
      DOUBLE PRECISION ARG,DELTA,TOL,C(0:1000),SK_UNB(0:1000)
      DATA TOL/1.D-15/
*
*     function declaration
*
      DOUBLE PRECISION DLNGAM
*
*
*
      ARG = ABS(B1)*S2+ABS(A1)*SQRT(S2)
      N = MIN(998.D0,30.D0+ARG*(5.4-0.2*ARG+ABS(B1)
     &     *(8.28-1.11*ABS(B1)+1.98*ARG)+1.33*ABS(A1)))

 10   EXPON = 0.D0

      SK_UNB(0) = 1.D0
      SK_UNB(1) = SQRT(S2/KAPPA)
     &            * EXP(DLNGAM(ALPHA)-DLNGAM(ALPHA+0.5D0))

      CALL SQUARE(N,B1,A1,C)

      IF (ABS(A1).LT.TOL) THEN
         ISTEP = 2
      ELSE
         ISTEP = 1
      ENDIF

      DO 20 K=0,N,ISTEP
         DELTA = C(K)*SK_UNB(K)
         EXPON = EXPON + DELTA
         IF (ABS(DELTA).LT.TOL) RETURN
         SK_UNB(K+2) = SK_UNB(K)*(S2/KAPPA)/(ALPHA+0.5D0*K)
 20   CONTINUE
      N = N + 10
      IF (N.LT.998) GOTO 10
*
*     Error: failure to converge in 998 terms
*
      CALL ERROR7(11)

      RETURN
      END


      SUBROUTINE MF_BRNCPT

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

c     Branch points of ZETA as defined by Eq. 3 of NOSC TR 1143 are
c     found. At these points in the THETA plane, the ordinary wave
c     cannot be distinguished from the extraordinary wave. Therefore,
c     magnetoionic reflection coefficients are not defined.

c     Closed solution version.

c  Change History:
c     26 Oct 95     Changed to get the LOG unit from LWPC_LUN.CMN.

c*******************!***************************************************

      implicit complex (a-h,o-z)

c     LWPC parameters
      include      'lwpc_lun.cmn'

      integer        rprnt,xprnt
      real           dcl,dcm,dcn,ec,
     &               dclsq,dcmsq,dcnsq,psq,p,
     &               argln,qmag,zsqmgp,zsqmgm,zsqmag

      common/mf_bpts/bpt(6),nobpts
     &      /mf_drcs/dcl,dcm,dcn,ec,g,q
     &      /mf_prnt/lprnt,lgprnt,mprnt,mrprnt,msprnt,mzprnt,rprnt,xprnt

      dimension      t(4),qq(4)

      if (lprnt .ne. 0 .or. mrprnt .ne. 0)
     &   write(lwpcLOG_lun,
     &       '(''MF_BRNCPT: Closed solution for branch points'')')

      nobpts=0

      dclsq=dcl**2
      dcmsq=dcm**2
      dcnsq=dcn**2
      psq=1.+ec
      p=SQRT(psq)

c     Two solutions to the equation
c        (p**2-t(i)**2)*G (+/-) 2*p*t(i) = 0
c     If t(i)=l*s(i)+n*q(i), this is the condition that ZETA in TR 1143
c     is zero. The other two solutions are the negative of these two.

      t(1)=p*((1.,0.)+SQRT((1.,0.)+g**2))/g
      t(2)=p*((1.,0.)-SQRT((1.,0.)+g**2))/g

c     Solutions to the equation
c        l*S(i)+n*q(i) = t(i)
c     where
c        S(i)**2+q(i)**2 = p**2.
c     Only solutions for which the real part of S(i) is positive are
c     included. The solution replaces the iteration described in Section
c     IV of TR 1143.

      i=1
      do ii=1,2

         rtterm=dcl*SQRT((dclsq+dcnsq)*psq-t(ii)**2)
         qp=(dcn*t(ii)+rtterm)/(dclsq+dcnsq)

         do nrt=1,2

            qsq=qp**2
            s=SQRT(psq-qsq)
            if (REAL(s) .lt. 0.) s=-s

c           A sign ambiguity in q(i) is resolved by substituting back
c           into the equation for ZETA squared (See Eq. 3 of TR 1143).
            a= dcl*s+dcn*qp
            b=-dcn*s+dcl*qp
            zsq=((b**2+dcmsq*psq)*g)**2-4.*a**2*psq
            zsqmgp=ABS(zsq)

            qm=-qp
            a= dcl*s+dcn*qm
            b=-dcn*s+dcl*qm
            zsq=((b**2+dcmsq*psq)*g)**2-4.*a**2*psq
            zsqmgm=ABS(zsq)

            if (zsqmgp .lt. zsqmgm) then
               qq(i)=qp
               zsqmag=zsqmgp
            else
               qq(i)=qm
               zsqmag=zsqmgm
            end if

c           The branch points are found. The condition that the real
c           part of C must have the same sign as the real part of q
c           is included.

            csq=qq(i)**2-ec
            c=SQRT(csq)
            if (REAL(qq(i)) .lt. 0.) c=-c

            tcompl=(0.,-1.)*LOG(s+(0.,1.)*c)
            bpt(i)=(90.,0.)-tcompl*(57.296,0.)

            if (lprnt .ne. 0 .or. mrprnt .ne. 0)
     &         write(lwpcLOG_lun,
     &             '(''MF_BRNCPT: bpt='',2f10.3,'' q='',1p2e10.3,1x,
     &               ''zsqmag='',e10.3)')
     &                 bpt(i),qq(i),zsqmag
            i=i+1
            qp=(dcn*t(ii)-rtterm)/(dclsq+dcnsq)
         end do
      end do

c     THETA = 90 is added to the list of points near which magnetoionic
c     reflection coefficients are no to be used.

      bpt(5)=90.

c     The point nearest the search area at which q = 0 is added to the
c     list of points near which the magnetoionic reflection coefficients
c     are not to be used.

      if (ec .le. 0.) then
         qpt=CMPLX(ACOS(SQRT(-ec))*57.296,0.)
      else
         argln=SQRT(ec)+SQRT(1.+ec)
         qpt=(90.,0.)+(0.,-1.)*LOG(argln)*(57.296,0.)
      end if
      bpt(6)=qpt
      qtest=SQRT(COS(qpt*.01745329252)**2+ec)
      qmag=ABS(qtest)

      if (lprnt .ne. 0 .or. mrprnt .ne. 0)
     &   write(lwpcLOG_lun,
     &       '(''MF_BRNCPT: qmag='',1pe9.2,'' at theta='',0p2f7.3)')
     &           qmag,qpt
      RETURN
      END      ! MF_BRNCPT


      module genint_m
c
        integer, dimension(4), parameter :: nint_tri (4) = (/1,3,6,12/)
        integer, dimension(5), parameter :: nint_quad(5) = (/1,4,9,16,25/)
c
        contains
c
        subroutine genint_if
c
          include "common.h"
c
          integer :: iblk, id
c
c... loop over interface blocks and generate
c    quadrature rules for each...
c
          do iblk = 1, nelblif
c
            id = iftpid(iblk)
c
            select case (id)
            case (1)
c
              nshapeif = (ipord+1)*(ipord+2)/2
c
              nintif0(id) = nint_tri(intg(3,1))
              nintif1(id) = nint_tri(intg(3,1))

              call symtri (nintif0(id), Qptif0(id,:,:), Qwtif0(id,:), nerr)
              call symtri (nintif1(id), Qptif1(id,:,:), Qwtif1(id,:), nerr)
c
c.... adjust quadrature weights to be consistent with the
c     design of tau.
c
              Qwtif0 = two * Qwtif0
              Qwtif1 = two * Qwtif1
c
            case default
              call error ('genint_if ', 'elem Cat', id)
            end select
c
          enddo
c
        end subroutine genint_if
c
      end module genint_m


!==========================================================================
!  Program file name: main.f95                                            !
!                                                                         !
!  © Mehdi Rezaie                                                         !
!                                                                         !
!  Last modified: 2014-10-17 14:27:50                                     !
!                                                                         !
! This program calcualte chi-square between data and flat LCDM model	  !
!                                                                         !
!                                                                         !
!==========================================================================
PROGRAM Main

  USE Routines
  IMPLICIT NONE

  character(len = 20) :: filename,gnu = "gnuplot plot.gnu"
  integer :: i,f,t,l,j,n = 0,n_iteration = 5000 !n # of data
  integer :: n_bins = 300
  real*8 :: p = 3.0D0,del = 1.4D0,alpha,y,norm_factor = 1.96D0

  real*8,allocatable :: z_data(:),dm_data(:),sigma_data(:),chi_temp(:),chi_true(:),chi_lc(:),DM_guess_bins(:),DM_guess_data(:), &
	delta_ar_bin (:), delta_ar_data (:),z(:),DM_smooth_data(:),DM_smooth_bins(:),chi_smooth(:),H(:),q(:)

  real*8 :: x,H0,Om !km/s.Mpc
  real*8 :: chi_min,chi_marginalized,binsize,shift_best

! data reading

!			Argument reading: filename is the name of input which includes the data
!========================================================================

  CALL get_command_argument(1, filename)
  IF (LEN_TRIM(filename) == 0) WRITE(*,*) "Error"
  WRITE(filename,*) TRIM(filename)

!			Opening files
!========================================================================

  OPEN(1, FILE = "inputs/"//TRIM(adjustl(filename)),STATUS = "OLD",ACTION="READ")
  open(2, file = "outputs/chi/chi_"//TRIM(adjustl(filename)),position = "rewind", action = "write")
  open(3, file = "outputs/chi/total_chi_"//TRIM(adjustl(filename)))
  open(10,file = "outputs/mu/mu_"//TRIM(adjustl(filename)))
  open(11,file = "outputs/h/h_"//TRIM(adjustl(filename)))
  open(12,file = "outputs/q/q_"//TRIM(adjustl(filename)))

!			# of data is specified
!
  do
	read(1,*,end = 10)
    n = n + 1
  end do
10 rewind(1)

  print*,n

!		Allocating arrays
!

  allocate(z_data(n),dm_data(n),sigma_data(n),chi_temp(n),chi_true(n),chi_lc(n),DM_guess_bins(n_bins),DM_guess_data(n), &
	delta_ar_bin(n_bins), delta_ar_data(n),z(n_bins),DM_smooth_data(n),DM_smooth_bins(n_bins),chi_smooth(n),&
	H(n_bins),q(n_bins))

  do i =1,n
	read(1,*)z_data(i),dm_data(i),sigma_data(i)
  end do

! generating true model to calculate its chi-square
!========================================================================

  chi_temp = 0.0D0
  chi_true = 0.0D0
  H0 = 68.0D0 ! km/s.Mpc
  chi_min = 50.0D3
  do j = 1,50
    do i = 1, n
    	x = z_data(i)
    	chi_temp(i) = ((Kink_mu (x, H0)-dm_data(i))/(sigma_data(i)))
    end do

    if (sum(chi_temp**2) .LT. chi_min) then
		chi_true = chi_temp
		chi_min = sum(chi_temp**2)
		!print*,"chi min achieved once!",H0
	end if
  H0 = H0 + 0.1
  end do

!	file to write the chi-square of true model

  write(2,'("# z - chi_true")')
  do i =1,n
    write(2,'(2(e26.15))')z_data(i),chi_true(i)
  end do

!  finding chi-square of best LCDM model
  chi_temp = 0.0D0

  chi_min = 5.0D3
  H0 = 68.0D0
  DO l = 1, 50
	 Om = 0.1D0

	 DO f = 1,30
	     DO i = 1, n
	       x = z_data(i)
	       chi_temp(i) =  ((  DM_flat (x,H0,Om)) - (dm_data(i))  ) / (sigma_data(i))
	     END DO
 	   if (sum(chi_temp**2) .LT. chi_min) then
			chi_lc = chi_temp
			chi_min = sum((chi_temp)**2)
!			print*,"chi min achieved once!",H0
		end if

	 Om = Om + 0.01D0
	 END DO
  H0 = H0 + 0.1D0
  END DO
  write(2,'(2/,"# z - chi_LCDM")')
  do i =1,n
    write(2,'(2(e26.15))')z_data(i),chi_lc(i)
  end do

! writing total values of chi-square

  write(3,'("# index 0 - true",/,"#index 1 - LCDM",/,"# index 2:5001 - reconstructed result ")')
  write(3,'("#",e26.15)')sum(chi_true**2)
  write(3,'("#",e26.15)')sum(chi_lc**2)

! smoothing

! binsize
! given no of bins, the binsize is evaluated for the smoothing procedure

  binsize = (MAXVAL(z_data))/Float(n_bins)

  IF (2.0*binsize .GT. MINVAL(z_data)) STOP "*** # of bins is low ***"

!	Calculate alpha, as a normalization factor of Delta(z) and specify the grids given # of bins
!========================================================================

! Determining the redshifts over the grids and normalizing alpha

	alpha = 1.0D0
	y = 0.0D0
	   x = MINVAL(z_data)-(1.5D0*binsize)
	   do i = 1, n_bins
	   z(i) = x
	   y = y + delta2(n,x,p,del,alpha,z_data,sigma_data)
       x = x + binsize
       end do
    alpha = (norm_factor)*(1.0D0/(binsize*y))	! alpha is normalized to 1.0

! Determining Delta on the bins and data points, for later use (smoothing procedure)!

	  do i = 1, n_bins
		x=z(i)
	    delta_ar_bin(i) = delta2(n,x,p,del,alpha,z_data,sigma_data)
     end do

      do i = 1, n
		x=z_data(i)
	    delta_ar_data(i) = delta2(n,x,p,del,alpha,z_data,sigma_data)
      end do

!	initial guess is produced by Om = 0.3 and H0 = 70.0

  H0 = 70.0D0
  Om = 0.30D0
  call Initial_guess (n,n_bins,z_data,H0,binsize,Om,DM_guess_data,DM_guess_bins)
  call Displacement (n,DM_guess_data,dm_data,sigma_data,shift_best,chi_smooth,chi_marginalized)

  DM_guess_data = DM_guess_data + shift_best
  DM_guess_bins = DM_guess_bins + shift_best

! smoothing is started
!========================================================================
  write(2,'(2/,"# z - chi_reconstructed")')
  write(10,'("# first raw is redshift - the rests are d modulus",/,300e26.15)')z

  do t = 1,n_iteration

    write(*,*)"j is started",t

    call Reconstruction (n_bins,DM_guess_bins,z,H,q)
    write(10,'(300e26.15)')DM_guess_bins
    write(11,'(300e26.15)')H
    write(12,'(300e26.15)')q

	call Smoothing (n,n_bins,z_data,sigma_data,dm_data,DM_guess_data,DM_smooth_data,z,&
						DM_guess_bins,DM_smooth_bins,delta_ar_bin,delta_ar_data)

	call Displacement (n,DM_guess_data,dm_data,sigma_data,shift_best,chi_smooth,chi_marginalized)
	DM_guess_data = DM_guess_data + shift_best
	DM_guess_bins = DM_guess_bins + shift_best

 	if (t .le. n_iteration .and. MOD(t,10) .eq. 0)then
  		 do i =1,n
 		   write(2,'(2(e26.15))')z_data(i),chi_smooth(i)
 		 end do
 		 write(2,'(/)')
 		 write(3,'(I4,1x,e26.15)')t,sum(chi_smooth**2)
    end if

  end do

deallocate (z_data,dm_data,sigma_data,chi_temp,chi_true,chi_lc,DM_guess_bins,DM_guess_data,delta_ar_bin,delta_ar_data,z,&
	DM_smooth_data,DM_smooth_bins,chi_smooth,H,q)
END PROGRAM Main


C     LAST UPDATE 04/08/95
C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
      SUBROUTINE FVOIGT(X,A,Y,DYDA)
      IMPLICIT NONE
C
C Purpose: Y(X;A) is a Voigtian. The amplitude. centre and widths of
C          the Voigtian are stored in consecutive locations of A:
C          A(1) = H,  A(2) = P,
C          A(3) = FWHM(Gaussian), A(4) = FWHM(Lorentzian)
C
C-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-
C Parameters:
C
      DOUBLE PRECISION TINY,FACTOR
      PARAMETER(TINY=1.0D-10,FACTOR=1.66510922231D0)
C
C Arguments:
C
      DOUBLE PRECISION A(10),DYDA(10)
      DOUBLE PRECISION X,Y
C
C Local variables:
C
      INTEGER I
      DOUBLE PRECISION  V,Z,P,PMA,ZMB,ZMB2,PMA2,DVDZ,DVDP,TOP,BOT,BOT2,
     &                  PP,W,DVMDP,TOPM,BOTM
      DOUBLE PRECISION  ALPHA(4),BETA(4),GAMMA(4),DELTA(4),GAPDB(4),
     &                  A2PB2(4)
C
C Common block:
C
      DOUBLE PRECISION VMAX
      COMMON /VGTCOM/VMAX
      SAVE /VGTCOM/
C
C Data:
C
      DATA ALPHA /-1.2150D0,-1.3509D0,-1.2150D0,-1.3509D0/,
     &     BETA  / 1.2359D0, 0.3786D0,-1.2359D0,-0.3786D0/,
     &     GAMMA /-0.3085D0, 0.5906D0,-0.3085D0, 0.5906D0/,
     &     DELTA / 0.0210D0,-1.1858D0,-0.0210D0, 1.1858D0/
      DATA GAPDB / 0.4007814D0,-1.24678542D0,0.4007814D0,-1.24678542D0/,
     &     A2PB2 / 3.00367381D0,1.96826877D0,3.00367381D0,1.96826877D0/
C
C-----------------------------------------------------------------------
      P = A(4)/2.0D0
      PP = P*P
      IF(A(3).LT.TINY)A(3) = TINY
      W = A(3)/FACTOR
      Z = (X-A(2))/W
      V = 0.0D0
      VMAX = 0.0D0
      DVDZ = 0.0D0
      DVDP = 0.0D0
      DVMDP = 0.0D0
      DO 10 I=1,4
         PMA = P - ALPHA(I)
         ZMB = Z - BETA(I)
         PMA2 = PMA*PMA
         ZMB2 = ZMB*ZMB
         TOP = GAMMA(I)*PMA + DELTA(I)*ZMB
         BOT = PMA2 + ZMB2
         BOT2 = BOT*BOT
         V = V + TOP/BOT
         TOPM = GAMMA(I)*P - GAPDB(I)
         BOTM = PP - 2.0D0*P*ALPHA(I) + A2PB2(I)
         VMAX = VMAX + TOPM/BOTM
         DVDZ = DVDZ + (DELTA(I)*BOT-2.0D0*ZMB*TOP)/BOT2
         DVDP = DVDP + (GAMMA(I)*BOT-2.0D0*PMA*TOP)/BOT2
         DVMDP = DVMDP + (GAMMA(I)*BOTM-2.0D0*PMA*TOPM)/(BOTM*BOTM)
 10   CONTINUE
      V = V/VMAX
      DVDZ = DVDZ/VMAX
      DVDP = DVDP/VMAX
      DVMDP = DVMDP/VMAX
      Y = A(1)*V
      DYDA(1) = V
      DYDA(2) = -DVDZ*A(1)/W
      DYDA(3) = FACTOR*Z*DYDA(2)
      DYDA(4) = 2.0D0*A(1)*(DVDP-V*DVMDP)
C
      RETURN
      END


$ Declare
   SUBROUTINE Parameter_f (Smax, fy, fu, f, A0)
!
! parameters
   USE PublicPar
   IMPLICIT NONE
!
   DOUBLE PRECISION, INTENT(IN)    :: Smax, fy, fu
   DOUBLE PRECISION, INTENT(OUT)   :: f, A0
!
! declarations
   DOUBLE PRECISION  :: pi
   DOUBLE PRECISION  :: Sflow
   DOUBLE PRECISION  :: A1, A2, A3, f1, f2, fK
   DOUBLE PRECISION  :: ratio
!
! material: steel in air (NasGro equations, parameters
! acc. to Fitnet and German dissertation)
!
! Constants and parameters
   pi    = 3.14159265358979D0
!
   Sflow = (fy + fu) / (2*fy)
   ratio = MIN (Smax / Sflow, 0.5D0)
   A0 = (0.825D0-0.34D0*alpha+0.05D0*alpha**2D0)*(DCOS(pi/2.D0*ratio))**(1.D0/alpha)
   A1 = (0.415D0-0.071D0*alpha)*ratio
   A3 = 2.D0*A0+A1-1.D0
   A2 = 1.D0-A0-A1-A3
   f1 = A0 + A1*R + A2*R**2 + A3*R**3
   f2 = A0 + A1*R
!
   IF (R.GE.0.) THEN
     fK = MAX (R,f1)
   ELSE IF (R.GE.-2.) THEN
     fK = f2
   ELSE IF (R.LT.-2.) THEN
     fK = A0 - 2*A1
   END IF
!
   IF (fK.GE.0.) THEN
     f = fK
   ELSE
     f = 0.
   END IF
!
! End subroutine
   RETURN
   END


subroutine utm_geo(rlon,rlat,rx,ry,UTM_PROJECTION_ZONE,iway)

  !   Convert geodetic longitude and latitude to UTM, and back.
  !   Use iway=ILONGLAT2UTM for long/lat to UTM, IUTM2LONGLAT for UTM to lat/long.

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

  !   CAMx v2.03
  !
  !     UTM_GEO performs UTM to geodetic (long/lat) translation, and back.
  !
  !     This is a Fortran version of the BASIC program "Transverse Mercator
  !     Conversion", Copyright 1986, Norman J. Berls (Stefan Musarra, 2/94)
  !     Based on algorithm taken from "Map Projections Used by the USGS"
  !     by John P. Snyder, Geological Survey Bulletin 1532, USDI.
  !
  !     Input/Output arguments:
  !
  !        rlon                  Longitude (deg, negative for West)
  !        rlat                  Latitude (deg)
  !        rx                    UTM easting (m)
  !        ry                    UTM northing (m)
  !        UTM_PROJECTION_ZONE   UTM zone
  !        iway                  Conversion type
  !                              ILONGLAT2UTM=geodetic to UTM
  !                              IUTM2LONGLAT=UTM to geodetic

  integer UTM_PROJECTION_ZONE,iway

  logical, parameter :: SUPPRESS_UTM_PROJECTION = .false.
  integer, parameter :: ILONGLAT2UTM = 0, IUTM2LONGLAT = 1
  double precision, parameter :: semimaj=6378206.4d0, semimin=6356583.8d0
  double precision, parameter :: scfa=.9996d0
  double precision, parameter :: north=0.d0, east=500000.d0

  PI=4.d0*datan(1.d0)
  TWO_PI=2.d0*PI
  degrad=PI/180.d0
  raddeg=180.d0/PI

  if(SUPPRESS_UTM_PROJECTION) then
     if(iway==ILONGLAT2UTM) then
        rx=rlon
        ry=rlat
     else
        rlon=rx
        rlat=ry
     endif
     return
  endif

  !   Save original parameters

  rlon_save=rlon
  rlat_save=rlat
  rx_save=rx
  ry_save=ry

!   Define parameters of reference ellipsoid

  e2=1.d0-(semimin/semimaj)**2.d0
  e4=e2*e2
  e6=e2*e4
  ep2=e2/(1.d0-e2)

  if(iway==IUTM2LONGLAT) then
     xx=rx
     yy=ry
  else
     dlon=rlon
     dlat=rlat
  endif

!   Set Zone parameters. cm: central meridian.

  zone=dble(UTM_PROJECTION_ZONE)
  cm=zone*6.d0-183.d0
  cmr=cm*degrad

  !   Lat/Lon to UTM conversion

  if(iway==ILONGLAT2UTM) then

     rlon=degrad*dlon
     rlat=degrad*dlat

     delam=dlon-cm
     if(delam<-180.d0) delam=delam+360.d0
     if(delam>180.d0) delam=delam-360.d0
     delam=delam*degrad

     f1=(1.d0-e2/4.d0-3.d0*e4/64.d0-5.d0*e6/256.d0)*rlat
     f2=3.d0*e2/8.d0+3.d0*e4/32.d0+45.d0*e6/1024.d0
     f2=f2*dsin(2.d0*rlat)
! corrected 5/4/21: f3=15.d0*e4/256.d0*45.d0*e6/1024.d0
     f3=15.d0*e4/256.d0+45.d0*e6/1024.d0
     f3=f3*dsin(4.d0*rlat)
     f4=35.d0*e6/3072.d0
     f4=f4*dsin(6.d0*rlat)
     rm=semimaj*(f1-f2+f3-f4)

     if(dlat==90.d0.or.dlat==-90.d0) then
        xx=0.d0
        yy=scfa*rm
     else
        rn=semimaj/dsqrt(1.d0-e2*dsin(rlat)**2)
        t=dtan(rlat)**2
        c=ep2*dcos(rlat)**2
        a=dcos(rlat)*delam

        f1=(1.d0-t+c)*a**3/6.d0
        f2=5.d0-18.d0*t+t**2+72.d0*c-58.d0*ep2
        f2=f2*a**5/120.d0
        xx=scfa*rn*(a+f1+f2)
        f1=a**2/2.d0
        f2=5.d0-t+9.d0*c+4.d0*c**2
        f2=f2*a**4/24.d0
        f3=61.d0-58.d0*t+t**2+600.d0*c-330.d0*ep2
        f3=f3*a**6/720.d0
        yy=scfa*(rm+rn*dtan(rlat)*(f1+f2+f3))
     endif

     xx=xx+east
     yy=yy+north

     !   UTM to Lat/Lon conversion

  else

     xx=xx-east
     yy=yy-north
     e1=dsqrt(1.d0-e2)
     e1=(1.d0-e1)/(1.d0+e1)
     rm=yy/scfa
     u=1.d0-e2/4.d0-3.d0*e4/64.d0-5.d0*e6/256.d0
     u=rm/(semimaj*u)

     f1=3.d0*e1/2.d0-27.d0*e1**3/32.d0
     f1=f1*dsin(2.d0*u)
     f2=21.d0*e1**2/16.d0-55.d0*e1**4/32.d0
     f2=f2*dsin(4.d0*u)
     f3=151.d0*e1**3.d0/96.d0
     f3=f3*dsin(6.d0*u)
     rlat1=u+f1+f2+f3
     dlat1=rlat1*raddeg

     if(dlat1>=90.d0.or.dlat1<=-90.d0) then
        dlat1=dmin1(dlat1,dble(90.d0))
        dlat1=dmax1(dlat1,dble(-90.d0))
        dlon=cm
     else
        c1=ep2*dcos(rlat1)**2
        t1=dtan(rlat1)**2
        f1=1.d0-e2*dsin(rlat1)**2
        rn1=semimaj/dsqrt(f1)
        r1=semimaj*(1.d0-e2)/dsqrt(f1**3)
        d=xx/(rn1*scfa)

        f1=rn1*dtan(rlat1)/r1
        f2=d**2/2.d0
! corrected 5/4/21: f3=5.d0*3.d0*t1+10.d0*c1-4.d0*c1**2-9.d0*ep2
        f3=5.d0+3.d0*t1+10.d0*c1-4.d0*c1**2-9.d0*ep2
        f3=f3*d**2*d**2/24.d0
        f4=61.d0+90.d0*t1+298.d0*c1+45.d0*t1**2-252.d0*ep2-3.d0*c1**2
        f4=f4*(d**2)**3.d0/720.d0
        rlat=rlat1-f1*(f2-f3+f4)
        dlat=rlat*raddeg

        f1=1.d0+2.d0*t1+c1
        f1=f1*d**2*d/6.d0
        f2=5.d0-2.d0*c1+28.d0*t1-3.d0*c1**2+8.d0*ep2+24.d0*t1**2
        f2=f2*(d**2)**2*d/120.d0
        rlon=cmr+(d-f1+f2)/dcos(rlat1)
        dlon=rlon*raddeg
        if(dlon<-180.d0) dlon=dlon+360.d0
        if(dlon>180.d0) dlon=dlon-360.d0
     endif

  endif

  if(iway==IUTM2LONGLAT) then
     rlon=dlon
     rlat=dlat
     rx=rx_save
     ry=ry_save
  else
     rx=xx
     ry=yy
     rlon=rlon_save
     rlat=rlat_save
  endif

  return
end subroutine utm_geo