*
* This file contains a test program and functions TVTL (trivariate normal
* and t), BVTL (bivariate t), BVND (bivariate normal), STUDNT (univariate
* t), PHID (univariate normal), plus some support functions.
* The file is self contained and should compile without errors on (77)
* standard Fortran compilers. The test program demonstrates the use of
* TVTL for computing trivariate distribution values 20 test problems
* with NU = 0 (normal case), 3, 6, 9, and 12.
*
* The software is based on work described in the paper
*  "Numerical Computation of Rectangular Bivariate and Trivariate Normal
*    and t Probabilities", by
*
*          Alan Genz
*          Department of Mathematics
*          Washington State University
*          Pullman, WA 99164-3113
*          Email : alangenz@wsu.edu
*
      PROGRAM TVTST
      INTEGER I, J, NU, NT
      PARAMETER ( NT = 20 )
      DOUBLE PRECISION TVTL, LIMIT(3,NT), SIGMA(3,NT), EPS, V
      DATA ( LIMIT(I,1), I = 1, 3 ), ( SIGMA(I,1), I = 1, 3 )
     &     / .5D0, .5D0, .8D0, .1D0, .6D0, .8D0 /
      DATA ( LIMIT(I,2), I = 1, 3 ), ( SIGMA(I,2), I = 1, 3 )
     &     / -2.5D0, .5D0, .8D0, .1D0, -.6D0, -.8D0 /
      DATA ( LIMIT(I,3), I = 1, 3 ), ( SIGMA(I,3), I = 1, 3 )
     &     / 1.5D0, .5D0, .8D0, .1D0, .6D0, .8D0 /
      DATA ( LIMIT(I,4), I = 1, 3 ), ( SIGMA(I,4), I = 1, 3 )
     &     / .5D0, .5D0, .8D0, .1D0, -.6D0, -.8D0 /
      DATA ( LIMIT(I,5), I = 1, 3 ), ( SIGMA(I,5), I = 1, 3 )
     &     / .5D0, .5D0, .8D0, .1D0, -.5D0, .5D0 /
      DATA ( LIMIT(I,6), I = 1, 3 ), ( SIGMA(I,6), I = 1, 3 )
     &     / -1.5D0, .5D0, .8D0, .1D0, -.5D0, .5D0 /
      DATA ( LIMIT(I,7), I = 1, 3 ), ( SIGMA(I,7), I = 1, 3 )
     &     / 1.5D0, .5D0, .8D0, .1D0, .5D0, -.5D0 /
      DATA ( LIMIT(I,8), I = 1, 3 ), ( SIGMA(I,8), I = 1, 3 )
     &     / -.5D0, 1D0, 1.2D0, -.4D0, .2D0, .7D0 /
      DATA ( LIMIT(I,9), I = 1, 3 ), ( SIGMA(I,9), I = 1, 3 )
     &     / 1D0, 1D0, 2D0, .4D0, .8D0, .8D0 /
      DATA ( LIMIT(I,10), I = 1, 3 ), ( SIGMA(I,10), I = 1, 3 )
     &     / 1D0, 2D0, 1D0, .4D0, .8D0, .8D0 /
      DATA ( LIMIT(I,11), I = 1, 3 ), ( SIGMA(I,11), I = 1, 3 )
     &     / -2D0, -2D0, -2D0, .4D0, .8D0, .8D0 /
      DATA ( LIMIT(I,12), I = 1, 3 ), ( SIGMA(I,12), I = 1, 3 )
     *     / 1D0, 2D0, 3D0, -.998D0, -0.248D0, 0.248D0 /
      DATA ( LIMIT(I,13), I = 1, 3 ), ( SIGMA(I,13), I = 1, 3 )
     *     / -1D0, 2D0, 3D0, .25D0, 0.25D0, 0.25D0 /
      DATA ( LIMIT(I,14), I = 1, 3 ), ( SIGMA(I,14), I = 1, 3 )
     *     /  1D0, 1D0, 3D0, .998D0, 0.2482D0, 0.2487D0 /
      DATA ( LIMIT(I,15), I = 1, 3 ), ( SIGMA(I,15), I = 1, 3 )
     *     /  1D0, 1D0, 3D0, .998D0, 0.5D0, 0.5D0 /
      DATA ( LIMIT(I,16), I = 1, 3 ), ( SIGMA(I,16), I = 1, 3 )
     *     /  1D0, 1D0, 3D0, .99D0, 0.99D0, 0.99D0 /
      DATA ( LIMIT(I,17), I = 1, 3 ), ( SIGMA(I,17), I = 1, 3 )
     *     /  1D0, 2D0, 3D0, -1D0, -.99D0, .99D0 /
      DATA ( LIMIT(I,18), I = 1, 3 ), ( SIGMA(I,18), I = 1, 3 )
     *     /  1D0, 2D0, 3D0, 1D0, -.99D0, -.99D0 /
      DATA ( LIMIT(I,19), I = 1, 3 ), ( SIGMA(I,19), I = 1, 3 )
     *     /  1D0, -1D0, 1D0, .998D0, -0.2482D0, -0.2482D0 /
      DATA ( LIMIT(I,NT), I = 1, 3 ), ( SIGMA(I,NT), I = 1, 3 )
     *     /  1D0, -1D0, 2D0, .99992D0, 0.64627D0, 0.63975D0 /
      EPS = 1D-6
      PRINT '(''      Trivariate t Test with EPS ='', E10.1)', EPS
      DO NU = 0, 12, 3
         PRINT '(''NU   B1   B2   B3    R21      R31      R32    TVT'')'
         DO J = 1, NT
            V = TVTL( NU, LIMIT(1,J), SIGMA(1,J), EPS )
            PRINT '(I2,3F5.1,3F9.5,F13.10)', NU,
     &           ( LIMIT(I,J), I = 1, 3 ), ( SIGMA(I,J), I = 1, 3 ), V
         END DO
      END DO
      END
*
      DOUBLE PRECISION FUNCTION TVTL( NU, H, R, EPSI )
*
*     A function for computing trivariate normal and t-probabilities.
*     This function uses algorithms developed from the ideas
*     described in the papers:
*       R.L. Plackett, Biometrika 41(1954), pp. 351-360.
*       Z. Drezner, Math. Comp. 62(1994), pp. 289-294.
*     with adaptive integration from (0,0,1) to (0,0,r23) to R.
*
*      Calculate the probability that X(I) < H(I), for I = 1,2,3
*    NU   INTEGER degrees of freedom; use NU = 0 for normal cases.
*    H    REAL array of uppoer limits for probability distribution
*    R    REAL array of three correlation coefficients, R should
*         contain the lower left portion of the correlation matrix r.
*         R should contains the values r21, r31, r23 in that order.
*   EPSI  REAL required absolute accuracy; maximum accuracy for most
*          computations is approximately 1D-14
*
*    The software is based on work described in the paper
*     "Numerical Computation of Rectangular Bivariate and Trivariate
*      Normal and t Probabilities", by the code author:
*
*       Alan Genz
*       Department of Mathematics
*       Washington State University
*       Pullman, WA 99164-3113
*       Email : alangenz@wsu.edu
*
*
* Copyright (C) 2013, Alan Genz,  All rights reserved.
*
* Redistribution and use in source and binary forms, with or without
* modification, are permitted provided the following conditions are met:
*   1. Redistributions of source code must retain the above copyright
*      notice, this list of conditions and the following disclaimer.
*   2. Redistributions in binary form must reproduce the above copyright
*      notice, this list of conditions and the following disclaimer in
*      the documentation and/or other materials provided with the
*      distribution.
*   3. The contributor name(s) may not be used to endorse or promote
*      products derived from this software without specific prior
*      written permission.
* THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
* "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
* LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS
* FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
* COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT,
* INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING,
* BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS
* OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND
* ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR
* TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF USE
* OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
*
      EXTERNAL TVTMFN
      INTEGER NU, NUC
      DOUBLE PRECISION H(3), H1, H2, H3, R(3), R12, R13, R23, EPSI
      DOUBLE PRECISION ONE, ZRO, EPS, ZROS(3), HS(3), TVT
      DOUBLE PRECISION RUA, RUB, AR, RUC, PT, BVTL, PHID, ADONET
      PARAMETER ( ZRO = 0, ONE = 1 )
      COMMON /TVTMBK/ H1, H2, H3, R23, RUA, RUB, AR, RUC, NUC
      EPS = MAX( 1D-14, EPSI )
      PT = ASIN(ONE)
      NUC = NU
      H1 = H(1)
      H2 = H(2)
      H3 = H(3)
      R12 = R(1)
      R13 = R(2)
      R23 = R(3)
*
*     Sort R's and check for special cases
*
      IF ( ABS(R12) .GT. ABS(R13) ) THEN
         H2 = H3
         H3 = H(2)
         R12 = R13
         R13 = R(1)
      END IF
      IF ( ABS(R13) .GT. ABS(R23) ) THEN
         H1 = H2
         H2 = H(1)
         R23 = R13
         R13 = R(3)
      END IF
      TVT = 0
      IF ( ABS(H1) + ABS(H2) + ABS(H3) .LT. EPS ) THEN
         TVT = ( 1 + ( ASIN(R12) + ASIN(R13) + ASIN(R23) )/PT )/8
      ELSE IF ( NU .LT. 1 .AND. ABS(R12) + ABS(R13) .LT. EPS ) THEN
         TVT = PHID(H1)*BVTL( NU, H2, H3, R23 )
      ELSE IF ( NU .LT. 1 .AND. ABS(R13) + ABS(R23) .LT. EPS ) THEN
         TVT = PHID(H3)*BVTL( NU, H1, H2, R12 )
      ELSE IF ( NU .LT. 1 .AND. ABS(R12) + ABS(R23) .LT. EPS ) THEN
         TVT = PHID(H2)*BVTL( NU, H1, H3, R13 )
      ELSE IF ( 1 - R23 .LT. EPS ) THEN
         TVT = BVTL( NU, H1, MIN( H2, H3 ), R12 )
      ELSE IF ( R23 + 1 .LT. EPS ) THEN
         IF  ( H2 .GT. -H3 )
     &        TVT = BVTL( NU, H1, H2, R12 ) - BVTL( NU, H1, -H3, R12 )
      ELSE
*
*        Compute singular TVT value
*
         IF ( NU .LT. 1 ) THEN
            TVT = BVTL( NU, H2, H3, R23 )*PHID(H1)
         ELSE IF ( R23 .GE. 0 ) THEN
            TVT = BVTL( NU, H1, MIN( H2, H3 ), ZRO )
         ELSE IF ( H2 .GT. -H3 ) THEN
            TVT = BVTL( NU, H1, H2, ZRO ) - BVTL( NU, H1, -H3, ZRO )
         END IF
*
*        Use numerical integration to compute probability
*
*
         RUA = ASIN( R12 )
         RUB = ASIN( R13 )
         AR = ASIN( R23)
         RUC = SIGN( PT, AR ) - AR
         TVT = TVT + ADONET( TVTMFN, ZRO, ONE, EPS )/( 4*PT )
      END IF
      TVTL = MAX( ZRO, MIN( TVT, ONE ) )
      END
*
      DOUBLE PRECISION FUNCTION TVTMFN( X )
*
*     Computes Plackett formula integrands
*
      INTEGER NU
      DOUBLE PRECISION X, H1, H2, H3, R23, RUA, RUB, AR, RUC
      DOUBLE PRECISION R12, RR2, R13, RR3, R, RR, ZRO, PNTGND
      PARAMETER ( ZRO = 0 )
      COMMON /TVTMBK/ H1, H2, H3, R23, RUA, RUB, AR, RUC, NU
      TVTMFN = 0
      CALL SINCS( RUA*X, R12, RR2 )
      CALL SINCS( RUB*X, R13, RR3 )
      IF ( ABS(RUA) .GT. 0 )
     &     TVTMFN = TVTMFN + RUA*PNTGND( NU, H1,H2,H3, R13,R23,R12,RR2 )
      IF ( ABS(RUB) .GT. 0 )
     &     TVTMFN = TVTMFN + RUB*PNTGND( NU, H1,H3,H2, R12,R23,R13,RR3 )
      IF ( NU .GT. 0 ) THEN
         CALL SINCS( AR + RUC*X, R, RR )
         TVTMFN = TVTMFN - RUC*PNTGND( NU, H2, H3, H1, ZRO, ZRO, R, RR )
      END IF
      END
*
      SUBROUTINE SINCS( X, SX, CS )
*
*     Computes SIN(X), COS(X)^2, with series approx. for |X| near PI/2
*
      DOUBLE PRECISION X, SX, CS, PT, EE
      PARAMETER ( PT = 1.57079632679489661923132169163975D0 )
      EE = ( PT - ABS(X) )**2
      IF ( EE .LT. 5D-5 ) THEN
         SX = SIGN( 1 - EE*( 1 - EE/12 )/2, X )
         CS = EE*( 1 - EE*( 1 - 2*EE/15 )/3 )
      ELSE
         SX = SIN(X)
         CS = 1 - SX*SX
      END IF
      END
*
      DOUBLE PRECISION FUNCTION PNTGND( NU, BA, BB, BC, RA, RB, R, RR )
*
*     Computes Plackett formula integrand
*
      INTEGER NU
      DOUBLE PRECISION BA, BB, BC, RA, RB, R, RR
      DOUBLE PRECISION DT, FT, BT, PHID, STUDNT
      PNTGND = 0
      DT = RR*( RR - ( RA - RB )**2 - 2*RA*RB*( 1 - R ) )
      IF ( DT .GT. 0 ) THEN
         BT = ( BC*RR + BA*( R*RB - RA ) + BB*( R*RA -RB ) )/SQRT(DT)
         FT = ( BA - R*BB )**2/RR + BB*BB
         IF ( NU .LT. 1 ) THEN
            IF ( BT .GT. -10 .AND. FT .LT. 100 ) THEN
               PNTGND = EXP( -FT/2 )
               IF ( BT .LT. 10 ) PNTGND = PNTGND*PHID(BT)
            END IF
         ELSE
            FT = SQRT( 1 + FT/NU )
            PNTGND = STUDNT( NU, BT/FT )/FT**NU
         END IF
      END IF
      END
*
      DOUBLE PRECISION FUNCTION ADONET( F, A, B, TOL )
*
*     One Dimensional Globally Adaptive Integration Function
*
      EXTERNAL F
      DOUBLE PRECISION F, A, B, TOL
      INTEGER NL, I, IM, IP
      PARAMETER ( NL = 100 )
      DOUBLE PRECISION EI(NL), AI(NL), BI(NL), FI(NL), FIN, ERR, KRNRDT
      COMMON /ABLK/ ERR, IM
      AI(1) = A
      BI(1) = B
      ERR = 1
      IP = 1
      IM = 1
      DO WHILE ( 4*ERR .GT. TOL .AND. IM .LT. NL )
         IM = IM + 1
         BI(IM) = BI(IP)
         AI(IM) = ( AI(IP) + BI(IP) )/2
         BI(IP) = AI(IM)
         FI(IP) = KRNRDT( AI(IP), BI(IP), F, EI(IP) )
         FI(IM) = KRNRDT( AI(IM), BI(IM), F, EI(IM) )
         ERR = 0
         FIN = 0
         DO I = 1, IM
            IF ( EI(I) .GT. EI(IP) ) IP = I
            FIN = FIN + FI(I)
            ERR = ERR + EI(I)**2
         END DO
         ERR = SQRT( ERR )
      END DO
      ADONET = FIN
      END
*
      DOUBLE PRECISION FUNCTION KRNRDT( A, B, F, ERR )
*
*     Kronrod Rule
*
      DOUBLE PRECISION A, B, ERR, T, CEN, F, FC, WID, RESG, RESK
*
*        The abscissae and weights are given for the interval (-1,1);
*        only positive abscissae and corresponding weights are given.
*
*        XGK    - abscissae of the 2N+1-point Kronrod rule:
*                 XGK(2), XGK(4), ...  N-point Gauss rule abscissae;
*                 XGK(1), XGK(3), ...  optimally added abscissae.
*        WGK    - weights of the 2N+1-point Kronrod rule.
*        WG     - weights of the N-point Gauss rule.
*
      INTEGER J, N
      PARAMETER ( N = 11 )
      DOUBLE PRECISION WG(0:(N+1)/2), WGK(0:N), XGK(0:N)
      SAVE WG, WGK, XGK
      DATA WG( 0)/ 0.2729250867779007D+00/
      DATA WG( 1)/ 0.5566856711617449D-01/
      DATA WG( 2)/ 0.1255803694649048D+00/
      DATA WG( 3)/ 0.1862902109277352D+00/
      DATA WG( 4)/ 0.2331937645919914D+00/
      DATA WG( 5)/ 0.2628045445102478D+00/
*
      DATA XGK( 0)/ 0.0000000000000000D+00/
      DATA XGK( 1)/ 0.9963696138895427D+00/
      DATA XGK( 2)/ 0.9782286581460570D+00/
      DATA XGK( 3)/ 0.9416771085780681D+00/
      DATA XGK( 4)/ 0.8870625997680953D+00/
      DATA XGK( 5)/ 0.8160574566562211D+00/
      DATA XGK( 6)/ 0.7301520055740492D+00/
      DATA XGK( 7)/ 0.6305995201619651D+00/
      DATA XGK( 8)/ 0.5190961292068118D+00/
      DATA XGK( 9)/ 0.3979441409523776D+00/
      DATA XGK(10)/ 0.2695431559523450D+00/
      DATA XGK(11)/ 0.1361130007993617D+00/
*
      DATA WGK( 0)/ 0.1365777947111183D+00/
      DATA WGK( 1)/ 0.9765441045961290D-02/
      DATA WGK( 2)/ 0.2715655468210443D-01/
      DATA WGK( 3)/ 0.4582937856442671D-01/
      DATA WGK( 4)/ 0.6309742475037484D-01/
      DATA WGK( 5)/ 0.7866457193222764D-01/
      DATA WGK( 6)/ 0.9295309859690074D-01/
      DATA WGK( 7)/ 0.1058720744813894D+00/
      DATA WGK( 8)/ 0.1167395024610472D+00/
      DATA WGK( 9)/ 0.1251587991003195D+00/
      DATA WGK(10)/ 0.1312806842298057D+00/
      DATA WGK(11)/ 0.1351935727998845D+00/
*
*           Major variables
*
*           CEN  - mid point of the interval
*           WID  - half-length of the interval
*           RESG - result of the N-point Gauss formula
*           RESK - result of the 2N+1-point Kronrod formula
*
*           Compute the 2N+1-point Kronrod approximation to
*            the integral, and estimate the absolute error.
*
      WID = ( B - A )/2
      CEN = ( B + A )/2
      FC = F(CEN)
      RESG = FC*WG(0)
      RESK = FC*WGK(0)
      DO J = 1, N
         T = WID*XGK(J)
         FC = F( CEN - T ) + F( CEN + T )
         RESK = RESK + WGK(J)*FC
         IF( MOD( J, 2 ) .EQ. 0 ) RESG = RESG + WG(J/2)*FC
      END DO
      KRNRDT = WID*RESK
      ERR = ABS( WID*( RESK - RESG ) )
      END
*
      DOUBLE PRECISION FUNCTION STUDNT( NU, T )
*
*     Student t Distribution Function
*
*                       T
*         STUDNT = C   I  ( 1 + y*y/NU )**( -(NU+1)/2 ) dy
*                   NU -INF
*
      INTEGER NU, J
      DOUBLE PRECISION T, ZRO, ONE, PI, PHID
      DOUBLE PRECISION CSSTHE, SNTHE, POLYN, TT, TS, RN
      PARAMETER ( ZRO = 0, ONE = 1 )
      PI = ACOS(-ONE)
      IF ( NU .LT. 1 ) THEN
         STUDNT = PHID( T )
      ELSE IF ( NU .EQ. 1 ) THEN
         STUDNT = ( 1 + 2*ATAN(T)/PI )/2
      ELSE IF ( NU .EQ. 2 ) THEN
         STUDNT = ( 1 + T/SQRT( 2 + T*T ))/2
      ELSE
         TT = T*T
         CSSTHE = 1/( 1 + TT/NU )
         POLYN = 1
         DO J = NU-2, 2, -2
            POLYN = 1 + ( J - 1 )*CSSTHE*POLYN/J
         END DO
         IF ( MOD( NU, 2 ) .EQ. 1 ) THEN
            RN = NU
            TS = T/SQRT(RN)
            STUDNT = ( 1 + 2*( ATAN(TS) + TS*CSSTHE*POLYN )/PI )/2
         ELSE
            SNTHE = T/SQRT( NU + TT )
            STUDNT = ( 1 + SNTHE*POLYN )/2
         END IF
         STUDNT = MAX( ZRO, MIN( STUDNT, ONE ) )
      ENDIF
      END
*
      DOUBLE PRECISION FUNCTION BVTL( NU, DH, DK, R )
*
*     A function for computing bivariate t probabilities.
*
*       Alan Genz
*       Department of Mathematics
*       Washington State University
*       Pullman, WA 99164-3113
*       Email : alangenz@wsu.edu
*
*    This function is based on the method described by
*        Dunnett, C.W. and M. Sobel, (1954),
*        A bivariate generalization of Student's t-distribution
*        with tables for certain special cases,
*        Biometrika 41, pp. 153-169.
*
* BVTL - calculate the probability that X < DH and Y < DK.
*
* parameters
*
*   NU number of degrees of freedom
*   DH 1st lower integration limit
*   DK 2nd lower integration limit
*   R   correlation coefficient
*
      INTEGER NU, J, HS, KS
      DOUBLE PRECISION DH, DK, R
      DOUBLE PRECISION TPI, PI, ORS, HRK, KRH, BVT, SNU, BVND, STUDNT
      DOUBLE PRECISION GMPH, GMPK, XNKH, XNHK, QHRK, HKN, HPK, HKRN
      DOUBLE PRECISION BTNCKH, BTNCHK, BTPDKH, BTPDHK, ONE, EPS
      PARAMETER ( ONE = 1, EPS = 1D-15 )
      IF ( NU .LT. 1 ) THEN
         BVTL = BVND( -DH, -DK, R )
      ELSE IF ( 1 - R .LE. EPS ) THEN
            BVTL = STUDNT( NU, MIN( DH, DK ) )
      ELSE IF ( R + 1  .LE. EPS ) THEN
         IF ( DH .GT. -DK )  THEN
            BVTL = STUDNT( NU, DH ) - STUDNT( NU, -DK )
         ELSE
            BVTL = 0
         END IF
      ELSE
         PI = ACOS(-ONE)
         TPI = 2*PI
         SNU = NU
         SNU = SQRT(SNU)
         ORS = 1 - R*R
         HRK = DH - R*DK
         KRH = DK - R*DH
         IF ( ABS(HRK) + ORS .GT. 0 ) THEN
            XNHK = HRK**2/( HRK**2 + ORS*( NU + DK**2 ) )
            XNKH = KRH**2/( KRH**2 + ORS*( NU + DH**2 ) )
         ELSE
            XNHK = 0
            XNKH = 0
         END IF
         HS = SIGN( ONE, DH - R*DK )
         KS = SIGN( ONE, DK - R*DH )
         IF ( MOD( NU, 2 ) .EQ. 0 ) THEN
            BVT = ATAN2( SQRT(ORS), -R )/TPI
            GMPH = DH/SQRT( 16*( NU + DH**2 ) )
            GMPK = DK/SQRT( 16*( NU + DK**2 ) )
            BTNCKH = 2*ATAN2( SQRT( XNKH ), SQRT( 1 - XNKH ) )/PI
            BTPDKH = 2*SQRT( XNKH*( 1 - XNKH ) )/PI
            BTNCHK = 2*ATAN2( SQRT( XNHK ), SQRT( 1 - XNHK ) )/PI
            BTPDHK = 2*SQRT( XNHK*( 1 - XNHK ) )/PI
            DO J = 1, NU/2
               BVT = BVT + GMPH*( 1 + KS*BTNCKH )
               BVT = BVT + GMPK*( 1 + HS*BTNCHK )
               BTNCKH = BTNCKH + BTPDKH
               BTPDKH = 2*J*BTPDKH*( 1 - XNKH )/( 2*J + 1 )
               BTNCHK = BTNCHK + BTPDHK
               BTPDHK = 2*J*BTPDHK*( 1 - XNHK )/( 2*J + 1 )
               GMPH = GMPH*( 2*J - 1 )/( 2*J*( 1 + DH**2/NU ) )
               GMPK = GMPK*( 2*J - 1 )/( 2*J*( 1 + DK**2/NU ) )
            END DO
         ELSE
            QHRK = SQRT( DH**2 + DK**2 - 2*R*DH*DK + NU*ORS )
            HKRN = DH*DK + R*NU
            HKN = DH*DK - NU
            HPK = DH + DK
            BVT = ATAN2( -SNU*( HKN*QHRK + HPK*HKRN ),
     &                          HKN*HKRN-NU*HPK*QHRK )/TPI
            IF ( BVT .LT. -EPS ) BVT = BVT + 1
            GMPH = DH/( TPI*SNU*( 1 + DH**2/NU ) )
            GMPK = DK/( TPI*SNU*( 1 + DK**2/NU ) )
            BTNCKH = SQRT( XNKH )
            BTPDKH = BTNCKH
            BTNCHK = SQRT( XNHK )
            BTPDHK = BTNCHK
            DO J = 1, ( NU - 1 )/2
               BVT = BVT + GMPH*( 1 + KS*BTNCKH )
               BVT = BVT + GMPK*( 1 + HS*BTNCHK )
               BTPDKH = ( 2*J - 1 )*BTPDKH*( 1 - XNKH )/( 2*J )
               BTNCKH = BTNCKH + BTPDKH
               BTPDHK = ( 2*J - 1 )*BTPDHK*( 1 - XNHK )/( 2*J )
               BTNCHK = BTNCHK + BTPDHK
               GMPH = 2*J*GMPH/( ( 2*J + 1 )*( 1 + DH**2/NU ) )
               GMPK = 2*J*GMPK/( ( 2*J + 1 )*( 1 + DK**2/NU ) )
            END DO
         END IF
         BVTL = BVT
      END IF
*     END BVTL
      END
*
      DOUBLE PRECISION FUNCTION PHID(Z)
*
*     Normal distribution probabilities accurate to 1d-15.
*     Reference: J.L. Schonfelder, Math Comp 32(1978), pp 1232-1240.
*
      INTEGER I, IM
      DOUBLE PRECISION A(0:43), BM, B, BP, P, RTWO, T, XA, Z
      PARAMETER( RTWO = 1.414213562373095048801688724209D0, IM = 24 )
      SAVE A
      DATA ( A(I), I = 0, 43 )/
     &    6.10143081923200417926465815756D-1,
     &   -4.34841272712577471828182820888D-1,
     &    1.76351193643605501125840298123D-1,
     &   -6.0710795609249414860051215825D-2,
     &    1.7712068995694114486147141191D-2,
     &   -4.321119385567293818599864968D-3,
     &    8.54216676887098678819832055D-4,
     &   -1.27155090609162742628893940D-4,
     &    1.1248167243671189468847072D-5, 3.13063885421820972630152D-7,
     &   -2.70988068537762022009086D-7, 3.0737622701407688440959D-8,
     &    2.515620384817622937314D-9, -1.028929921320319127590D-9,
     &    2.9944052119949939363D-11, 2.6051789687266936290D-11,
     &   -2.634839924171969386D-12, -6.43404509890636443D-13,
     &    1.12457401801663447D-13, 1.7281533389986098D-14,
     &   -4.264101694942375D-15, -5.45371977880191D-16,
     &    1.58697607761671D-16, 2.0899837844334D-17,
     &   -5.900526869409D-18, -9.41893387554D-19, 2.14977356470D-19,
     &    4.6660985008D-20, -7.243011862D-21, -2.387966824D-21,
     &    1.91177535D-22, 1.20482568D-22, -6.72377D-25, -5.747997D-24,
     &   -4.28493D-25, 2.44856D-25, 4.3793D-26, -8.151D-27, -3.089D-27,
     &    9.3D-29, 1.74D-28, 1.6D-29, -8.0D-30, -2.0D-30 /
*
      XA = ABS(Z)/RTWO
      IF ( XA .GT. 100 ) THEN
         P = 0
      ELSE
         T = ( 8*XA - 30 ) / ( 4*XA + 15 )
         BM = 0
         B  = 0
         DO I = IM, 0, -1
            BP = B
            B  = BM
            BM = T*B - BP  + A(I)
         END DO
         P = EXP( -XA*XA )*( BM - BP )/4
      END IF
      IF ( Z .GT. 0 ) P = 1 - P
      PHID = P
      END
*
      DOUBLE PRECISION FUNCTION BVND( DH, DK, R )
*
*     A function for computing bivariate normal probabilities.
*
*       Alan Genz
*       Department of Mathematics
*       Washington State University
*       Pullman, WA 99164-3113
*       Email : alangenz@wsu.edu
*
*    This function is based on the method described by
*        Drezner, Z and G.O. Wesolowsky, (1989),
*        On the computation of the bivariate normal integral,
*        Journal of Statist. Comput. Simul. 35, pp. 101-107,
*    with major modifications for double precision, and for |R| close to 1.
*
* BVND calculates the probability that X > DH and Y > DK.
*      Note: Prob( X < DH, Y < DK ) = BVND( -DH, -DK, R ).
*
* Parameters
*
*   DH  DOUBLE PRECISION, integration limit
*   DK  DOUBLE PRECISION, integration limit
*   R   DOUBLE PRECISION, correlation coefficient
*
      DOUBLE PRECISION DH, DK, R, TWOPI
      INTEGER I, IS, LG, NG
      PARAMETER ( TWOPI = 6.283185307179586D0 )
      DOUBLE PRECISION X(10,3), W(10,3), AS, A, B, C, D, RS, XS, BVN
      DOUBLE PRECISION PHID, SN, ASR, H, K, BS, HS, HK
*     Gauss Legendre Points and Weights, N =  6
      DATA ( W(I,1), X(I,1), I = 1,3) /
     &  0.1713244923791705D+00,-0.9324695142031522D+00,
     &  0.3607615730481384D+00,-0.6612093864662647D+00,
     &  0.4679139345726904D+00,-0.2386191860831970D+00/
*     Gauss Legendre Points and Weights, N = 12
      DATA ( W(I,2), X(I,2), I = 1,6) /
     &  0.4717533638651177D-01,-0.9815606342467191D+00,
     &  0.1069393259953183D+00,-0.9041172563704750D+00,
     &  0.1600783285433464D+00,-0.7699026741943050D+00,
     &  0.2031674267230659D+00,-0.5873179542866171D+00,
     &  0.2334925365383547D+00,-0.3678314989981802D+00,
     &  0.2491470458134029D+00,-0.1252334085114692D+00/
*     Gauss Legendre Points and Weights, N = 20
      DATA ( W(I,3), X(I,3), I = 1, 10 ) /
     &  0.1761400713915212D-01,-0.9931285991850949D+00,
     &  0.4060142980038694D-01,-0.9639719272779138D+00,
     &  0.6267204833410906D-01,-0.9122344282513259D+00,
     &  0.8327674157670475D-01,-0.8391169718222188D+00,
     &  0.1019301198172404D+00,-0.7463319064601508D+00,
     &  0.1181945319615184D+00,-0.6360536807265150D+00,
     &  0.1316886384491766D+00,-0.5108670019508271D+00,
     &  0.1420961093183821D+00,-0.3737060887154196D+00,
     &  0.1491729864726037D+00,-0.2277858511416451D+00,
     &  0.1527533871307259D+00,-0.7652652113349733D-01/
      SAVE X, W
      IF ( ABS(R) .LT. 0.3 ) THEN
         NG = 1
         LG = 3
      ELSE IF ( ABS(R) .LT. 0.75 ) THEN
         NG = 2
         LG = 6
      ELSE
         NG = 3
         LG = 10
      ENDIF
      H = DH
      K = DK
      HK = H*K
      BVN = 0
      IF ( ABS(R) .LT. 0.925 ) THEN
         IF ( ABS(R) .GT. 0 ) THEN
            HS = ( H*H + K*K )/2
            ASR = ASIN(R)
            DO I = 1, LG
               DO IS = -1, 1, 2
                  SN = SIN( ASR*(  IS*X(I,NG) + 1 )/2 )
                  BVN = BVN + W(I,NG)*EXP( ( SN*HK-HS )/( 1-SN*SN ) )
               END DO
            END DO
            BVN = BVN*ASR/( 2*TWOPI )
         ENDIF
         BVN = BVN + PHID(-H)*PHID(-K)
      ELSE
         IF ( R .LT. 0 ) THEN
            K = -K
            HK = -HK
         ENDIF
         IF ( ABS(R) .LT. 1 ) THEN
            AS = ( 1 - R )*( 1 + R )
            A = SQRT(AS)
            BS = ( H - K )**2
            C = ( 4 - HK )/8
            D = ( 12 - HK )/16
            ASR = -( BS/AS + HK )/2
            IF ( ASR .GT. -100 ) BVN = A*EXP(ASR)
     &             *( 1 - C*( BS - AS )*( 1 - D*BS/5 )/3 + C*D*AS*AS/5 )
            IF ( -HK .LT. 100 ) THEN
               B = SQRT(BS)
               BVN = BVN - EXP( -HK/2 )*SQRT(TWOPI)*PHID(-B/A)*B
     &                    *( 1 - C*BS*( 1 - D*BS/5 )/3 )
            ENDIF
            A = A/2
            DO I = 1, LG
               DO IS = -1, 1, 2
                  XS = ( A*(  IS*X(I,NG) + 1 ) )**2
                  RS = SQRT( 1 - XS )
                  ASR = -( BS/XS + HK )/2
                  IF ( ASR .GT. -100 ) THEN
                     BVN = BVN + A*W(I,NG)*EXP( ASR )
     &                    *( EXP( -HK*XS/( 2*( 1 + RS )**2 ) )/RS
     &                    - ( 1 + C*XS*( 1 + D*XS ) ) )
                  END IF
               END DO
            END DO
            BVN = -BVN/TWOPI
         ENDIF
         IF ( R .GT. 0 ) THEN
            BVN =  BVN + PHID( -MAX( H, K ) )
         ELSE
            BVN = -BVN
            IF ( K .GT. H ) THEN
               IF ( H .LT. 0 ) THEN
                  BVN = BVN + PHID(K)  - PHID(H)
               ELSE
                  BVN = BVN + PHID(-H) - PHID(-K)
               ENDIF
            ENDIF
         ENDIF
      ENDIF
      BVND = BVN
      END


      SUBROUTINE UV(DIVSC,ZETASC,UCOS,VCOS)
C
C THIS SUBROUTINE OBTAINS CAPITAL U AND V MOMENTUM COMPONENTS FROM THE
C VORTICITY AND DIVERGENCE SPECTRAL COEFFICIENTS
C THE SUBROUTINE MAKES EXTENSIVE USE OF INFORMATION
C CONTAINED IN COMMON BLOCKS (POLYNOMIALS, COEFFICIENTS, ETC.)
C
C CALLED BY: COMP1
C CALLS: FFT991
C
C REVISIONS:
C 7-10-92 CHANGE TO CCM CODING CONVENTIONS (R. JAKOB)
C
C---- Model Parameters -------------------------------------------------
C
      INCLUDE 'params.i'
C
C---- Common Blocks ----------------------------------------------------
C
C TRANSFORM ARRAYS
      INCLUDE 'trnsfm.i'
C WORKSPACE
      INCLUDE 'wrkspc.i'
C
C------------ Arguments ------------------------------------------------
C
C     Input
C
C DIVERGENCE SPECTRAL COEFFICIENTS
      COMPLEX DIVSC(NALP)
C VORTICITY SPECTRAL COEFFICIENTS
      COMPLEX ZETASC(NALP)
C
C     Output
C
C COMPUTED EASTWARD WIND FIELD
      REAL UCOS(NLON+2,NLAT)
C COMPUTED NORTHWARD WIND FIELD
      REAL VCOS(NLON+2,NLAT)
C
C------ Local Variables ------------------------------------------------
C
C     EQUIVALENCE TO WORKSPACE STORAGE POOL /WRKSPC/
C
      COMPLEX CMAT1(NALP), CMAT2(NALP), CMAT3(NALP), CMAT4(NALP)
      EQUIVALENCE (CMAT1(1),RMAT1(1)), (CMAT2(1),RMAT2(1)),
     $            (CMAT3(1),RMAT3(1)), (CMAT4(1),RMAT4(1))
      COMPLEX UTMP1(NLAT/2,NFC), UTMP2(NLAT/2,NFC),
     $        VTMP1(NLAT/2,NFC), VTMP2(NLAT/2,NFC)
      EQUIVALENCE (UTMP1(1,1),WS1(1,1)), (UTMP2(1,1),WS1(1,NLAT/2+1)),
     $            (VTMP1(1,1),WS2(1,1)), (VTMP2(1,1),WS2(1,NLAT/2+1))
C
C     TEMPORARIES
C
      INTEGER M,N,JM,JN,NL,IS,INDEX,SL
C
C----- Executable Statements -------------------------------------------
C
C     COMPUTE U AND V MOMENTUM COMPONENTS FROM VORTICITY AND DIVERGENCE
C
C
C     COMPUTE INTERMEDIATE QUANTITIES FOR COMPUTATIONAL EFFICIENCY
C     INCLUDE CORIOLIS TERM HERE
C
      DO 230 JN=0,NN
         IS = LDIAG(JN,2)
C
         DO 220 JM=1,LDIAG(JN,1)
            M = JM-1
            N = M + JN
C
C           COEFFICIENT N=0 UNDEFINED
C
            IF (N .GT. 0) THEN
               CMAT1(IS+JM)  = CMPLX(0.0,ANNP1(N)*REAL(M)) *
     $               DIVSC(IS+JM)
               CMAT2(IS+JM)  = ANNP1(N)*ZETASC(IS+JM)
               CMAT3(IS+JM)  = CMPLX(0.0,ANNP1(N)*REAL(M)) *
     $               ZETASC(IS+JM)
               CMAT4(IS+JM)  = ANNP1(N)*DIVSC(IS+JM)
             ENDIF
  220    CONTINUE
  230 CONTINUE
C
C     ADD CORIOLIS TERM FOR ROTATED COORDINATES
C
C     WAVE M=0, N=1
      INDEX = LDIAG(1,2)+1
      CMAT2(INDEX) = CMAT2(INDEX)-CMPLX(ANNP1(1)*CORSC1,0.0)
C     WAVE M=1, N=1
      INDEX = LDIAG(0,2)+2
      CMAT2(INDEX) = CMAT2(INDEX)-CMPLX(ANNP1(1)*CORSC2,0.0)
      CMAT3(INDEX) = CMAT3(INDEX)-CMPLX(0.0,ANNP1(1)*CORSC2)
C
C     EVEN DIAGONALS FIRST
C
      DO 280 JN=0,NN,2
         IS = LDIAG(JN,2)
C
C     THIS DETOUR ELIMINATES NEED TO EXPLICITLY ZERO UTMP1, UTMP2, ETC.
C
         IF (JN .EQ. 0) THEN
C
C           SPECIAL HANDLING M=N=0
C
            DO 245 NL=1,NLAT/2
               UTMP1(NL,1) = CMPLX(0.0,0.0)
               UTMP2(NL,1) = CMPLX(0.0,0.0)
               VTMP1(NL,1) = CMPLX(0.0,0.0)
               VTMP2(NL,1) = CMPLX(0.0,0.0)
  245       CONTINUE
            DO 250 JM=2,MM+1
               DO 240 NL=1,NLAT/2
                  UTMP1(NL,JM) = - CMAT1(JM)*ALP(JM,NL)
                  UTMP2(NL,JM) =   CMAT2(JM)*DALP(JM,NL)
                  VTMP1(NL,JM) = - CMAT3(JM)*ALP(JM,NL)
                  VTMP2(NL,JM) = - CMAT4(JM)*DALP(JM,NL)
  240          CONTINUE
  250       CONTINUE
         ELSE
C
C           ALL OTHER EVEN DIAGONALS
C
            DO 270 JM=1,LDIAG(JN,1)
               DO 260 NL=1,NLAT/2
                  UTMP1(NL,JM) = UTMP1(NL,JM)
     $                           - CMAT1(IS+JM)*ALP(IS+JM,NL)
                  UTMP2(NL,JM) = UTMP2(NL,JM)
     $                           + CMAT2(IS+JM)*DALP(IS+JM,NL)
                  VTMP1(NL,JM) = VTMP1(NL,JM)
     $                           - CMAT3(IS+JM)*ALP(IS+JM,NL)
                  VTMP2(NL,JM) = VTMP2(NL,JM)
     $                           - CMAT4(IS+JM)*DALP(IS+JM,NL)
  260          CONTINUE
  270       CONTINUE
         ENDIF
  280 CONTINUE
C
C     ODD DIAGONALS NEXT
C
      DO 310 JN=1,NN,2
         IS = LDIAG(JN,2)
         DO 300 JM=1,LDIAG(JN,1)
            DO 290 NL=1,NLAT/2
               UTMP2(NL,JM) = UTMP2(NL,JM) - CMAT1(IS+JM)*ALP(IS+JM,NL)
               UTMP1(NL,JM) = UTMP1(NL,JM) + CMAT2(IS+JM)*DALP(IS+JM,NL)
               VTMP2(NL,JM) = VTMP2(NL,JM) - CMAT3(IS+JM)*ALP(IS+JM,NL)
               VTMP1(NL,JM) = VTMP1(NL,JM) - CMAT4(IS+JM)*DALP(IS+JM,NL)
  290       CONTINUE
  300    CONTINUE
  310 CONTINUE
C
C        COMBINE CONTRIBUTIONS OF EVEN AND ODD WAVENUMBERS TO OBTAIN
C        FOURIER COEFFICIENTS
C
         DO 330 JM=1,MM+1
            DO 320 NL=1,NLAT/2
               SL = NLAT-NL+1
C              UCOSFC(JM  ,NL)   = UTMP1(NL,JM) + UTMP2(NL,JM)
               UCOS(2*JM-1,NL)   = REAL(UTMP1(NL,JM) + UTMP2(NL,JM))
               UCOS(2*JM  ,NL)   =AIMAG(UTMP1(NL,JM) + UTMP2(NL,JM))
C              UCOSFC(JM  ,NLAT-NL+1) = UTMP1(NL,JM) - UTMP2(NL,JM)
               UCOS(2*JM-1,SL)   = REAL(UTMP1(NL,JM) - UTMP2(NL,JM))
               UCOS(2*JM  ,SL)   =AIMAG(UTMP1(NL,JM) - UTMP2(NL,JM))
C              VCOSFC(JM,NL)     = VTMP1(NL,JM) + VTMP2(NL,JM)
               VCOS(2*JM-1,NL)   = REAL(VTMP1(NL,JM) + VTMP2(NL,JM))
               VCOS(2*JM  ,NL)   =AIMAG(VTMP1(NL,JM) + VTMP2(NL,JM))
C              VCOSFC(JM,NLAT-NL+1)   = VTMP1(NL,JM) - VTMP2(NL,JM)
               VCOS(2*JM-1,SL)   = REAL(VTMP1(NL,JM) - VTMP2(NL,JM))
               VCOS(2*JM  ,SL)   =AIMAG(VTMP1(NL,JM) - VTMP2(NL,JM))
  320       CONTINUE
  330    CONTINUE
C
         DO 350 JM=MM+2,NFC
            DO 340 NL=1,NLAT
C              UCOSFC(JM,NL)   = (0.0,0.0)
               UCOS(2*JM-1,NL) = 0.0
               UCOS(2*JM  ,NL) = 0.0
C              VCOSFC(JM,NL)   = (0.0,0.0)
               VCOS(2*JM-1,NL) = 0.0
               VCOS(2*JM  ,NL) = 0.0
  340       CONTINUE
  350    CONTINUE
C
C
C     CALL FFT ROUTINE FOR INVERSE TRANSFORM OF UCOS AND VCOS
C
      CALL FFT991(UCOS,FFTWS2,TRIGS,IFAX,1,NLON+2,NLON,NLAT,+1)
      CALL FFT991(VCOS,FFTWS2,TRIGS,IFAX,1,NLON+2,NLON,NLAT,+1)
C
      RETURN
C
      END


c-----------------------------------------------------------------------
      subroutine gfdm_pres_solv(z,r,ug,wg,kwave2) ! (A - kwave2*B)z = r

      include 'SIZE'
      include 'INPUT'
      include 'PARALLEL'
      include 'TSTEP'
      include 'ZPER'

      real z (lx2*ly2*lz2*lelv),r (lx2*ly2*lz2*lelv)
      real ug(lx2*ly2*lz2*lelv),wg(lx2*ly2*lz2*lelv)
      real kwave2

      mfld = 1
      if (ifmhd.and.ifield.gt.1) mfld = 2

c     Set up diagonal for solver

      ii= 1          ! we'll need to change this for multiple flds
      l = ngfdm_p(1)
      m = ngfdm_p(2)
      n = ngfdm_p(3)
      i = mlp(1,mfld)
      j = mlp(2,mfld)
      k = mlp(3,mfld)
      call gfdm_set_diagp(wavep(ii),tpn1,mcex
     $         ,eigp(i),l,eigp(j),m,eigp(k),n,kwave2)

      mp   = ngfdm_p(pst2lex(1))
      ms   = ngfdm_p(pst2lex(2))
      mt   = ngfdm_p(pst2lex(3))

      msfp = msp(pst2lex(1),mfld)
      msfs = msp(pst2lex(2),mfld)
      msft = msp(pst2lex(3),mfld)

      ntot  = nx2*ny2*nz2*nelv

      m     = ntot/mp
      nwave = mcex
      mpt   = mcex/(ms*mt)

      dtbdi = 1
      if (ifemat.and..not.ifmhd) dtbdi=bd(1)/dt ! scale by BDF coefficient/DT

c     write(6,*) 'msfp:',msfp,msfs,msft,mp,ms,mt,sp(msfp)
c     call outmat(sp(msfp),mp,mp,'S  x  ',istep)
c     call outmat(sp(msfs),ms,ms,'S  y  ',ifield)
c     call outmat(sp(msft),mt,mt,'S  z  ',mt)
c     call outmat(wavep   ,mp,ms,'WAVE  ',mt)
c     stop

      if (if3d) then
         call copy    (ug,r,ntot)
         call swap_ip (ug,tpn2,ntot)
         call mxm     (ug,m,sp (msfp),mp,wg,mp)
         call cexr    (ug,wg,m,mp,part_out,part_in,msg_id,wdsize,nid,np)
         call swap_ip (ug,ind23,mcex)
         call mxm     (spt(msfs),ms,ug,ms,wg,mpt*mt)
         call mxm     (wg,ms*mpt,sp (msft),mt,ug,mt)
         call col2s2  (ug,wavep,dtbdi,mcex)
         call mxm     (ug,ms*mpt,spt(msft) ,mt,wg,mt)
         call mxm     (sp (msfs),ms,wg,ms,ug,mpt*mt)
         call swapt_ip(ug,ind23,mcex)
         call cextr   (wg,m,mp,ug,part_out,part_in,msg_id,wdsize,nid,np)
         call mxm     (wg,m,spt(msfp),mp,z,mp)
         call swapt_ip(z,tpn2,ntot)
      else
         call copy    (ug,r,ntot)
         call swap_ip (ug,tpn2,ntot)
         call mxm     (ug,m,sp (msfp),mp,wg,mp)
         call cexr    (ug,wg,m,mp,part_out,part_in,msg_id,wdsize,nid,np)
         call swap_ip (ug,ind23,mcex)
         call mxm     (spt(msfs),ms,ug,ms,wg,mpt)
         call col2s2  (wg,wavep,dtbdi,mcex)
         call mxm     (sp (msfs),ms,wg,ms,ug,mpt)
         call swapt_ip(ug,ind23,mcex)
         call cextr   (wg,m,mp,ug,part_out,part_in,msg_id,wdsize,nid,np)
         call mxm     (wg,m,spt(msfp),mp,z,mp)
         call swapt_ip(z,tpn2,ntot)
      endif

      return
      end
c-----------------------------------------------------------------------


C    Copyright(C) 1999-2020 National Technology & Engineering Solutions
C    of Sandia, LLC (NTESS).  Under the terms of Contract DE-NA0003525 with
C    NTESS, the U.S. Government retains certain rights in this software.
C
C    See packages/seacas/LICENSE for details

      SUBROUTINE ARCPAR (MP, KT, KNUM, COOR, LINKP, IPNTR1, IPNTR2,
     &   IPNTR3, IP3, XCEN, YCEN, THETA1, THETA2, TANG, R1, R2, ERR,
     &   ICCW, ICW, XK, XA)
C***********************************************************************

C  SUBROUTINE ARCPAR = THIS ROUTINE CALCULATES THE ARC PARAMETERS

C***********************************************************************

C  VARIABLES USED:
C     TANG   = TOTAL ANGLE SCRIBED BY THE ARC
C     THETA1 = FIRST CCW ANGLE OF THE ARC
C     THETA2 = SECOND CCW ANGLE OF THE ARC
C     IPNTR1 = POINTER TO FIRST COORDINATE VALUE
C     IPNTR2 = POINTER TO SECOND COORDINATE VALUE
C     IPNTR3 = POINTER TO THIRD COORDINATE VALUE
C     IP3    = THE THIRD POINT NUMBER (CAN BE NEGATED)

C***********************************************************************

      DIMENSION COOR (2, MP), LINKP (2, MP)

      LOGICAL ERR

      PI = ATAN2(0.0, -1.0)
      TWOPI = PI + PI
      ERR = .FALSE.

C  ARC WITH CENTER GIVEN
C  ARC GOES FROM 1ST POINT TO 2ND IN *COUNTER-CLOCKWISE* DIRECTION.

      IF (KT .EQ. 3) THEN
         XCEN = COOR (1, IPNTR3)
         YCEN = COOR (2, IPNTR3)

C  CIRCLE WITH THIRD POINT ON ARC

      ELSEIF (KT .EQ. 4) THEN
         THETA1 = ATAN2 (COOR (2, IPNTR3) - COOR (2, IPNTR1),
     &      COOR (1, IPNTR3) - COOR (1, IPNTR1)) + PI / 2.0
         THETA2 = ATAN2 (COOR (2, IPNTR3) - COOR (2, IPNTR2),
     &      COOR (1, IPNTR3) - COOR (1, IPNTR2)) + PI / 2.0
         DET = - COS (THETA1) * SIN (THETA2) +
     &      COS (THETA2) * SIN (THETA1)
         X11 = 0.5 * (COOR (1, IPNTR1) + COOR (1, IPNTR3))
         Y11 = 0.5 * (COOR (2, IPNTR1) + COOR (2, IPNTR3))
         X21 = 0.5 * (COOR (1, IPNTR2) + COOR (1, IPNTR3))
         Y21 = 0.5 * (COOR (2, IPNTR2) + COOR (2, IPNTR3))
         R =  ( - SIN (THETA2) * (X21 - X11) +
     &      COS (THETA2) * (Y21 - Y11)) / DET
         XCEN = X11 + R * COS (THETA1)
         YCEN = Y11 + R * SIN (THETA1)

C     CIRCLE WITH RADIUS GIVEN

      ELSEIF (KT .EQ. 6) THEN
         DX = 0.5 * (COOR (1, IPNTR2) - COOR (1, IPNTR1))
         DY = 0.5 * (COOR (2, IPNTR2) - COOR (2, IPNTR1))
         CHORD = SQRT (DX * DX + DY * DY)
         R = ABS (COOR (1, IPNTR3))
         IF (R .LE. CHORD) THEN
            XCEN = 0.5 * (COOR (1, IPNTR1) + COOR (1, IPNTR2))
            YCEN = 0.5 * (COOR (2, IPNTR1) + COOR (2, IPNTR2))
         ELSE
            ARM = SQRT (R * R - CHORD * CHORD)
            IF (IP3.LT.0) THEN
               XCEN = COOR (1, IPNTR1) + DX + ARM * DY / CHORD
               YCEN = COOR (2, IPNTR1) + DY - ARM * DX / CHORD
            ELSE
               XCEN = COOR (1, IPNTR1) + DX - ARM * DY / CHORD
               YCEN = COOR (2, IPNTR1) + DY + ARM * DX / CHORD
            ENDIF
         ENDIF
      ENDIF

C  CHECK TO MAKE SURE THAT THE BEGINNING AND ENDING RADIUS EXIST

      IF ((( COOR (1, IPNTR1) .EQ. XCEN) .AND.
     &   (COOR (2, IPNTR1) .EQ. YCEN)) .OR.
     &   ((COOR (1, IPNTR2) .EQ. XCEN) .AND.
     &   (COOR (2, IPNTR2) .EQ. YCEN))) THEN
         CALL PLTFLU
         WRITE (*, 10000) ABS (KNUM)
         ERR = .TRUE.
         GOTO 100
      ENDIF
      R1 = SQRT ( (COOR (1, IPNTR1) - XCEN) **2 +  (COOR (2, IPNTR1) -
     &   YCEN) **2)
      R2 = SQRT ( (COOR (1, IPNTR2) - XCEN) **2 +  (COOR (2, IPNTR2) -
     &   YCEN) **2)
      THETA1 = ATAN2 (COOR (2, IPNTR1) - YCEN, COOR (1, IPNTR1) - XCEN)
      THETA2 = ATAN2 (COOR (2, IPNTR2) - YCEN, COOR (1, IPNTR2) - XCEN)

C  ARC WITH THE CENTER GIVEN

      IF (KT .EQ. 3) THEN
         IF  (IPNTR1 .EQ. IPNTR2) THEN
            THETA2  =  THETA1  +  TWOPI
         ELSEIF ((IP3 .GE. 0) .AND. (THETA2 .LE. THETA1)) THEN
            THETA2 = THETA2 + TWOPI
         ELSEIF ((IP3 .LT. 0) .AND. (THETA1 .LE. THETA2)) THEN
            THETA1 = THETA1 + TWOPI
         ENDIF
         TANG = THETA2 - THETA1
         IF (IP3 .LT. 0) THEN
            ICCW = IPNTR2
            ICW = IPNTR1
         ELSE
            ICCW = IPNTR1
            ICW = IPNTR2
         ENDIF

C  CIRCULAR ARC WITH 3RD POINT ON ARC - CLOCKWISE OR COUNTER-CLOCKWISE

      ELSEIF (KT .EQ. 4) THEN
         THETA3 = ATAN2 (COOR (2, IPNTR3) - YCEN, COOR (1, IPNTR3) -
     &      XCEN)
         IF (THETA2 .LE. THETA1) THETA2 = THETA2 + TWOPI
         IF (THETA3 .LE. THETA1) THETA3 = THETA3 + TWOPI
         TANG = THETA2 - THETA1
         IF (THETA3 .GT. THETA2) THEN
            TANG = - (TWOPI - TANG)
            ICCW = IPNTR2
            ICW = IPNTR1
         ELSE
            ICCW = IPNTR1
            ICW = IPNTR2
         ENDIF

C     CIRRCULAR ARC WITH RADIUS GIVEN - CLOCKWISE OR COUNTER-CLOCKWISE

      ELSEIF (KT .EQ. 6) THEN
         IF ( (IP3 .GE. 0) .AND. (THETA2 .LE. THETA1))
     &      THETA2 = THETA2 + TWOPI
         IF ( (IP3 .LT. 0) .AND. (THETA1 .LE. THETA2))
     &      THETA1 = THETA1 + TWOPI
         TANG = THETA2 - THETA1
         IF (IP3 .GE. 0) THEN
            ICCW = IPNTR1
            ICW = IPNTR2
         ELSE
            ICCW = IPNTR2
            ICW = IPNTR1
         ENDIF
      ENDIF

C  DEFINE THE SPIRAL PARAMETERS  (R = XA * EXP  (XK * THETA))

      XK = (LOG (R2 / R1)) / (THETA2 - THETA1)
      DIVID = EXP (XK * THETA2)
      IF (DIVID .GT. 0.) THEN
         XA = R2 / DIVID
      ELSE
         WRITE (*, 10010) IABS (KNUM)
         ERR = .TRUE.
         GOTO 100
      ENDIF

  100 CONTINUE

      RETURN

10000 FORMAT (' CENTER POINT FOR LINE', I5, ' LIES ON ONE OF',
     &   ' THE ENDPOINTS')
10010 FORMAT (' DEFINITION FOR ARC LINE', I5, ' IS INVLAID')

      END


      integer i,j,k
      real lat,lon,c1,c30,org1,org30,cl30,sa30,si30,bulk30
      real cl1,sa1,si1,bulk1,map(6,60,60),lat0,lon0

      lat0 = 50.0833
      lon0 = -7.0833

      do i=1,60
        do j=1,60
          do k=1,6
            map(k,i,j) = -999
          enddo
          map(3,i,j)= 0.0
          map(6,i,j)= 0.0
        enddo
      enddo

      open(11,file='UKcarbtext_sdgvm10min.txt',status='old')
      open(21,file='../30cm/data.txt')
      open(22,file='../1m/data.txt')
      read(11,*)
      do i=1,1061
        read(11,*) lat,lon,c1,c30,org1,org30,cl30,sa30,si30,
     &bulk30,cl1,sa1,si1,bulk1
        if (sa30.LT.200) then
        ind1 = int((lat - lat0)*6.0 + .5)+1
        ind2 = int((lon - lon0)*6.0 + .5)+1
        map(1,ind1,ind2) = sa30/(sa30+si30+cl30)*100.0
        map(2,ind1,ind2) = si30/(sa30+si30+cl30)*100.0
        map(3,ind1,ind2) = bulk30
        map(4,ind1,ind2) = sa1/(sa1+si1+cl1)*100.0
        map(5,ind1,ind2) = si1/(sa1+si1+cl1)*100.0
        map(6,ind1,ind2) = bulk1
        if ((ind1.gt.60).or.(ind1.lt.1).or.(ind2.gt.60).or.
     &(ind2.lt.1)) stop
        endif
      enddo

      do i=1,60
        do j=1,60
          write(21,'(f7.3,f9.3,4f12.3)') real(60-i)/6.0+lat0,
     &real(j-1)/6.0+lon0,(map(k,61-i,j),k=1,3),0.0
          write(22,'(f7.3,f9.3,4f12.3)') real(60-i)/6.0+lat0,
     &real(j-1)/6.0+lon0,(map(k,61-i,j),k=4,6),0.0
        enddo
      enddo

      stop
      end


!
!     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.
!
      subroutine labyrinth(node1,node2,nodem,nelem,lakon,
     &     nactdog,identity,ielprop,prop,iflag,v,xflow,f,
     &     nodef,idirf,df,cp,R,physcon,co,dvi,numf,vold,set,
     &     kon,ipkon,mi,iaxial)
!
!     labyrinth element
!
!     author: Yannick Muller
!
      implicit none
!
      logical identity
      character*8 lakon(*)
      character*81 set(*)
!
      integer nelem,nactdog(0:3,*),node1,node2,nodem,numf,
     &     ielprop(*),nodef(4),idirf(4),index,iflag,mi(*),
     &     inv,kgas,n,iaxial,nodea,nodeb,ipkon(*),kon(*),i,itype
!
      real*8 prop(*),v(0:mi(2),*),xflow,f,df(4),kappa,R,a,d,
     &     p1,p2,T1,Aeff,C1,C2,C3,cd,cp,physcon(3),p2p1,km1,dvi,
     &     kp1,kdkm1,tdkp1,km1dk,x,y,ca1,cb1,ca2,cb2,dT1,alambda,
     &     rad,reynolds,pi,ppkrit,co(3,*),
     &     carry_over,lc,hst,e,szt,num,denom,t,s,b,h,cdu,
     &     cd_radius,cst,dh,cd_honeycomb,cd_lab,bdh,
     &     pt0zps1,cd_1spike,cdbragg,rzdh,
     &     cd_correction,p1p2,xflow_oil,T2,vold(0:mi(2),*)
!
      itype=1
      pi=4.d0*datan(1.d0)
      e=2.718281828459045d0
!
      if (iflag.eq.0) then
         identity=.true.
!
         if(nactdog(2,node1).ne.0)then
            identity=.false.
         elseif(nactdog(2,node2).ne.0)then
            identity=.false.
         elseif(nactdog(1,nodem).ne.0)then
            identity=.false.
         endif
!
      elseif (iflag.eq.1)then
!
          index=ielprop(nelem)
          kappa=(cp/(cp-R))
!
!     Usual Labyrinth
!
          if(lakon(nelem)(2:5).ne.'LABF') then
             t=prop(index+1)
             s=prop(index+2)
c             iaxial=int(prop(index+3))
             d=prop(index+4)
             n=int(prop(index+5))
             b=prop(index+6)
             h=prop(index+7)
             lc=prop(index+8)
             rad=prop(index+9)
             X=prop(index+10)
             Hst=prop(index+11)
!
             A=pi*D*s
!
!    "flexible" labyrinth for thermomechanical coupling
!
          elseif(lakon(nelem)(2:5).eq.'LABF') then
             nodea=int(prop(index+1))
             nodeb=int(prop(index+2))
c             iaxial=int(prop(index+3))
             t=prop(index+4)
             d=prop(index+5)
             n=int(prop(index+6))
             b=prop(index+7)
             h=prop(index+8)
!     hc=prop(index+7)
             lc=prop(index+9)
             rad=prop(index+10)
             X=prop(index+11)
             Hst=prop(index+12)

!
!     gap definition
             s=dsqrt((co(1,nodeb)+vold(1,nodeb)-
     &            co(1,nodea)-vold(1,nodea))**2)
c             if(iaxial.ne.0) then
c                a=pi*d*s/iaxial
c             else
                a=pi*d*s
c             endif
          endif
!
         p1=v(2,node1)
         p2=v(2,node2)
         if(p1.ge.p2) then
            inv=1
            T1=v(0,node1)+physcon(1)
         else
            inv=-1
            p1=v(2,node2)
            p2=v(2,node1)
            T1=v(0,node2)+physcon(1)
         endif
!
         cd=1.d0
         Aeff=A*cd
         p2p1=p2/p1
!
!************************
!     one fin
!*************************
         if(n.eq.1.d0) then
!
            km1=kappa-1.d0
            kp1=kappa+1.d0
            kdkm1=kappa/km1
            tdkp1=2.d0/kp1
            C2=tdkp1**kdkm1
!
!     subcritical
!
            if(p2p1.gt.C2) then
               xflow=inv*p1*Aeff*dsqrt(2.d0*kdkm1*p2p1**(2.d0/kappa)
     &              *(1.d0-p2p1**(1.d0/kdkm1))/r)/dsqrt(T1)
!
!     critical
!
            else
               xflow=inv*p1*Aeff*dsqrt(kappa/r)*tdkp1**(kp1/(2.d0*km1))/
     &              dsqrt(T1)
            endif
         endif
!
!***********************
!     straight labyrinth and stepped labyrinth
!     method found in "Air system Correlations Part1 Labyrinth Seals"
!     H.Zimmermann and K.H. Wolff
!     ASME 98-GT-206
!**********************
!
         if (n.ge.2) then
!
            call lab_straight_ppkrit(n,ppkrit)
!
!     subcritical case
!
            if (p2p1.gt.ppkrit) then
               xflow=inv*p1*Aeff/dsqrt(T1)*dsqrt((1.d0-p2p1**2.d0)
     &              /(R*(n-log(p2p1)/log(e))))
!
!     critical case
!
            else
               xflow=inv*p1*Aeff/dsqrt(T1)*dsqrt(2.d0/R)*ppkrit
            endif
         endif
!
      elseif (iflag.eq.2)then
         numf=4
         alambda=10000.d0
!
         p1=v(2,node1)
         p2=v(2,node2)
         if(p1.ge.p2) then
            inv=1
            xflow=v(1,nodem)*iaxial
            T1=v(0,node1)+physcon(1)
            T2=v(0,node2)+physcon(1)
            nodef(1)=node1
            nodef(2)=node1
            nodef(3)=nodem
            nodef(4)=node2
         else
            inv=-1
            p1=v(2,node2)
            p2=v(2,node1)
            xflow=-v(1,nodem)*iaxial
            T1=v(0,node2)+physcon(1)
            T2=v(0,node1)+physcon(1)
            nodef(1)=node2
            nodef(2)=node2
            nodef(3)=nodem
            nodef(4)=node1
         endif
!
         idirf(1)=2
         idirf(2)=0
         idirf(3)=1
         idirf(4)=2
!
!     Usual labyrinth
!
         if(lakon(nelem)(2:5).ne. 'LABF') then
            index=ielprop(nelem)
            kappa=(cp/(cp-R))
            t=prop(index+1)
            s=prop(index+2)
c            iaxial=int(prop(index+3))
            d=prop(index+4)
            n=int(prop(index+5))
            b=prop(index+6)
            h=prop(index+7)
            lc=prop(index+8)
            rad=prop(index+9)
            X=prop(index+10)
            Hst=prop(index+11)
            A=pi*D*s
!
!     Flexible labyrinth for coupled calculations
!
         elseif(lakon(nelem)(2:5).eq.'LABF') then
            index=ielprop(nelem)
            nodea=int(prop(index+1))
            nodeb=int(prop(index+2))
c            iaxial=int(prop(index+3))
            t=prop(index+4)
            d=prop(index+5)
            n=int(prop(index+6))
            b=prop(index+7)
            h=prop(index+8)
            lc=prop(index+9)
            rad=prop(index+10)
            X=prop(index+11)
            Hst=prop(index+12)
!
!     gap definition
             s=dsqrt((co(1,nodeb)+vold(1,nodeb)-
     &            co(1,nodea)-vold(1,nodea))**2)
c             if(iaxial.ne.0) then
c                a=pi*d*s/iaxial
c             else
                a=pi*d*s
c             endif
          endif
!
         p2p1=p2/p1
         dT1=dsqrt(T1)
!
         Aeff=A
!
!     honeycomb stator correction
!
         cd_honeycomb=1.d0
         if (lc.ne.0.d0)then
            call cd_lab_honeycomb(s,lc,cd_honeycomb)
            cd_honeycomb=1+cd_honeycomb/100
         endif
!
!     inlet radius correction
!
         cd_radius=1.d0
         if((rad.ne.0.d0).and.(n.ne.1d0)) then
            call cd_lab_radius(rad,s,Hst,cd_radius)
         endif
!
!     carry over factor (only for straight throught labyrinth)
!
         if ((n.ge.2).and.(hst.eq.0d0)) then
            cst=n/(n-1.d0)
            szt=s/t
            carry_over=cst/dsqrt(cst-szt/(szt+0.02))
            Aeff=Aeff*carry_over
         endif
!
!     calculation of the dynamic viscosity
!
         if(dabs(dvi).lt.1E-30) then
            kgas=0
            call dynamic_viscosity(kgas,T1,dvi)
         endif
!
!     calculation of the number of reynolds for a gap
!
         reynolds=dabs(xflow)*2.d0*s/(dvi*A*cd_honeycomb/cd_radius)
!
!**************************************
!     single fin labyrinth
!     the resolution procedure is the same as for the restrictor
!**************************************
!
         if(n.eq.1)then
!
!     single fin labyrinth
!
!     incompressible basis cd , reynolds correction,and radius correction
!
!     "Flow Characteristics of long orifices with rotation and corner radiusing"
!     W.F. Mcgreehan and M.J. Schotsch
!     ASME 87-GT-162
!
            dh=2*s
            bdh=b/dh
            rzdh=rad/dh
!
            call cd_Mcgreehan_Schotsch(rzdh,bdh,reynolds,cdu)
!
!     compressibility correction factor
!
!     S.L.Bragg
!     "Effect of conpressibility on the discharge coefficient of orifices and convergent nozzles"
!     Journal of Mechanical engineering vol 2 No 1 1960
!
            call cd_bragg(cdu,p2p1,cdbragg,itype)
            cd=cdbragg
            Aeff=Aeff*cd
!
            km1=kappa-1.d0
            kp1=kappa+1.d0
            kdkm1=kappa/km1
            tdkp1=2.d0/kp1
            C2=tdkp1**kdkm1
!
            if(p2p1.gt.C2) then
               C1=dsqrt(2.d0*kdkm1/r)*Aeff
               km1dk=1.d0/kdkm1
               y=p2p1**km1dk
               x=dsqrt(1.d0-y)
               ca1=-C1*x/(kappa*p1*y)
               cb1=C1*km1dk/(2.d0*p1)
               ca2=-ca1*p2p1-xflow*dT1/(p1*p1)
               cb2=-cb1*p2p1
               f=xflow*dT1/p1-C1*p2p1**(1.d0/kappa)*x
               if(cb2.le.-(alambda+ca2)*x) then
                  df(1)=-alambda
               elseif(cb2.ge.(alambda-ca2)*x) then
                  df(1)=alambda
               else
                  df(1)=ca2+cb2/x
               endif
               df(2)=xflow/(2.d0*p1*dT1)
               df(3)=inv*dT1/p1
               if(cb1.le.-(alambda+ca1)*x) then
                  df(4)=-alambda
               elseif(cb1.ge.(alambda-ca1)*x) then
                  df(4)=alambda
               else
                  df(4)=ca1+cb1/x
               endif
            else
               C3=dsqrt(kappa/r)*(tdkp1)**(kp1/(2.d0*km1))*Aeff
               f=xflow*dT1/p1-C3
               df(1)=-xflow*dT1/(p1)**2
               df(2)=xflow/(2*p1*dT1)
               df(3)=inv*dT1/p1
               df(4)=0.d0
            endif
         endif
!
!****************************************
!     straight labyrinth & stepped labyrinth
!     method found in "Air system Correlations Part1 Labyrinth Seals"
!     H.Zimmermann and K.H. Wolff
!     ASME 98-GT-206
!****************************************
!
         if(n.ge.2) then
            num=(1.d0-p2p1**2)
            denom=R*(n-log(p2p1)/log(e))
!
!     straight labyrinth
!
            if((hst.eq.0.d0).and.(n.ne.1)) then
               call cd_lab_straight(n,p2p1,s,b,reynolds,cd_lab)
               Aeff=Aeff*cd_lab*cd_honeycomb*cd_radius
!
!     Stepped Labyrinth
!
            else
!     corrective term for the first spike
               p1p2=p1/p2
               pt0zps1=(p1p2)**(1/prop(index+4))
               call cd_lab_1spike (pt0zps1,s,b,cd_1spike)
!
!     corrective term for cd_lab_1spike
!
               call cd_lab_correction (p1p2,s,b,cd_correction)
!
!     calculation of the discharge coefficient of the stepped labyrinth
!
               cd=cd_1spike*cd_correction
               cd_lab=cd
!
               Aeff=Aeff*cd_lab*cd_radius*cd_honeycomb
            endif
!
            call lab_straight_ppkrit(n,ppkrit)
!
!     subcritical case
!
            if (p2p1.gt.ppkrit) then
!
               f=xflow*dT1/p1-dsqrt(num/denom)*Aeff
!
               df(1)=xflow*dt1/p1**2.d0-Aeff/2.d0
     &              *dsqrt(denom/num)*(2.d0*(p2**2.d0/p1**3.d0)/denom)
     &              +num/denom**2.d0*r/p1
               df(2)=xflow/(2.d0*p1*dT1)
               df(3)=inv*dT1/p1
               df(4)=-Aeff/2.d0*dsqrt(denom/num)*(-2.d0*(p2/p1**2.d0)
     &              /denom)+num/denom**2.d0*r/p2
!
!     critical case
!
            else
               C2=dsqrt(2/R)*Aeff*ppkrit
!
               f=xflow*dT1/p1-C2
               df(1)=-xflow*dT1/(p1**2)
               df(2)=xflow/(2.d0*p1*dT1)
               df(3)=inv*dT1/p1
               df(4)=0.d0
            endif
         endif
!
!     output
!
      elseif(iflag.eq.3)then
!

         p1=v(2,node1)
         p2=v(2,node2)
         if(p1.ge.p2) then
            inv=1
            xflow=v(1,nodem)*iaxial
            T1=v(0,node1)+physcon(1)
            T2=v(0,node2)+physcon(1)
            nodef(1)=node1
            nodef(2)=node1
            nodef(3)=nodem
            nodef(4)=node2
         else
            inv=-1
            p1=v(2,node2)
            p2=v(2,node1)
            xflow=-v(1,nodem)*iaxial
            T1=v(0,node2)+physcon(1)
            T2=v(0,node2)+physcon(1)
            nodef(1)=node2
            nodef(2)=node2
            nodef(3)=nodem
            nodef(4)=node1
         endif
!
         index=ielprop(nelem)
         kappa=(cp/(cp-R))
         t=prop(index+1)
         s=prop(index+2)
         d=prop(index+3)
         n=int(prop(index+4))
         b=prop(index+5)
         h=prop(index+6)
         lc=prop(index+7)
         rad=prop(index+8)
         X=prop(index+9)
         Hst=prop(index+10)
!
         p2p1=p2/p1
         dT1=dsqrt(T1)
!
         pi=4.d0*datan(1.d0)
         A=pi*D*s
         Aeff=A
         e=2.718281828459045d0
!
!     honeycomb stator correction
!
         if (lc.ne.0.d0)then
            call cd_lab_honeycomb(s,lc,cd_honeycomb)
            Aeff=Aeff*(1.d0+cd_honeycomb/100.d0)
         else
            cd_honeycomb=0
         endif
!
!     inlet radius correction
!
         if((rad.ne.0.d0).and.(n.ne.1d0)) then
            call cd_lab_radius(rad,s,Hst,cd_radius)
            Aeff=Aeff*cd_radius
         else
            cd_radius=1
         endif
!
!     carry over factor (only for straight throught labyrinth)
!
         if((n.gt.1).and.(hst.eq.0d0)) then
            cst=n/(n-1.d0)
            szt=s/t
            carry_over=cst/dsqrt(cst-szt/(szt+0.02))
            Aeff=Aeff*carry_over
         endif
!
!     calculation of the dynamic viscosity
!
         if(dabs(dvi).lt.1E-30) then
            kgas=0
            call dynamic_viscosity(kgas,T1,dvi)
         endif
!
!     calculation of the number of reynolds for a gap
!
         reynolds=dabs(xflow)*2.d0*s/(dvi*A)
!**************************************
!     single fin labyrinth
!     the resolution procedure is the same as for the restrictor
!**************************************
!
         if(n.eq.1)then
!
!     single fin labyrinth
!
!     incompressible basis cd , reynolds correction,and radius correction
!
!     "Flow Characteristics of long orifices with rotation and corner radiusing"
!     W.F. Mcgreehan and M.J. Schotsch
!     ASME 87-GT-162
!
            dh=2*s
            bdh=b/dh
            rzdh=rad/dh
!
            call cd_Mcgreehan_Schotsch(rzdh,bdh,reynolds,cdu)
!
!     compressibility correction factor
!
!     S.L.Bragg
!     "Effect of conpressibility on the discharge coefficient of orifices and convergent nozzles"
!     Journal of Mechanical engineering vol 2 No 1 1960
!
            call cd_bragg(cdu,p2p1,cdbragg,itype)
            cd=cdbragg
            Aeff=Aeff*cd
         endif
!
!****************************************
!     straight labyrinth & stepped labyrinth
!     method found in "Air system Correlations Part1 Labyrinth Seals"
!     H.Zimmermann and K.H. Wolff
!     ASME 98-GT-206
!****************************************
!
         if(n.ge.2) then
            num=(1.d0-p2p1**2)
            denom=R*(n-log(p2p1)/log(e))
!
!     straight labyrinth
!
            if((hst.eq.0.d0).and.(n.ne.1)) then
               call cd_lab_straight(n,p2p1,s,b,reynolds,cd_lab)
               Aeff=Aeff*cd_lab*cd_honeycomb*cd_radius
!
!     Stepped Labyrinth
!
            else
!     corrective term for the first spike
               p1p2=p1/p2
               pt0zps1=(p1p2)**(1/prop(index+4))
               call cd_lab_1spike (pt0zps1,s,b,cd_1spike)
!
!     corrective term for cd_lab_1spike
!
               call cd_lab_correction (p1p2,s,b,cd_correction)
!
!     calculation of the discharge coefficient of the stepped labyrinth
!
               cd=cd_1spike*cd_correction
               cd_lab=cd
!
               Aeff=Aeff*cd_lab*cd_radius*cd_honeycomb
            endif
!
            call lab_straight_ppkrit(n,ppkrit)
!
         endif
!
         xflow_oil=0
!
         write(1,*) ''
         write(1,55) 'In line',int(nodem/100),' from node',node1,
     &' to node', node2,':   air massflow rate= ',xflow,'kg/s',
     &', oil massflow rate= ',xflow_oil,'kg/s'
 55      FORMAT(1X,A,I6.3,A,I6.3,A,I6.3,A,F9.6,A,A,F9.6,A)

         if(inv.eq.1) then
          write(1,56)'       Inlet node  ',node1,':   Tt1=',T1,
     &           'K, Ts1=',T1,'K, Pt1=',P1/1E5, 'Bar'

            write(1,*)'             element S    ',set(numf)(1:20)
            write(1,57)'             eta= ',dvi,'kg/(m*s), Re= ' ,
     &           reynolds,
     &', Cd_radius= ',cd_radius,', Cd_honeycomb= ', 1+cd_honeycomb/100
!
!     straight labyrinth
           if((hst.eq.0.d0).and.(n.ne.1)) then
              write(1,58)'             COF= ',carry_over,
     &             ', Cd_lab= ',cd_lab,', Cd= ',carry_over*cd_lab

!     stepped labyrinth
           elseif(hst.ne.0d0) then
              write(1,59)'             Cd_1_fin= ',
     &             cd_1spike, ', Cd= ',cd,', pt0/ps1= ',pt0zps1,
     &             ', p0/pn= ',p1/p2

!     single fin labyrinth
           elseif(n.eq.1) then
              write(1,60) '             Cd_Mcgreehan= ',cdu,
     &             ', Cd= ',cdbragg
           endif

            write(1,56)'       Outlet node ',node2,':   Tt2= ',T2,
     &           'K, Ts2= ',T2,'K, Pt2= ',P2/1e5,'Bar'

!
         else if(inv.eq.-1) then
            write(1,56)'       Inlet node  ',node2,':    Tt1= ',T1,
     &           'K, Ts1= ',T1,'K, Pt1= ',P1/1E5, 'Bar'

            write(1,*)'             element S    ',set(numf)(1:20)
            write(1,57)'             eta=',dvi,'kg/(m*s), Re= '
     &           ,reynolds,
     & ', Cd_radius= ',cd_radius,', Cd_honeycomb= ',1+cd_honeycomb/100
!
!     straight labyrinth
            if((hst.eq.0.d0).and.(n.ne.1)) then
               write(1,58)'                  COF = ',carry_over,
     &              ', Cd_lab= ',cd_lab,', Cd= ',carry_over*cd_lab
!
!     stepped labyrinth
            elseif(hst.ne.0d0) then
               write(1,59)'                 Cd_1_fin= ',
     &              cd_1spike,', Cd= ',cd,', pt0/ps1= ',pt0zps1,
     &             ', p0/pn= ',p1/p2

!     single fin labyrinth
            elseif(n.eq.1) then
               write(1,60) '              Cd_Mcgreehan= ',
     & cdu,' Cd= ',cdbragg
           endif
           write(1,56)'       Outlet node ',node1,':    Tt2= ',T2,
     &          'K, Ts2= ',T2,'K, Pt2= ',P2/1e5, 'Bar'

        endif
!
 56      FORMAT(1X,A,I6.3,A,f6.1,A,f6.1,A,f9.5,A)
 57      FORMAT(1X,A,E11.5,A,G9.4,A,f6.4,A,f6.4)
 58      FORMAT(1X,A,f7.5,A,f7.5,A,f7.5)
 59      FORMAT(1X,A,f7.5,A,f7.5,A,f7.5,A,f5.3)
 60      FORMAT(1X,A,f7.5,A,f7.5)
      endif
!
      xflow=xflow/iaxial
      df(3)=df(3)*iaxial
!
      return
      end


      SUBROUTINE SB04QR( M, D, IPR, INFO )
C
C     SLICOT RELEASE 5.7.
C
C     Copyright (c) 2002-2020 NICONET e.V.
C
C     PURPOSE
C
C     To solve a linear algebraic system of order M whose coefficient
C     matrix has zeros below the third subdiagonal and zero elements on
C     the third subdiagonal with even column indices. The matrix is
C     stored compactly, row-wise.
C
C     ARGUMENTS
C
C     Input/Output Parameters
C
C     M       (input) INTEGER
C             The order of the system.  M >= 0, M even.
C             Note that parameter M should have twice the value in the
C             original problem (see SLICOT Library routine SB04QU).
C
C     D       (input/output) DOUBLE PRECISION array, dimension
C             (M*M/2+4*M)
C             On entry, the first M*M/2 + 3*M elements of this array
C             must contain the coefficient matrix, stored compactly,
C             row-wise, and the next M elements must contain the right
C             hand side of the linear system, as set by SLICOT Library
C             routine SB04QU.
C             On exit, the content of this array is updated, the last M
C             elements containing the solution with components
C             interchanged (see IPR).
C
C     IPR     (output) INTEGER array, dimension (2*M)
C             The leading M elements contain information about the
C             row interchanges performed for solving the system.
C             Specifically, the i-th component of the solution is
C             specified by IPR(i).
C
C     Error Indicator
C
C     INFO    INTEGER
C             = 0:  successful exit;
C             = 1:  if a singular matrix was encountered.
C
C     METHOD
C
C     Gaussian elimination with partial pivoting is used. The rows of
C     the matrix are not actually permuted, only their indices are
C     interchanged in array IPR.
C
C     REFERENCES
C
C     [1] Golub, G.H., Nash, S. and Van Loan, C.F.
C         A Hessenberg-Schur method for the problem AX + XB = C.
C         IEEE Trans. Auto. Contr., AC-24, pp. 909-913, 1979.
C
C     [2] Sima, V.
C         Algorithms for Linear-quadratic Optimization.
C         Marcel Dekker, Inc., New York, 1996.
C
C     NUMERICAL ASPECTS
C
C     None.
C
C     CONTRIBUTORS
C
C     D. Sima, University of Bucharest, May 2000.
C
C     REVISIONS
C
C     -
C
C     KEYWORDS
C
C     Hessenberg form, orthogonal transformation, real Schur form,
C     Sylvester equation.
C
C     ******************************************************************
C
      DOUBLE PRECISION  ZERO
      PARAMETER         ( ZERO = 0.0D0 )
C     .. Scalar Arguments ..
      INTEGER           INFO, M
C     .. Array Arguments ..
      INTEGER           IPR(*)
      DOUBLE PRECISION  D(*)
C     .. Local Scalars ..
      INTEGER           I, I1, I2, IPRM, IPRM1, J, K, L, M1, MPI, MPI1,
     $                  MPI2
      DOUBLE PRECISION  D1, D2, D3, DMAX
C     .. External Subroutines ..
      EXTERNAL          DAXPY
C     .. Intrinsic Functions ..
      INTRINSIC         ABS, MOD
C     .. Executable Statements ..
C
      INFO = 0
      I2   = M*M/2 + 3*M
      MPI  = M
      IPRM = I2
      M1 = M
      I1 = 1
C
      DO 20 I = 1, M
         MPI = MPI + 1
         IPRM = IPRM + 1
         IPR(MPI) = I1
         IPR(I) = IPRM
         I1 = I1 + M1
         IF ( I.GE.4 .AND. MOD( I, 2 ).EQ.0 ) M1 = M1 - 2
   20 CONTINUE
C
      M1   = M - 1
      MPI1 = M + 1
C
C     Reduce to upper triangular form.
C
      DO 80 I = 1, M1
         MPI  = MPI1
         MPI1 = MPI1 + 1
         IPRM = IPR(MPI)
         D1 = D(IPRM)
         I1 = 3
         IF ( MOD( I, 2 ).EQ.0 ) I1 = 2
         IF ( I.EQ.M1 ) I1 = 1
         MPI2 = MPI + I1
         L = 0
         DMAX = ABS( D1 )
C
         DO 40 J = MPI1, MPI2
            D2 = D(IPR(J))
            D3 = ABS( D2 )
            IF ( D3.GT.DMAX ) THEN
               DMAX = D3
               D1 = D2
               L = J - MPI
            END IF
   40    CONTINUE
C
C        Check singularity.
C
         IF ( DMAX.EQ.ZERO ) THEN
            INFO = 1
            RETURN
         END IF
C
         IF ( L.GT.0 ) THEN
C
C           Permute the row indices.
C
            K = IPRM
            J = MPI + L
            IPRM   = IPR(J)
            IPR(J) = K
            IPR(MPI) = IPRM
            K  = IPR(I)
            I2 = I + L
            IPR(I)  = IPR(I2)
            IPR(I2) = K
         END IF
         IPRM = IPRM + 1
C
C        Annihilate the subdiagonal elements of the matrix.
C
         I2 = I
         D3 = D(IPR(I))
C
         DO 60 J = MPI1, MPI2
            I2 = I2 + 1
            IPRM1 = IPR(J)
            DMAX = -D(IPRM1)/D1
            D(IPR(I2)) = D(IPR(I2)) + DMAX*D3
            CALL DAXPY( M-I, DMAX, D(IPRM), 1, D(IPRM1+1), 1 )
            IPR(J) = IPR(J) + 1
   60    CONTINUE
C
   80 CONTINUE
C
      MPI  = M + M
      IPRM = IPR(MPI)
C
C     Check singularity.
C
      IF ( D(IPRM).EQ.ZERO ) THEN
         INFO = 1
         RETURN
      END IF
C
C     Back substitution.
C
      D(IPR(M)) = D(IPR(M))/D(IPRM)
C
      DO 120 I = M1, 1, -1
         MPI   = MPI - 1
         IPRM  = IPR(MPI)
         IPRM1 = IPRM
         DMAX  = ZERO
C
         DO 100 K = I+1, M
            IPRM1 = IPRM1 + 1
            DMAX  = DMAX + D(IPR(K))*D(IPRM1)
  100    CONTINUE
C
         D(IPR(I)) = ( D(IPR(I)) - DMAX )/D(IPRM)
  120 CONTINUE
C
      RETURN
C *** Last line of SB04QR ***
      END


        INTEGER FUNCTION YEAR4 ( YY )

C********************************************************************
C Version "$Id: year4.f 1 2017-06-10 18:05:20Z coats $"
C EDSS/Models-3 I/O API.
C Copyright (C) 1992-2002 MCNC and Carlie J. Coats, Jr.,
C (c) 2004-2007 Baron Advanced Meteorological Systems,
C (c) 2007-2013 Carlie J. Coats, Jr., and (C) 2014 UNC Institute
C for the Environment.
C Distributed under the GNU LESSER GENERAL PUBLIC LICENSE version 2.1
C See file "LGPL.txt" for conditions of use.
C.........................................................................
C       function body starts at line  59
C
C  FUNCTION:
C
C      Returns the 4-digit year from the 2-digit year
C
C
C  REVISION HISTORY:
C
C       Create by M Houyoux: 5/97
C
C       Modified 03/2010 by CJC: F9x changes for I/O API v3.1
C
C       Modified 02/2014 by CJC: Fix MH violation of coding-standards:
C       check status IOS from  ENVINT()!!
C****************************************************************************

        IMPLICIT NONE

C.......   INCLUDES:

        INCLUDE 'PARMS3.EXT'
        INCLUDE 'IODECL3.EXT'

C.......   ARGUMENTS:

        INTEGER, INTENT(IN   ) :: YY    ! 2 digit year

C.......   EXTERNAL FUNCTIONS

        INTEGER, EXTERNAL :: ENVINT

C.......   LOCAL VARIABLES:

        CHARACTER*256   MESG
        INTEGER         ISTAT

        INTEGER, SAVE :: BASEYR, PIVOTYR
        LOGICAL, SAVE :: FIRSTIME = .TRUE.

        CHARACTER*16, PARAMETER :: PNAME = 'YEAR4'

C......................................................................
C       begin YEAR4

        IF ( FIRSTIME ) THEN
            FIRSTIME = .FALSE.
            BASEYR = ENVINT( 'YEAR4_BASE',
     &                        'Base century year for YEAR4 algorithm',
     &                        1900, ISTAT )
            IF ( ISTAT .GT. 0 ) THEN
                CALL M3EXIT( PNAME,0,0,'Bad env vble "YEAR4_BASE"', 2)
            END IF
            IF ( BASEYR .GT. 100 ) THEN
                BASEYR = BASEYR / 100
            END IF
            BASEYR  = BASEYR * 100
            PIVOTYR = ENVINT( 'YEAR4_PIVOT',
     &                        'Pivot year for YEAR4 algorithm',
     &                        BASEYR + 70, ISTAT )
            IF ( ISTAT .GT. 0 ) THEN
                CALL M3EXIT( PNAME,0,0,'Bad env vble "YEAR4_PIVOT"', 2)
            END IF
            PIVOTYR = MOD( PIVOTYR , 100 )
        END IF

        IF( YY .GT. BASEYR ) THEN
            YEAR4 = YY
        ELSE IF( YY .GT. 99 .OR. YY .LT. 0 ) THEN
            WRITE( MESG,94010 ) 'Year "', YY,
     &                          '" is not a 2-digit positive number'
            CALL M3EXIT( 'YEAR4', 0, 0, MESG, 2 )

        ELSE IF( YY .GE. PIVOTYR ) THEN
            YEAR4 = BASEYR + YY
        ELSE
            YEAR4 = BASEYR + 100 + YY
        ENDIF

C................   end body of YEAR4 .......................................

C...........   Internal buffering formats............ 94xxx

94010   FORMAT( 10( A, :, I7, :, 1X ) )

        END FUNCTION YEAR4


SUBROUTINE LA_TEST_DSYEVX( JOBZ, RANGE, UPLO,  N, A, LDA, VL, VU, IL, &
     &  IU, ABSTOL, M, W, Z, LDZ, WORK, LWORK, IWORK, IFAIL, INFO )
!
!  -- LAPACK95 interface driver routine (version 1.1) --
!     UNI-C, Denmark;
!     September 11, 1999
!
!  .. Use Statements ..
      USE LA_PRECISION, ONLY: WP => DP
      USE F95_LAPACK, ONLY: LA_SYEVX
!  .. Implicit Statement ..
      IMPLICIT NONE
!  .. Scalar Arguments ..
      INTEGER, INTENT(IN) :: N, LDA, LDZ, IL, IU, LWORK
      REAL(WP), INTENT(IN) ::  ABSTOL, VL, VU
      INTEGER, INTENT(OUT) :: M
      INTEGER, INTENT(INOUT) :: INFO
      CHARACTER*1, INTENT(IN) :: UPLO, JOBZ, RANGE
!  .. Array Arguments ..
      REAL(WP), INTENT(INOUT) :: A(1:LDA,1:N)
      REAL(WP), INTENT(OUT)::  W(1:N), WORK(1:LWORK), Z(1:LDZ,1:N)
      INTEGER, INTENT(OUT) :: IWORK(1:5*N), IFAIL(1:N)
!  .. Parameters ..
      CHARACTER(LEN=8),  PARAMETER :: SRNAME = 'LA_SYEVX'
      CHARACTER(LEN=14), PARAMETER :: SRNAMT = 'LA_TEST_DSYEVX'
      LOGICAL LSAME
      EXTERNAL LSAME
!  .. Common blocks ..
      INTEGER :: INFOTC
      COMMON /LINFO95/ INFOTC
!  .. Local Scalars ..
      INTEGER :: I, J, IA1, IA2, IW, IIL, IIU, IIFAIL
      REAL(WP) :: IVU, IVL
      CHARACTER*1 :: IUPLO, IJOBZ, IRANGE
!  .. Local Arrays ..
      LOGICAL, SAVE :: CTEST = .TRUE., ETEST = .TRUE.
!  .. Executable Statements ..
      IA1 = N; IA2 = N; IUPLO = UPLO; IW = N; IJOBZ = JOBZ
      IVU=VU; IVL = VL;IIL=IL; IIU = IU; IIFAIL = N
      I = INFO / 100; J = INFO - I*100; IRANGE=RANGE

      SELECT CASE(I)
      CASE (1)
      IA2 = IA1 - 1
      CASE (2)
        IW = IA1 - 1
      CASE (3)
        IJOBZ = 'T'
        CALL LA_SYEVX( A(1:IA1,1:IA2), W(1 :IW), IJOBZ, IUPLO, &
&         M=M, IFAIL=IFAIL(1:IIFAIL), ABSTOL=ABSTOL, INFO=INFO )
        CALL LA_AUX_AA01( I, CTEST, ETEST, SRNAMT )
        RETURN
      CASE (4)
        IUPLO = 'T'
      CASE (5)
        IVL = IVU+1; IJOBZ='V'; IRANGE='V'
        CALL LA_SYEVX( A(1:IA1,1:IA2), W(1 :IW), UPLO=IUPLO, &
&         VL=IVL, VU=IVU,  M=M, IFAIL=IFAIL(1:IIFAIL), ABSTOL=ABSTOL,&
&         INFO=INFO )
        CALL LA_AUX_AA01( I, CTEST, ETEST, SRNAMT )
        RETURN
      CASE (6)
        IRANGE='A'; IJOBZ='V'
        CALL LA_SYEVX( A(1:IA1,1:IA2), W(1 :IW), IJOBZ, IUPLO, &
&         IVL, IVU, IL, IU,  M, IFAIL(1:IIFAIL),&
&         ABSTOL, INFO )
        CALL LA_AUX_AA01( I, CTEST, ETEST, SRNAMT )
        RETURN
      CASE(7)
        IIL = IIU + 1; IJOBZ='V'; IRANGE='I'
        CALL LA_SYEVX( A(1:IA1,1:IA2), W(1 :IW), IJOBZ, IUPLO, &
&         IL=IIL, IU=IIU, M=M,IFAIL=IFAIL(1 :IIFAIL), &
&         ABSTOL=ABSTOL, INFO=INFO )
        CALL LA_AUX_AA01( I, CTEST, ETEST, SRNAMT )
        RETURN
      CASE (8)
        IIU = IA2 + 1;  IIL = IIU
        IJOBZ='V'; IRANGE='I'
        CALL LA_SYEVX( A(1:IA1,1:IA2), W(1 :IW), IJOBZ, IUPLO, &
&         IL=IIL, IU=IIU, M=M, ABSTOL=ABSTOL, INFO=INFO )
        CALL LA_AUX_AA01( I, CTEST, ETEST, SRNAMT )
        RETURN
      CASE(10)
        IIFAIL = IA2 - 1
        IJOBZ='V'; IRANGE='A'
        CALL LA_SYEVX( A(1:IA1,1:IA2), W(1 :IW), IJOBZ, IUPLO, &
&         M=M, IFAIL=IFAIL(1:IIFAIL), ABSTOL=ABSTOL, INFO=INFO )
        CALL LA_AUX_AA01( I, CTEST, ETEST, SRNAMT )
      RETURN
    CASE(:-1,9,11:)
      CALL UESTOP(SRNAMT)
  END SELECT

  IF (LSAME(IRANGE,'A')) THEN
        IF (LSAME(IJOBZ, 'V')) THEN
          CALL LA_SYEVX( A(1:IA1,1:IA2), W(1 :IW), IJOBZ, IUPLO, &
&           M=M, IFAIL=IFAIL(1:IIFAIL), ABSTOL=ABSTOL, INFO=INFO )
        ELSE
          CALL LA_SYEVX( A(1:IA1,1:IA2), W(1 :IW), UPLO=IUPLO, &
&           M=M, ABSTOL=ABSTOL, INFO=INFO )
        END IF
      ELSE
        IF (LSAME(IRANGE, 'V')) THEN
          IF (LSAME(IJOBZ, 'V')) THEN
            CALL LA_SYEVX( A(1:IA1,1:IA2), W(1 :IW), IJOBZ, IUPLO, &
&             IVL, IVU,  M=M, IFAIL=IFAIL(1:IIFAIL), ABSTOL=ABSTOL,&
&             INFO=INFO )
          ELSE
            CALL LA_SYEVX( A(1:IA1,1:IA2), W(1 :IW), UPLO=IUPLO,  &
&             VL=IVL, VU=IVU, M=M, ABSTOL=ABSTOL, INFO=INFO )
          END IF
        ELSE
          IF (LSAME(IJOBZ, 'V')) THEN
            CALL LA_SYEVX( A(1:IA1,1:IA2), W(1 :IW), IJOBZ, IUPLO, &
&             IL=IIL, IU=IIU, M=M,IFAIL=IFAIL(1 :IIFAIL), &
&             ABSTOL=ABSTOL, INFO=INFO )
          ELSE
            CALL LA_SYEVX( A(1:IA1,1:IA2), W(1 :IW), UPLO=IUPLO, &
&             IL=IIL, IU=IIU, M=M, ABSTOL=ABSTOL, INFO=INFO )
          ENDIF
        END IF
      ENDIF
      IF (N/=0) Z(1:IA1, 1:M) = A(1:IA1, 1:M)

      CALL LA_AUX_AA01( I, CTEST, ETEST, SRNAMT )
END SUBROUTINE LA_TEST_DSYEVX


program foo
  integer :: arr(3) = (/1, 2, 3/)
  print *,arr
end program foo


( Compiler interpreter mode tests )

." 3 + 2  ->  " 3 2 + . cr
." 3 - 2  ->  " 3 2 - . cr
." 3 * 2  ->  " 3 2 * . cr
." 6 / 2  ->  " 6 2 / . cr
." 3 dup + .  ->  " 3 dup + . cr
." 3 4 drop .  ->  " 3 4 drop . cr
." 1 2 swap . .  ->  " 1 2 swap . . cr
." 1 2 3 rot . . .  ->  " 1 2 3 rot . . . cr
." 1 2 3 3 pick . . . .  ->  " 1 2 3 3 pick . . . . cr
." 1 2 3 3 roll . . . ->  " 1 2 3 3 roll . . . cr
." *" space space ." *" cr
." *" 5 spaces ." *" cr
ascii * emit cr

." here is " hex here . decimal cr

." 128 in hex is " 128 hex . decimal cr
." 128 in binary is " 128 2 base ! . decimal cr

." hex ff in decimal is " hex ff decimal . cr
." binary 1100 in decimal is " 2 base ! 1100 decimal . cr

: test[]
	[ ." Compiling Test " cr 123 ]
	cr
	[ ." Popping value " . cr ] ;

( Test [if] )

1 [if]
	." This should be printed" cr
[then]

1 [if]
	." This should be printed" cr
[else]
	." This should NOT be printed" cr
[then]

0 [if]
	." This should NOT be printed" cr
[else]
	." This should be printed" cr
[then]

[defined] cr [if] ." cr is defined" cr [then]
[defined] abc not [if] ." ABC is not defined" cr [then]


! PR fortran/71014
! { dg-do run }
! { dg-additional-options "-O0" }

program pr71014
  implicit none
  integer :: i, j
  integer, parameter :: t = 100*101/2
  integer :: s(16)
  s(:) = 0
!$omp parallel do
  do j = 1, 16
    associate (k => j)
      do i = 1, 100
        s(j) = s(j) + i
      end do
    end associate
  end do
  if (any(s /= t)) call abort
end program pr71014


program diffusion
    use, intrinsic :: iso_fortran_env, only : SP => REAL32, DP => REAL64, error_unit
    use :: diffusion_mod
    implicit none
    integer, parameter :: max_steps = 1000
    integer :: n
    real(kind=SP), dimension(:, :), allocatable :: temp, new_temp
    real(kind=SP) :: error
    integer :: step_nr
    real(kind=DP) :: start_time, stop_time

    call get_arguments(n)
    call init_system(n, temp, new_temp)

    call cpu_time(start_time)
    do step_nr = 1, max_steps
          call diffusion_step(temp, new_temp, error)
          if (mod(step_nr, 100) == 0) &
              print '(A, I0, A, E10.3)', 'step ', step_nr, ': ', error
          call swap(new_temp, temp)
    end do
    call cpu_time(stop_time)
    if (n <= 10) then
        !$acc update self(temp)
        call print_system(temp)
    end if
    call dealloc_system(temp, new_temp)
    print '(A, E15.7)', 'time = ', stop_time - start_time

contains

    subroutine get_arguments(n)
        implicit none
        integer, intent(out) :: n
        character(len=128) :: buffer, msg
        integer :: istat

        if (command_argument_count() < 1) then
            n = 10
        else
            call get_command_argument(1, buffer)
            read (buffer, fmt=*, iomsg=msg, iostat=istat) n
            if (istat /= 0) then
                write (unit=error_unit, fmt='(2A)') &
                    'error: ', trim(msg)
                stop 2
            end if
        end if
    end subroutine get_arguments

end program diffusion


! DART software - Copyright UCAR. This open source software is provided
! by UCAR, "as is", without charge, subject to all terms of use at
! http://www.image.ucar.edu/DAReS/DART/DART_download
!
! $Id$

program prog_dobsdx

!-----------------------------------------------------------
! Numerically differentiate the observation values for small
! change in input vector component. Used to interpolate
! observation.

implicit none
real(8)        :: deltax = 0.1_8, x
real(8),allocatable :: obsx(:), obsxpd(:), dobsdx(:), locx(:)
character(128) :: file_in ='obsval.dat.bck'
character(128) :: file_out ='obsval.dat'
character(128) :: file_x ='model.in.bck'
integer :: nobs,i,j

nobs = 0
open(11,file=trim(file_in),status='old')
do
  read(11,'(1x)',end=123)
  nobs = nobs + 1
enddo
123 rewind(11)
allocate(obsx(nobs),obsxpd(nobs),dobsdx(nobs),locx(nobs))
open(12,file=trim(file_out),status='old')
do i = 1, nobs
   read(11,*)locx(i),j,obsx(i)
   read(12,*)locx(i),j,obsxpd(i)
   dobsdx(i) = (obsxpd(i) - obsx(i))/deltax
end do
close(11)
rewind(12)
open(11,file=trim(file_x),status='old')
read(11,*)
read(11,*)
read(11,*) x
close(11)
do i = 1, nobs
   write(12,*)locx(i),x,obsx(i),dobsdx(i)
enddo
close(12)
end program prog_dobsdx

! <next few lines under version control, do not edit>
! $URL$
! $Id$
! $Revision$
! $Date$


!
!    Copyright 2011 Sebastian Heimann
!
!    Licensed under the Apache License, Version 2.0 (the "License");
!    you may not use this file except in compliance with the License.
!    You may obtain a copy of the License at
!
!        http://www.apache.org/licenses/LICENSE-2.0
!
!    Unless required by applicable law or agreed to in writing, software
!    distributed under the License is distributed on an "AS IS" BASIS,
!    WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
!    See the License for the specific language governing permissions and
!    limitations under the License.
!

program test_comparator

    use util
    use sparse_trace
    use comparator
    use piecewise_linear_function

    implicit none

    type(t_strip) :: s1, s2, stap
    type(t_probe) :: a, b
    real :: n, eps, dt
    integer, dimension(2) :: shiftrange
    real, dimension(-5:5) :: cross_corr
    type(t_plf) :: taper

    dt = 1.
    call probe_init( a,dt )
    call probe_init( b,dt )

    call test_begin("test_comparator")

    call strip_init( (/-1,2/), (/0.,0.,5.,1./), s1 )
    call strip_init( (/1,4/), (/5.,1.,1.,1./), s2 )

    call probe_set_array( a, s1 )
    call probe_set_array( b, s2 )
    n = probes_norm( a, b )
    if (n /= 0.) call test_fail("1")
    n = probes_norm( a, b, L1NORM )
    if (n /= 0.) call test_fail("1b")

    call strip_init( (/-1,2/), (/0.,0.,0.,1./), s1 )
    call strip_init( (/1,4/), (/0.,1.,1.,1./), s2 )
    call probe_set_array( a, s1 )
    call probe_set_array( b, s2 )
    n = probes_norm( a, b )
    if (n /= 0.) call test_fail("2")
    n = probes_norm( a, b, L1NORM )
    if (n /= 0.) call test_fail("2b")

    eps = 0.000001;

    call strip_init( (/-4,-1/), (/1.,0.,0.,0./), s1 )
    call strip_init( (/1,4/), (/1.,0.,0.,0./), s2 )
    call probe_set_array( a, s1 )
    call probe_set_array( b, s2 )
    n = probes_norm( a,b )
    if (.not. near(n,sqrt(2.),eps)) call test_fail("3")
    n = probes_norm( a,b, L1NORM )
    if (.not. near(n,2.,eps)) call test_fail("3b")

    call strip_init( (/0,3/), (/1.,2.,1.,0./), s1 )
    call strip_init( (/1,4/), (/1.,1.,0.,1./), s2 )
    call probe_set_array( a, s1 )
    call probe_set_array( b, s2 )
    n = probes_norm( a,b )
    if (.not. near(n ,sqrt(3.),eps)) call test_fail("4")
    n = probes_norm( a,b, L1NORM )
    if (.not. near(n ,3.,eps)) call test_fail("4b")

    call strip_init( (/0,3/), (/0.,1.,2.,1./), s1 )
    call strip_init( (/1,2/), (/1.,2./), s2 )
    call probe_set_array( a, s1 )
    call probe_set_array( b, s2 )
    n = probes_norm( a,b )
    if (.not. near(n,1.,eps)) call test_fail("5")
    n = probes_norm( a,b, L1NORM )
    if (.not. near(n,1.,eps)) call test_fail("5b")

    call strip_init( (/0,4/), (/0.,1.,2.,1.,0./), s1 )
    call strip_init( (/10,14/), (/0.,1.,2.,1.,0./), s2 )
    call probe_set_array( a, s1 )
    call probe_set_array( b, s2 )
    n = probes_norm( a,b, AMPSPEC_L2NORM )
    if (.not. near(n,0.,eps)) call test_fail("6")

    call strip_init( (/1,5/), (/0.,1.,2.,1.,0./), s1 )
    call strip_init( (/2,6/), (/0.,1.,2.,1.,0./), s2 )
    call probe_set_array( a, s1 )
    call probe_set_array( b, s2 )
    shiftrange = (/-5,5/)
    call probes_windowed_cross_corr( a, b, shiftrange, cross_corr )
    if (any(cross_corr .ne. (/0., 0., 1., 4., 6., 4., 1., 0., 0., 0., 0./))) then
        call test_fail("cross correlation")
    end if

    call plf_make( taper, 2.5,1., 3.5,1. )
    call probe_set_taper( a, taper )
    call probe_get_tapered(a, stap)
    call probe_set_taper( b, taper )
    call probes_windowed_cross_corr( a, b, shiftrange, cross_corr )
    if (any(cross_corr .ne. (/0., 0., 0., 2., 4., 2., 0., 0., 0., 0., 0./))) then
        call test_fail("tapered cross correlation")
    end if

    call test_end()

    call cleanup()

  contains

    elemental logical function near( a,b, eps )
        real, intent(in) :: a,b,eps
        near = abs(a-b) < eps
    end function

end program


!*==zhpr2.f90  processed by SPAG 7.51RB at 20:37 on  3 Mar 2022
!> \brief \b ZHPR2
!
!  =========== DOCUMENTATION ===========
!
! Online html documentation available at
!            http://www.netlib.org/lapack/explore-html/
!
!  Definition:
!  ===========
!
!       SUBROUTINE ZHPR2(UPLO,N,ALPHA,X,INCX,Y,INCY,AP)
!
!       .. Scalar Arguments ..
!       COMPLEX*16 ALPHA
!       INTEGER INCX,INCY,N
!       CHARACTER UPLO
!       ..
!       .. Array Arguments ..
!       COMPLEX*16 AP(*),X(*),Y(*)
!       ..
!
!
!> \par Purpose:
!  =============
!>
!> \verbatim
!>
!> ZHPR2  performs the hermitian rank 2 operation
!>
!>    A := alpha*x*y**H + conjg( alpha )*y*x**H + A,
!>
!> where alpha is a scalar, x and y are n element vectors and A is an
!> n by n hermitian matrix, supplied in packed form.
!> \endverbatim
!
!  Arguments:
!  ==========
!
!> \param[in] UPLO
!> \verbatim
!>          UPLO is CHARACTER*1
!>           On entry, UPLO specifies whether the upper or lower
!>           triangular part of the matrix A is supplied in the packed
!>           array AP as follows:
!>
!>              UPLO = 'U' or 'u'   The upper triangular part of A is
!>                                  supplied in AP.
!>
!>              UPLO = 'L' or 'l'   The lower triangular part of A is
!>                                  supplied in AP.
!> \endverbatim
!>
!> \param[in] N
!> \verbatim
!>          N is INTEGER
!>           On entry, N specifies the order of the matrix A.
!>           N must be at least zero.
!> \endverbatim
!>
!> \param[in] ALPHA
!> \verbatim
!>          ALPHA is COMPLEX*16
!>           On entry, ALPHA specifies the scalar alpha.
!> \endverbatim
!>
!> \param[in] X
!> \verbatim
!>          X is COMPLEX*16 array, dimension at least
!>           ( 1 + ( n - 1 )*abs( INCX ) ).
!>           Before entry, the incremented array X must contain the n
!>           element vector x.
!> \endverbatim
!>
!> \param[in] INCX
!> \verbatim
!>          INCX is INTEGER
!>           On entry, INCX specifies the increment for the elements of
!>           X. INCX must not be zero.
!> \endverbatim
!>
!> \param[in] Y
!> \verbatim
!>          Y is COMPLEX*16 array, dimension at least
!>           ( 1 + ( n - 1 )*abs( INCY ) ).
!>           Before entry, the incremented array Y must contain the n
!>           element vector y.
!> \endverbatim
!>
!> \param[in] INCY
!> \verbatim
!>          INCY is INTEGER
!>           On entry, INCY specifies the increment for the elements of
!>           Y. INCY must not be zero.
!> \endverbatim
!>
!> \param[in,out] AP
!> \verbatim
!>          AP is COMPLEX*16 array, dimension at least
!>           ( ( n*( n + 1 ) )/2 ).
!>           Before entry with  UPLO = 'U' or 'u', the array AP must
!>           contain the upper triangular part of the hermitian matrix
!>           packed sequentially, column by column, so that AP( 1 )
!>           contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 1, 2 )
!>           and a( 2, 2 ) respectively, and so on. On exit, the array
!>           AP is overwritten by the upper triangular part of the
!>           updated matrix.
!>           Before entry with UPLO = 'L' or 'l', the array AP must
!>           contain the lower triangular part of the hermitian matrix
!>           packed sequentially, column by column, so that AP( 1 )
!>           contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 2, 1 )
!>           and a( 3, 1 ) respectively, and so on. On exit, the array
!>           AP is overwritten by the lower triangular part of the
!>           updated matrix.
!>           Note that the imaginary parts of the diagonal elements need
!>           not be set, they are assumed to be zero, and on exit they
!>           are set to zero.
!> \endverbatim
!
!  Authors:
!  ========
!
!> \author Univ. of Tennessee
!> \author Univ. of California Berkeley
!> \author Univ. of Colorado Denver
!> \author NAG Ltd.
!
!> \date December 2016
!
!> \ingroup complex16_blas_level2
!
!> \par Further Details:
!  =====================
!>
!> \verbatim
!>
!>  Level 2 Blas routine.
!>
!>  -- Written on 22-October-1986.
!>     Jack Dongarra, Argonne National Lab.
!>     Jeremy Du Croz, Nag Central Office.
!>     Sven Hammarling, Nag Central Office.
!>     Richard Hanson, Sandia National Labs.
!> \endverbatim
!>
!  =====================================================================
      SUBROUTINE ZHPR2(Uplo,N,Alpha,X,Incx,Y,Incy,Ap)
      IMPLICIT NONE
!*--ZHPR2149
!
!  -- Reference BLAS level2 routine (version 3.7.0) --
!  -- Reference BLAS is a software package provided by Univ. of Tennessee,    --
!  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
!     December 2016
!
!     .. Scalar Arguments ..
      COMPLEX*16 Alpha
      INTEGER Incx , Incy , N
      CHARACTER Uplo
!     ..
!     .. Array Arguments ..
      COMPLEX*16 Ap(*) , X(*) , Y(*)
!     ..
!
!  =====================================================================
!
!     .. Parameters ..
      COMPLEX*16 ZERO
      PARAMETER (ZERO=(0.0D+0,0.0D+0))
!     ..
!     .. Local Scalars ..
      COMPLEX*16 temp1 , temp2
      INTEGER i , info , ix , iy , j , jx , jy , k , kk , kx , ky
!     ..
!     .. External Functions ..
      LOGICAL LSAME
      EXTERNAL LSAME
!     ..
!     .. External Subroutines ..
      EXTERNAL XERBLA
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC DBLE , DCONJG
!     ..
!
!     Test the input parameters.
!
      info = 0
      IF ( .NOT.LSAME(Uplo,'U') .AND. .NOT.LSAME(Uplo,'L') ) THEN
         info = 1
      ELSEIF ( N<0 ) THEN
         info = 2
      ELSEIF ( Incx==0 ) THEN
         info = 5
      ELSEIF ( Incy==0 ) THEN
         info = 7
      ENDIF
      IF ( info/=0 ) THEN
         CALL XERBLA('ZHPR2 ',info)
         RETURN
      ENDIF
!
!     Quick return if possible.
!
      IF ( (N==0) .OR. (Alpha==ZERO) ) RETURN
!
!     Set up the start points in X and Y if the increments are not both
!     unity.
!
      IF ( (Incx/=1) .OR. (Incy/=1) ) THEN
         IF ( Incx>0 ) THEN
            kx = 1
         ELSE
            kx = 1 - (N-1)*Incx
         ENDIF
         IF ( Incy>0 ) THEN
            ky = 1
         ELSE
            ky = 1 - (N-1)*Incy
         ENDIF
         jx = kx
         jy = ky
      ENDIF
!
!     Start the operations. In this version the elements of the array AP
!     are accessed sequentially with one pass through AP.
!
      kk = 1
      IF ( LSAME(Uplo,'U') ) THEN
!
!        Form  A  when upper triangle is stored in AP.
!
         IF ( (Incx==1) .AND. (Incy==1) ) THEN
            DO j = 1 , N
               IF ( (X(j)/=ZERO) .OR. (Y(j)/=ZERO) ) THEN
                  temp1 = Alpha*DCONJG(Y(j))
                  temp2 = DCONJG(Alpha*X(j))
                  k = kk
                  DO i = 1 , j - 1
                     Ap(k) = Ap(k) + X(i)*temp1 + Y(i)*temp2
                     k = k + 1
                  ENDDO
                  Ap(kk+j-1) = DBLE(Ap(kk+j-1))                         &
     &                         + DBLE(X(j)*temp1+Y(j)*temp2)
               ELSE
                  Ap(kk+j-1) = DBLE(Ap(kk+j-1))
               ENDIF
               kk = kk + j
            ENDDO
         ELSE
            DO j = 1 , N
               IF ( (X(jx)/=ZERO) .OR. (Y(jy)/=ZERO) ) THEN
                  temp1 = Alpha*DCONJG(Y(jy))
                  temp2 = DCONJG(Alpha*X(jx))
                  ix = kx
                  iy = ky
                  DO k = kk , kk + j - 2
                     Ap(k) = Ap(k) + X(ix)*temp1 + Y(iy)*temp2
                     ix = ix + Incx
                     iy = iy + Incy
                  ENDDO
                  Ap(kk+j-1) = DBLE(Ap(kk+j-1))                         &
     &                         + DBLE(X(jx)*temp1+Y(jy)*temp2)
               ELSE
                  Ap(kk+j-1) = DBLE(Ap(kk+j-1))
               ENDIF
               jx = jx + Incx
               jy = jy + Incy
               kk = kk + j
            ENDDO
         ENDIF
!
!        Form  A  when lower triangle is stored in AP.
!
      ELSEIF ( (Incx==1) .AND. (Incy==1) ) THEN
         DO j = 1 , N
            IF ( (X(j)/=ZERO) .OR. (Y(j)/=ZERO) ) THEN
               temp1 = Alpha*DCONJG(Y(j))
               temp2 = DCONJG(Alpha*X(j))
               Ap(kk) = DBLE(Ap(kk)) + DBLE(X(j)*temp1+Y(j)*temp2)
               k = kk + 1
               DO i = j + 1 , N
                  Ap(k) = Ap(k) + X(i)*temp1 + Y(i)*temp2
                  k = k + 1
               ENDDO
            ELSE
               Ap(kk) = DBLE(Ap(kk))
            ENDIF
            kk = kk + N - j + 1
         ENDDO
      ELSE
         DO j = 1 , N
            IF ( (X(jx)/=ZERO) .OR. (Y(jy)/=ZERO) ) THEN
               temp1 = Alpha*DCONJG(Y(jy))
               temp2 = DCONJG(Alpha*X(jx))
               Ap(kk) = DBLE(Ap(kk)) + DBLE(X(jx)*temp1+Y(jy)*temp2)
               ix = jx
               iy = jy
               DO k = kk + 1 , kk + N - j
                  ix = ix + Incx
                  iy = iy + Incy
                  Ap(k) = Ap(k) + X(ix)*temp1 + Y(iy)*temp2
               ENDDO
            ELSE
               Ap(kk) = DBLE(Ap(kk))
            ENDIF
            jx = jx + Incx
            jy = jy + Incy
            kk = kk + N - j + 1
         ENDDO
      ENDIF
!
!
!     End of ZHPR2 .
!
      END SUBROUTINE ZHPR2


program comp_test
  use flips

  ! This program tests single and double precision reals in FLIPS

  implicit none

  !integer, parameter :: sp = kind(1.0E0)
  !integer, parameter :: dp = kind(1.0D0)

  real(dp) :: t,f
  integer :: sstart,send,sstep,bmin,bmax,bstep,loopcnt,order, prec,mem
  integer :: oa,ob,oc,ia,ib,ic, i, j, bs, odfac
  logical :: flag = .FALSE.,use_files

  write(*,*) 'Give precision:'
  write(*,*) '1. Single'
  write(*,*) '2. Double'
  write(*,*) 'Anything else terminates'
  read(*,*) prec
  if (.NOT.(prec==1 .OR. prec==2)) then
     write(*,*) 'Bye!'
     stop
  end if

  write(*,*) 'Memory or binary files:'
  write(*,*) '1. Memory'
  write(*,*) '2. Binary files'
  write(*,*) 'Anything else terminates'
  read(*,*) mem
  if (.NOT.(mem==1 .OR. mem==2)) then
     write(*,*) 'Bye!'
     stop
  end if

  if (mem==1) then
     use_files=.FALSE.
  else
     use_files=.TRUE.
  end if

  write(*,*) 'Give start size, end size, step'
  read(*,*) sstart,send,sstep
  if (sstep==0) sstep=1

  write(*,*) 'Give od factor:'
  read(*,*) odfac

  write(*,*) 'Give buffer min size, max size, step'
  read(*,*) bmin,bmax,bstep
  if (bstep==0) bstep=1

  write(*,*) 'Give order:'
  write(*,*) '1. By buffer size'
  write(*,*) '2. By matrix size'
  write(*,*) 'Anything else terminates'
  read(*,*) order

  select case (order)

  case(1)
     do i = bmin,bmax,bstep
        do j = sstart,send,sstep

           !loopcnt = floor(max(1.0,1100*exp(-0.01*j)+1))
           loopcnt = 1

           if (i==0) then
              if (prec==1) then
                 call test_run_c(j,1,loopcnt,use_files,t,odfac)
              else
                 call test_run_z(j,1,loopcnt,use_files,t,odfac)
              end if
              bs = 1
           else

              if (prec==1) then
                 call test_run_c(j,i,loopcnt,use_files,t,odfac)
              else
                 call test_run_z(j,i,loopcnt,use_files,t,odfac)
              end if
              bs = i
           end if

           write(*,'(i6,i6,f15.8,f6.3)') j,bs,t

        end do
     end do

  case(2)
     do i = sstart,send,sstep
        do j = bmin,bmax,bstep

           !loopcnt = floor(max(1.0,1100*exp(-0.01*i)+1))
           loopcnt = 1

           if (j==0) then
              if (prec==1) then
                 call test_run_c(i,1,loopcnt,use_files,t,odfac)
              else
                 call test_run_z(i,1,loopcnt,use_files,t,odfac)
              end if
              bs = 1
           else

              if (prec==1) then
                 call test_run_c(i,j,loopcnt,use_files,t,odfac)
              else
                 call test_run_z(i,j,loopcnt,use_files,t,odfac)
              end if
              bs = j
           end if

           write(*,'(i6,i6,f15.8,f6.3)') i,bs,t

        end do
     end do
  case default
     write(*,*) 'Bye!'
     stop
  end select

contains

  subroutine test_run_c(size,buffer,loops,files,time,odf)
    implicit none

    integer, intent(in) :: size, buffer, loops, odf
    logical :: files
    real(dp), intent(out) :: time

    type(flips_c) :: gs
    real(dp) :: ts,te,total
    complex(sp), dimension(:), allocatable :: amat
    complex(sp), dimension(:), allocatable :: mvec
    real(sp), dimension(:), allocatable :: aux1,aux2
    integer :: n

    allocate(amat(size*size*odf),mvec(size*odf),aux1(size*size*odf),aux2(size*odf))

    time = 0.0D0

write(*,*) 'Data construction start'

    ! Make data
    call random_number(aux1)
    amat = aux1
    call random_number(aux1)
    amat = amat + (0.0,1.0)*aux1
    call random_number(aux2)
    mvec = aux2
    call random_number(aux2)
    mvec = mvec + (0.0,1.0) * aux2

write(*,*) 'Data construction completed'

    ! Start clock
    call cpu_time(ts)

write(*,*) 'FLIPS start!'

    ! Loop
    do n = 1,loops

       ! Initialize flips object
       if (files) then
          call flips_init(gs,size,1,idnum=100,buffersize=buffer)
       else
          call flips_init(gs,size,1,buffersize=buffer)
       end if

       ! Feed the data
       call flips_add(gs,size*odf,amat,mvec)
       ! Solve
       call flips_solve(gs)

       ! Update flops
       !flops = flops + gs%fc

       ! Kill fob
       call flips_kill(gs,.FALSE.)

    end do

write(*,*) 'FLIPS complete'

    ! Stop clock
    call cpu_time(te)

    !  time
    time = (te-ts)/loops
    ! flops
    !flops = flops/loops

    deallocate(amat,mvec)

  end subroutine test_run_c

  subroutine test_run_z(size,buffer,loops,files,time,odf)
    implicit none

    integer, intent(in) :: size, buffer, loops,odf
    logical :: files
    real(dp), intent(out) :: time

    type(flips_z) :: gs
    real(dp) :: ts,te,total
    complex(dp), dimension(:), allocatable :: amat
    complex(dp), dimension(:), allocatable :: mvec
    real(dp), dimension(:), allocatable :: aux1,aux2
    integer :: n

    allocate(amat(size*size*odf),mvec(size*odf),aux1(size*size*odf),aux2(size*odf))

    time = 0.0D0

    ! Make data
    call random_number(aux1)
    amat = aux1
    call random_number(aux1)
    amat = amat + (0.0_dp,1.0_dp)*aux1
    call random_number(aux2)
    mvec = aux2
    call random_number(aux2)
    mvec = mvec + (0.0_dp,1.0_dp) * aux2

    ! Start clock
    call cpu_time(ts)

    ! Loop
    do n = 1,loops

       ! Initialize flips object
       if (files) then
          call flips_init(gs,size,1,idnum=100,buffersize=buffer)
       else
          call flips_init(gs,size,1,buffersize=buffer)
       end if

       ! Feed the data
       call flips_add(gs,size*odf,amat,mvec)
       ! Solve
       call flips_solve(gs)

       ! Update flops
       !flops = flops + gs%fc

       ! Kill fob
       call flips_kill(gs,.FALSE.)

    end do

    ! Stop clock
    call cpu_time(te)

    !  time
    time = (te-ts)/loops
    ! flops
    !flops = flops/loops

    deallocate(amat,mvec)

  end subroutine test_run_z

end program comp_test