C*********************************************************************
C
C This benchmark test program is measuring a cpu performance
C of floating point operation by a Poisson equation solver.
CC
C If you have any question, please ask me via email.
C written by Ryutaro HIMENO, November 26, 2001.
C Version 3.0
C ----------------------------------------------
C Ryutaro Himeno, Dr. of Eng.
C Head of Computer Information Division,
C RIKEN (The Institute of Pysical and Chemical Research)
C Email : himeno@postman.riken.go.jp
C ---------------------------------------------------------------
C You can adjust the size of this benchmark code to fit your target
C computer. In that case, please chose following sets of
C (mimax,mjmax,mkmax):
C small : 65,33,33
C small : 129,65,65
C midium: 257,129,129
C large : 513,257,257
C ext.large: 1025,513,513
C This program is to measure a computer performance in MFLOPS
C by using a kernel which appears in a linear solver of pressure
C Poisson eq. which appears in an incompressible Navier-Stokes solver.
C A point-Jacobi method is employed in this solver as this method can
C be easyly vectrized and be parallelized.
C ------------------
C Finite-difference method, curvilinear coodinate system
C Vectorizable and parallelizable on each grid point
C No. of grid points : imax x jmax x kmax including boundaries
C ------------------
C A,B,C:coefficient matrix, wrk1: source term of Poisson equation
C wrk2 : working area, OMEGA : relaxation parameter
C BND:control variable for boundaries and objects ( = 0 or 1)
C P: pressure
C -------------------

      INCLUDE "himeno_f77.h"
C
C     ttarget specifys the measuring period in sec
	PARAMETER (ttarget=60.0)

      REAL*8 cpu,cpu0,cpu1,gettime
      EXTERNAL gettime

      omega=0.8
      imax=mimax-1
      jmax=mjmax-1
      kmax=mkmax-1
CC Initializing matrixes
      call initmt
      write(*,*) ' mimax=',mimax,' mjmax=',mjmax,' mkmax=',mkmax
      write(*,*) ' imax=',imax,' jmax=',jmax,' kmax=',kmax
CC Start measuring
C
      nn=3
      write(*,*) ' Start rehearsal measurement process.'
      write(*,*) ' Measure the performance in 3 times.'
C
      cpu0=gettime()
C
C Jacobi iteration
      call jacobi(nn,gosa)
C
      cpu1= gettime()
      cpu = cpu1-cpu0
      flop=real(kmax-2)*real(jmax-2)*real(imax-2)*34.0*real(nn)
      xmflops2=flop/cpu*1.0e-6
      write(*,*) ' Gosa :',gosa
      write(*,*) '  MFLOPS:',xmflops2,'  time(s):',cpu
C
C     end the test loop

C AH: This estimate is now used to choose a number of iterations for the
C     main performance measurement (aiming to take around a minute)
      nn=int(ttarget/(cpu/3.0))
      write(*,*) 'Now, start the actual measurement process.'
      write(*,*) 'The loop will be excuted in',nn,' times.'
      write(*,*) 'This will take about one minute.'
      write(*,*) 'Wait for a while.'
C
C Jacobi iteration
      cpu0=gettime()
      call jacobi(nn,gosa)
C
      cpu1= gettime()
      cpu = cpu1-cpu0
      flop=real(kmax-2)*real(jmax-2)*real(imax-2)*34.0*real(nn)
      xmflops2=flop*1.0e-6/cpu
C
CCC      xmflops2=nflop/cpu*1.0e-6*float(nn)
C
      write(*,*) ' Loop executed for ',nn,' times'
      write(*,*) ' Gosa :',gosa
      write(*,*) ' MFLOPS:',xmflops2, '  time(s):',cpu
      score=xmflops2/82.84
      write(*,*) ' Score based on Pentium III 600MHz :',score
C
c      pause
c      stop
      END
C
C
C**************************************************************
      subroutine initmt
C**************************************************************

      INCLUDE "himeno_f77.h"

C TODO: Implement data initialization with OpenACC on device

C TODO: Implement computation with OpenACC on device

      do k=1,mkmax
         do j=1,mjmax
            do i=1,mimax
               a(i,j,k,1)=0.0
               a(i,j,k,2)=0.0
               a(i,j,k,3)=0.0
               a(i,j,k,4)=0.0
               b(i,j,k,1)=0.0
               b(i,j,k,2)=0.0
               b(i,j,k,3)=0.0
               c(i,j,k,1)=0.0
               c(i,j,k,2)=0.0
               c(i,j,k,3)=0.0
               p(i,j,k) =0.0
               wrk1(i,j,k)=0.0
               bnd(i,j,k)=0.0
            enddo
         enddo
      enddo
C
      do k=1,kmax
         do j=1,jmax
            do i=1,imax
               a(i,j,k,1)=1.0
               a(i,j,k,2)=1.0
               a(i,j,k,3)=1.0
               a(i,j,k,4)=1.0/6.0
               b(i,j,k,1)=0.0
               b(i,j,k,2)=0.0
               b(i,j,k,3)=0.0
               c(i,j,k,1)=1.0
               c(i,j,k,2)=1.0
               c(i,j,k,3)=1.0
               p(i,j,k) =float((k-1)*(k-1))/float((kmax-1)*(kmax-1))
               wrk1(i,j,k)=0.0
               bnd(i,j,k)=1.0
            enddo
         enddo
      enddo
C
      return
      end
C
C*************************************************************
      subroutine jacobi(nn,gosa)
C*************************************************************

      INCLUDE "himeno_f77.h"

C TODO: Implement data initialization with OpenACC on device

      DO loop=1,nn
         gosa=0.0
C
C TODO: Implement computation with OpenACC on device
         gosa1= 0.0
         DO K=2,kmax-1
            DO J=2,jmax-1
               DO I=2,imax-1
                  S0=a(I,J,K,1)*p(I+1,J,K)+a(I,J,K,2)*p(I,J+1,K)
     1                 +a(I,J,K,3)*p(I,J,K+1)
     2                 +b(I,J,K,1)*(p(I+1,J+1,K)-p(I+1,J-1,K)
     3                 -p(I-1,J+1,K)+p(I-1,J-1,K))
     4                 +b(I,J,K,2)*(p(I,J+1,K+1)-p(I,J-1,K+1)
     5                 -p(I,J+1,K-1)+p(I,J-1,K-1))
     6                 +b(I,J,K,3)*(p(I+1,J,K+1)-p(I-1,J,K+1)
     7                 -p(I+1,J,K-1)+p(I-1,J,K-1))
     8                 +c(I,J,K,1)*p(I-1,J,K)+c(I,J,K,2)*p(I,J-1,K)
     9                 +c(I,J,K,3)*p(I,J,K-1)+wrk1(I,J,K)
                  SS=(S0*a(I,J,K,4)-p(I,J,K))*bnd(I,J,K)
                  GOSA1=GOSA1+SS*SS
                  wrk2(I,J,K)=p(I,J,K)+OMEGA *SS
               enddo
            enddo
         enddo

C TODO: Implement computation with OpenACC on device
         DO K=2,kmax-1
            DO J=2,jmax-1
               DO I=2,imax-1
                  p(I,J,K)=wrk2(I,J,K)
               enddo
            enddo
         enddo

         gosa= gosa + gosa1

C
      enddo

      return
      end

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

C AH: Added this function to provide timing.
C     It uses Fortran90.

C*************************************************************
      function gettime() result(rtime)
C*************************************************************

      implicit none

      integer(kind=selected_int_kind(18)) :: ic,ir,im
      real(kind=8) :: rtime

      call system_clock(ic,ir,im)

      rtime= real(ic,8)/real(ir,8)

      end function


*> \brief \b DNPTF2 computes the LU factorization of a general m-by-n matrix using partial pivoting with row interchanges (unblocked algorithm).
*
*  =========== DOCUMENTATION ===========
*
*  Definition:
*  ===========
*
*       SUBROUTINE DNPTF2( M, N, A, LDA, INFO )
*
*       .. Scalar Arguments ..
*       INTEGER            INFO, LDA, M, N
*       ..
*       .. Array Arguments ..
*       DOUBLE PRECISION   A( LDA, * )
*       ..
*
*
*> \par Purpose:
*  =============
*>
*> \verbatim
*>
*> DNPTF2 computes an LU factorization of a general m-by-n matrix A
*> without pivoting.
*>
*> The factorization has the form
*>    A = L * U
*> where L is lower triangular with unit diagonal elements (lower
*> trapezoidal if m > n), and U is upper triangular (upper trapezoidal if
*> m < n).
*>
*> This is the right-looking Level 2 BLAS version of the algorithm.
*> \endverbatim
*
*  Arguments:
*  ==========
*
*> \param[in] M
*> \verbatim
*>          M is INTEGER
*>          The number of rows of the matrix A.  M >= 0.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*>          N is INTEGER
*>          The number of columns of the matrix A.  N >= 0.
*> \endverbatim
*>
*> \param[in,out] A
*> \verbatim
*>          A is DOUBLE PRECISION array, dimension (LDA,N)
*>          On entry, the m by n matrix to be factored.
*>          On exit, the factors L and U from the factorization
*>          A = L*U; the unit diagonal elements of L are not stored.
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*>          LDA is INTEGER
*>          The leading dimension of the array A.  LDA >= max(1,M).
*> \endverbatim
*>
*> \param[out] INFO
*> \verbatim
*>          INFO is INTEGER
*>          = 0: successful exit
*>          < 0: if INFO = -k, the k-th argument had an illegal value
*>          > 0: if INFO = k, U(k,k) is exactly zero. The factorization
*>               has been completed, but the factor U is exactly
*>               singular, and division by zero will occur if it is used
*>               to solve a system of equations.
*> \endverbatim
*
*  Authors:
*  ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date March 2015
*
*  =====================================================================
      SUBROUTINE DNPTF2( M, N, A, LDA, INFO )
*
*  -- Modified LAPACK computational routine (version 3.4.2) --
*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*     September 2012
*
*     .. Scalar Arguments ..
      INTEGER            INFO, LDA, M, N
*     ..
*     .. Array Arguments ..
      DOUBLE PRECISION   A( LDA, * )
*     ..
*
*  =====================================================================
*
*     .. Parameters ..
      DOUBLE PRECISION   ONE, ZERO
      PARAMETER          ( ONE = 1.0D+0, ZERO = 0.0D+0 )
*     ..
*     .. Local Scalars ..
      DOUBLE PRECISION   SFMIN, AJJ
      INTEGER            I, J
*     ..
*     .. External Functions ..
      LOGICAL            DISNAN
      DOUBLE PRECISION   DLAMCH
      EXTERNAL           DLAMCH
*     ..
*     .. External Subroutines ..
      EXTERNAL           DGER, DSCAL, XERBLA
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          MAX, MIN
*     ..
*     .. Executable Statements ..
*
*     Test the input parameters.
*
      INFO = 0
      IF( M.LT.0 ) THEN
         INFO = -1
      ELSE IF( N.LT.0 ) THEN
         INFO = -2
      ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
         INFO = -4
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DGETF2', -INFO )
         RETURN
      END IF
*
*     Quick return if possible
*
      IF( M.EQ.0 .OR. N.EQ.0 )
     $   RETURN
*
*     Compute machine safe minimum
*
      SFMIN = DLAMCH('S')
*
      DO 10 J = 1, MIN( M, N )
*
*        Test for singularity.
*
         AJJ = A( J, J )
         IF( AJJ.EQ.ZERO.OR.DISNAN( AJJ ) ) THEN
            GO TO 30
         END IF
*
*        Compute elements J+1:M of J-th column.
*
         IF( J.LT.M ) THEN
            IF( ABS( AJJ ) .GE. SFMIN ) THEN
               CALL DSCAL( M-J, ONE / AJJ, A( J+1, J ), 1 )
            ELSE
               DO 20 I = 1, M-J
                  A( J+I, J ) = A( J+I, J ) / AJJ
   20          CONTINUE
            END IF
         END IF
*
         IF( J.LT.MIN( M, N ) ) THEN
*
*           Update trailing submatrix.
*
            CALL DGER( M-J, N-J, -ONE, A( J+1, J ), 1, A( J, J+1 ), LDA,
     $                 A( J+1, J+1 ), LDA )
         END IF
   10 CONTINUE
      GO TO 40
   30 CONTINUE
      INFO = J
   40 CONTINUE
      RETURN
*
*     End of DNPTF2
*
      END


*     MB04XD EXAMPLE PROGRAM TEXT
*     Copyright (c) 2002-2020 NICONET e.V.
*
*     .. Parameters ..
      DOUBLE PRECISION ZERO
      PARAMETER        ( ZERO = 0.0D0 )
      INTEGER          NIN, NOUT
      PARAMETER        ( NIN = 5, NOUT = 6 )
      INTEGER          MMAX, NMAX
      PARAMETER        ( MMAX = 20, NMAX = 20 )
      INTEGER          LDA, LDU, LDV
      PARAMETER        ( LDA = MMAX, LDU = MMAX, LDV = NMAX )
      INTEGER          MAXMN, MNMIN
      PARAMETER        ( MAXMN = MAX( MMAX, NMAX ),
     $                   MNMIN = MIN( MMAX, NMAX ) )
      INTEGER          LENGQ
      PARAMETER        ( LENGQ = 2*MNMIN-1 )
      INTEGER          LDWORK
      PARAMETER        ( LDWORK = MAX( 2*NMAX, NMAX*( NMAX+1 )/2 )
     $                          + MAX( 2*MNMIN + MAXMN, 8*MNMIN - 5 ) )
*     .. Local Scalars ..
      DOUBLE PRECISION RELTOL, THETA, THETA1, TOL
      INTEGER          I, INFO, IWARN, J, K, LOOP, M, MINMN, N, NCOLU,
     $                 NCOLV, RANK, RANK1
      CHARACTER*1      JOBU, JOBV
      LOGICAL          LJOBUA, LJOBUS, LJOBVA, LJOBVS, WANTU, WANTV
*     .. Local Arrays ..
      DOUBLE PRECISION A(LDA,NMAX), DWORK(LDWORK), Q(LENGQ),
     $                 U(LDU,MMAX), V(LDV,NMAX)
      LOGICAL          INUL(MAXMN)
*     .. External Functions ..
      LOGICAL          LSAME
      EXTERNAL         LSAME
*     .. External Subroutines ..
      EXTERNAL         MB04XD
*     .. Intrinsic Functions ..
      INTRINSIC        MAX, MIN
*     .. Executable Statements ..
*
      WRITE ( NOUT, FMT = 99999 )
*     Skip the heading in the data file and read the data.
      READ ( NIN, FMT = '()' )
      READ ( NIN, FMT = * ) M, N, RANK, THETA, TOL, RELTOL, JOBU, JOBV
      IF ( M.LT.0 .OR. M.GT.MMAX ) THEN
         WRITE ( NOUT, FMT = 99983 ) M
      ELSE IF ( N.LT.0 .OR. N.GT.NMAX ) THEN
         WRITE ( NOUT, FMT = 99982 ) N
      ELSE IF ( RANK.GT.MNMIN ) THEN
         WRITE ( NOUT, FMT = 99981 ) RANK
      ELSE IF ( RANK.LT.0 .AND. THETA.LT.ZERO ) THEN
         WRITE ( NOUT, FMT = 99980 ) THETA
      ELSE
         READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,M )
         RANK1 = RANK
         THETA1 = THETA
*        Compute a basis for the left and right singular subspace of A.
         CALL MB04XD( JOBU, JOBV, M, N, RANK, THETA, A, LDA, U, LDU, V,
     $                LDV, Q, INUL, TOL, RELTOL, DWORK, LDWORK, IWARN,
     $                INFO )
*
         IF ( INFO.NE.0 ) THEN
            WRITE ( NOUT, FMT = 99998 ) INFO
         ELSE
            IF ( IWARN.NE.0 ) THEN
               WRITE ( NOUT, FMT = 99997 ) IWARN
               WRITE ( NOUT, FMT = 99996 ) RANK
            ELSE
               IF ( RANK1.LT.0 ) WRITE ( NOUT, FMT = 99996 ) RANK
            END IF
            IF ( THETA1.LT.ZERO ) WRITE ( NOUT, FMT = 99995 ) THETA
            LJOBUA = LSAME( JOBU, 'A' )
            LJOBUS = LSAME( JOBU, 'S' )
            LJOBVA = LSAME( JOBV, 'A' )
            LJOBVS = LSAME( JOBV, 'S' )
            WANTU = LJOBUA.OR.LJOBUS
            WANTV = LJOBVA.OR.LJOBVS
            WRITE ( NOUT, FMT = 99994 )
            MINMN = MIN( M, N )
            LOOP = MINMN - 1
            DO 20 I = 1, LOOP
               K = I + MINMN
               WRITE ( NOUT, FMT = 99993 ) I, I, Q(I), I, I + 1, Q(K)
   20       CONTINUE
            WRITE ( NOUT, FMT = 99992 ) MINMN, MINMN, Q(MINMN)
            IF ( WANTU ) THEN
               NCOLU = M
               IF ( LJOBUS ) NCOLU = MINMN
               WRITE ( NOUT, FMT = 99986 )
               DO 40 I = 1, M
                  WRITE ( NOUT, FMT = 99985 ) ( U(I,J), J = 1,NCOLU )
   40          CONTINUE
               WRITE ( NOUT, FMT = 99991 ) NCOLU
               WRITE ( NOUT, FMT = 99990 )
               DO 60 I = 1, NCOLU
                  WRITE ( NOUT, FMT = 99989 ) I, INUL(I)
   60          CONTINUE
            END IF
            IF ( WANTV ) THEN
               NCOLV = N
               IF ( LJOBVS ) NCOLV = MINMN
               WRITE ( NOUT, FMT = 99984 )
               DO 80 I = 1, N
                  WRITE ( NOUT, FMT = 99985 ) ( V(I,J), J = 1,NCOLV )
   80          CONTINUE
               WRITE ( NOUT, FMT = 99988 ) NCOLV
               WRITE ( NOUT, FMT = 99987 )
               DO 100 J = 1, NCOLV
                  WRITE ( NOUT, FMT = 99989 ) J, INUL(J)
  100          CONTINUE
            END IF
         END IF
      END IF
      STOP
*
99999 FORMAT (' MB04XD EXAMPLE PROGRAM RESULTS',/1X)
99998 FORMAT (' INFO on exit from MB04XD = ',I2)
99997 FORMAT (' IWARN on exit from MB04XD = ',I2,/)
99996 FORMAT (' The computed rank of matrix A = ',I3,/)
99995 FORMAT (' The computed value of THETA = ',F7.4,/)
99994 FORMAT (' The elements of the partially diagonalized bidiagonal ',
     $       'matrix are',/)
99993 FORMAT (2(' (',I1,',',I1,') = ',F7.4,2X))
99992 FORMAT (' (',I1,',',I1,') = ',F7.4,/)
99991 FORMAT (/' Left singular subspace corresponds to the i-th column',
     $       '(s) of U for which ',/' INUL(i) = .TRUE., i = 1,...,',I1,
     $       /)
99990 FORMAT ('  i    INUL(i)',/)
99989 FORMAT (I3,L8)
99988 FORMAT (/' Right singular subspace corresponds to the j-th colum',
     $       'n(s) of V for which ',/' INUL(j) = .TRUE., j = 1,...,',I1,
     $       /)
99987 FORMAT ('  j    INUL(j)',/)
99986 FORMAT (' Matrix U',/)
99985 FORMAT (20(1X,F8.4))
99984 FORMAT (/' Matrix V',/)
99983 FORMAT (/' M is out of range.',/' M = ',I5)
99982 FORMAT (/' N is out of range.',/' N = ',I5)
99981 FORMAT (/' RANK is out of range.',/' RANK = ',I5)
99980 FORMAT (/' THETA must be at least zero.',/' THETA = ',F8.4)
      END


MODULE testcases_3_4_5_6

  !=======================================================================
  !
  !  Functions for setting up initial conditions for the dynamical core test cases 3-6
  !  The input parameters depend on the test case (see comments for each test case below).
  !
  !  Given longitude (radians), latitude (radians), eta (pressure) and rotation_angle (degrees)
  !  the functions will return temperature, surface geopotential, zonal and meridional wind
  !  components, respectively.
  !
  !  Author: Christiane Jablonowski (University of Michigan, cjablono@umich.edu)
  !
  !  May/5/2008
  !
  !=======================================================================

implicit none
!=======================================================================
!  physical constants
!=======================================================================
  integer, parameter :: r8 = SELECTED_REAL_KIND(12) ! 8 byte real

  real(r8), parameter ::           &
       Rd         = 287.04_r8,     &             ! gas constant J/(K kg)
       cp         = 1004.64_r8,    &             ! specific heat at constant pressure J/(K kg)
       kappa      = Rd/cp,         &             ! kappa = 2/7
       g          = 9.80616_r8,    &             ! gravitational acceleration (m/s^2)
       a          = 6371229._r8,   &             ! Earth's radius in m
       pi         = 3.14159265358979323846_r8,&  ! pi
       omega      = 2._r8*pi/86164._r8, &        ! Earth's angular velocity 1/s
       pih        = pi*0.5_r8,     &             ! pi/2
       deg2rad    = pi/180._r8

CONTAINS

!==========================================================================================
! pure 3D advection, time-dependent
!==========================================================================================
  SUBROUTINE advection (tracer_variant, lon, lat, height, rotation_angle,  &
                        u_wind, v_wind, temperature, surface_geopotential, &
                        surface_pressure, q5, q6)
!-----------------------------------------------------------------------
!     input parameters
!-----------------------------------------------------------------------
      character*2, intent(in) :: tracer_variant                          ! identifies test variant 'yy', here tracers
                                                                         ! e.g. 0 : no tracer, set to zero
                                                                         !      5 : tracer q5 only
                                                                         !     56 : both tracers q5 and q6
      real(r8), intent(in)  :: lon,                                     & ! longitude in radians
                               lat,                                     & ! latitude in radians
                               height,                                  & ! height of the level in m
                               rotation_angle                             ! alpha in degrees
!-----------------------------------------------------------------------
!     input parameters
!-----------------------------------------------------------------------
      real(r8), intent(out) :: u_wind,                                  & ! zonal wind in m/s
                               v_wind,                                  & ! meridional wind in m/s
                               temperature,                             & ! temperature in K
                               surface_geopotential,                    & ! surface geopotential in m^2/s^2
                               surface_pressure,                        & ! surface pressure in Pa
                               q5,                                      & ! tracer q5
                               q6                                         ! tracer q6
!-----------------------------------------------------------------------
!     test case parameters
!-----------------------------------------------------------------------
      real(r8), parameter :: p0      = 100000._r8,                      & ! reference pressure
                             u0      = (2._r8*pi*a)/(12._r8*86400._r8), & ! circumference / 12 days
                             tau     = 3._r8 * 86400._r8,               & ! period: 3 days expressed in s
                             omega_0 = pi*40000._r8 / tau,              & ! 0.4848 Pa/s
                             T0      = 300._r8,                         & ! constant temperature
                             H       = Rd * T0 / g,                     & ! scale height
                             RR      = 1/3._r8,                         & ! horizontal half width divided by 'a'
                             ZZ      = 1000._r8,                        & ! vertical half width
                             z0      = 4500._r8,                        & ! center point in z
                             lambda0 = 1.5_r8*pi,                       & ! center point in longitudes
                             phi0    = 0._r8,                           & ! center point in latitudes
                             slot    = 1._r8/8._r8                        ! half width of the slot in radians
!-----------------------------------------------------------------------
!     local variables
!-----------------------------------------------------------------------
      real(r8) :: alpha
      real(r8) :: sin_tmp, cos_tmp
      real(r8) :: d1, d2, s, r

      alpha = rotation_angle*deg2rad
!-----------------------------------------------------------------------
!    initialize the wind components
!-----------------------------------------------------------------------
      u_wind =  u0 * (cos(lat)*cos(alpha) + sin(lat)*cos(lon)*sin(alpha))
      v_wind = -u0 *  sin(lon) * sin(alpha)
!-----------------------------------------------------------------------
!     initialization of the vertical velocity:
!     must be implemented in the dynamical core
!-----------------------------------------------------------------------
!-----------------------------------------------------------------------
!     initialize T (temperature)
!-----------------------------------------------------------------------
      temperature = T0
!-----------------------------------------------------------------------
!     initialize surface geopotential
!-----------------------------------------------------------------------
      surface_geopotential = 0._r8
!-----------------------------------------------------------------------
!     initialize PS (surface pressure)
!-----------------------------------------------------------------------
      surface_pressure = p0
!-----------------------------------------------------------------------
!     Tracer variables
!-----------------------------------------------------------------------
      q5 = 0._r8   ! default
      q6 = 0._r8   ! default
!-----------------------------------------------------------------------
!     tracer q5
!-----------------------------------------------------------------------
      if (tracer_variant(1:1) == '5' .or. tracer_variant(2:2) == '5') then
        sin_tmp = sin(lat) * sin(phi0)
        cos_tmp = cos(lat) * cos(phi0)
        r  = ACOS (sin_tmp + cos_tmp*cos(lon-lambda0))       ! great circle distance without 'a'
        d1 = min( 1._r8, (r/RR)**2 + ((height-z0)/ZZ)**2 )
        q5 = 0.5_r8 * (1._r8 + cos(pi*d1))
      endif
!-----------------------------------------------------------------------
!     tracer q6
!-----------------------------------------------------------------------
      if (tracer_variant(1:1) == '6' .or. tracer_variant(2:2) == '6') then
        sin_tmp = sin(lat) * sin(phi0)
        cos_tmp = cos(lat) * cos(phi0)
        r  = ACOS (sin_tmp + cos_tmp*cos(lon-lambda0))       ! great circle distance without 'a'
        d2 = (r/RR)**2 + ((height-z0)/ZZ)**2
        if (d2 <= 1._r8) then
          q6 = 1._r8
        else
          q6 = 0._r8
        endif
        if ((height > z0) .and. ((phi0-slot) < lat .and. lat < (phi0+slot)) ) q6 = 0._r8   ! slotted ellipse
      endif
  end subroutine advection

!==========================================================================================
! Rossby_Haurwitz wave, wavenumber 4
!==========================================================================================
  SUBROUTINE Rossby_Haurwitz (lon, lat, pressure,                                &
                              u_wind, v_wind, temperature, surface_geopotential, &
                              surface_pressure)
!-----------------------------------------------------------------------
!     input parameters
!-----------------------------------------------------------------------
      real(r8), intent(in)  :: lon,                                     & ! longitude in radians
                               lat,                                     & ! latitude in radians
                               pressure                                   ! pressure at full model level in Pa
!-----------------------------------------------------------------------
!     input parameters
!-----------------------------------------------------------------------
      real(r8), intent(out) :: u_wind,                                  & ! zonal wind in m/s
                               v_wind,                                  & ! meridional wind in m/s
                               temperature,                             & ! temperature in K
                               surface_geopotential,                    & ! surface geopotential in m^2/s^2
                               surface_pressure                           ! surface pressure in Pa

!-----------------------------------------------------------------------
!     test case parameters
!-----------------------------------------------------------------------
      real(r8),parameter :: u0      = 50._r8,                          &   ! reference wind
                            T0      = 288._r8,                         &   ! reference temperature
                            n       = 4._r8,                           &   ! wavenumber
                            MM      = u0/(n*a),                        &   ! parameter M and p_ref=95500.
                            KK      = u0/(n*a),                        &   ! parameter K
                            gamma   = 0.0065_r8,                       &   ! lapse rate in K/m
                            p_ref   = 95500._r8                            ! reference pressure

!-----------------------------------------------------------------------
!     local
!-----------------------------------------------------------------------
      real(r8) :: tmp1, tmp2, tmp3
      real(r8) :: sin_lat, cos_lat, sin_slat, cos_slat
      real(r8) :: exponent_1, exponent_2
      real(r8) :: AA, BB, CC
      real(r8) :: phis_perturb

!-----------------------------------------------------------------------
!     initialize the wind components
!-----------------------------------------------------------------------
      cos_lat = cos(lat)
      sin_lat = sin(lat)
      tmp1 = a * MM * cos_lat
      tmp2 = a * KK * cos_lat**(n-1._r8)*(n*sin_lat**2 - cos_lat**2)
      tmp3 = -a * KK * n * cos_lat**(n-1._r8) * sin_lat
      u_wind = tmp1 + tmp2 * cos(n*lon)
      v_wind = tmp3 * sin(n*lon)
!-----------------------------------------------------------------------
!     initialize surface geopotential
!-----------------------------------------------------------------------
      surface_geopotential = 0._r8
!-----------------------------------------------------------------------
!     initialize surface pressure and temperature
!-----------------------------------------------------------------------
      tmp1       = gamma/(g*T0)
      tmp2       = a*a
      exponent_1 = g/(gamma*Rd)
      exponent_2 = (gamma*Rd)/g

      cos_lat = cos(lat)
      AA = tmp2 * (0.5_r8 * MM*(2._r8*omega+MM) * cos_lat**2 + 0.25_r8 * KK**2 * cos_lat**(2._r8*n) * &
                  ( (n+1._r8)*cos_lat**2 + (2._r8*n*n - n - 2._r8)) - 0.5_r8*n*n*KK**2 * cos_lat**(2._r8*(n-1)))
      BB = tmp2 * (2._r8*(omega+MM)*KK/((n+1._r8)*(n+2._r8)) * cos_lat**n * &
                   ( (n*n + 2._r8*n +2._r8) - (n+1._r8)**2 * cos_lat**2 ))
      CC = tmp2 * (0.25_r8 * KK**2 * cos_lat**(2._r8*n) * ( (n+1._r8)*cos_lat**2 - (n+2._r8)))
      phis_perturb = AA + BB * cos(n*lon) + CC * cos(2._r8*n*lon)
      surface_pressure = p_ref * (1._r8 + tmp1*phis_perturb)**exponent_1   ! surface pressure
      temperature      = T0 * (pressure/p_ref)**exponent_2                 ! temperature

  end subroutine Rossby_Haurwitz

!==========================================================================================
! Mountain induced Rossby wave
!==========================================================================================
  SUBROUTINE mountain_Rossby (choice, lon, lat, pressure,                        &
                              u_wind, v_wind, temperature, surface_geopotential, &
                              surface_pressure)
!-----------------------------------------------------------------------
!     input parameters
!-----------------------------------------------------------------------
      integer, intent(in)   :: choice                                     ! identifies test variant 'x'
                                                                          ! e.g. 0 : gaussian hill mountian
                                                                          !      1 : cylindrical step-function hill
      real(r8), intent(in)  :: lon,                                     & ! longitude in radians
                               lat,                                     & ! latitude in radians
                               pressure                                   ! pressure at full model level in Pa
!-----------------------------------------------------------------------
!     input parameters
!-----------------------------------------------------------------------
      real(r8), intent(out) :: u_wind,                                  & ! zonal wind in m/s
                               v_wind,                                  & ! meridional wind in m/s
                               temperature,                             & ! temperature in K
                               surface_geopotential,                    & ! surface geopotential in m^2/s^2
                               surface_pressure                           ! surface pressure in Pa
!-----------------------------------------------------------------------
!     test case parameters
!-----------------------------------------------------------------------
      real(r8),parameter :: u0      = 20._r8,                          &   ! 20 m/s
                            T0      = 288._r8,                         &   ! temperature
                            N2      = g*g/(cp*T0),                     &   ! squared Brunt Vaisala frequency N^2
                            h0      = 2000._r8,                        &   ! amplitude of the mountain, 2km
                            d       = 1500.e3_r8,                      &   ! half width 1500 km
                            lambda0 = 0.5_r8*pi,                       &   ! center point in longitudes
                            phi0    = pi/6._r8,                        &   ! center point in latitudes
                            p_sp    = 93000._r8                            ! pressure at the South Pole in Pa
!-----------------------------------------------------------------------
!   local variables
!-----------------------------------------------------------------------
      real(r8) :: sin_tmp, cos_tmp
      real(r8) :: tmp1, tmp2, tmp3
      real(r8) :: r

!-----------------------------------------------------------------------
!    initialize the wind components
!-----------------------------------------------------------------------
      u_wind = u0 * cos(lat)
      v_wind = 0._r8
!-----------------------------------------------------------------------
!     initialize T (temperature)
!-----------------------------------------------------------------------
      temperature = T0
!-----------------------------------------------------------------------
!     initialize surface geopotential and surface pressure
!-----------------------------------------------------------------------
      tmp1 = (a * N2 * u0)/(2._r8 * g*g * kappa) * (u0/a + 2._r8 * omega)
      tmp2 = N2 / (g*g * kappa)

      sin_tmp = sin(lat) * sin(phi0)
      cos_tmp = cos(lat) * cos(phi0)
      tmp3 = tmp1*((sin(lat))**2 - 1._r8)
      r = a * ACOS (sin_tmp + cos_tmp*cos(lon-lambda0))   ! great circle distance with 'a'
      surface_geopotential = g*h0 * exp(-(r/d)**2)        ! Gaussian profile of the mountain

      if (choice==1) then
        surface_geopotential = 0.0
        sin_tmp = sin(lat) * sin(phi0)
        cos_tmp = cos(lat) * cos(phi0)
        tmp3 = tmp1*((sin(lat))**2 - 1._r8)
        r = a * ACOS (sin_tmp + cos_tmp*cos(lon-lambda0))   ! great circle distance with 'a'
        if (r<=d) surface_geopotential = g*h0               ! Cylindrical step-function profile of the mountain
      endif

      surface_pressure     = p_sp * exp( -tmp3 - tmp2*surface_geopotential)

  end subroutine mountain_Rossby

!==========================================================================================
! gravity waves
!==========================================================================================
  SUBROUTINE gravity_wave (choice, lon, lat, height,                          &
                           u_wind, v_wind, temperature, surface_geopotential, &
                           surface_pressure, pressure)
!-----------------------------------------------------------------------
!     input parameters
!-----------------------------------------------------------------------
      integer, intent(in)   :: choice                                     ! identifies test variant 'x'
                                                                          ! e.g. 0 : no Coriolis, N=0.01 1/s, u0=0  m/s
                                                                          !      1 : no Coriolis, N=0.01 1/s, u0=40 m/s
      real(r8), intent(in)  :: lon,                                     & ! longitude in radians
                               lat,                                     & ! latitude in radians
                               height                                     ! height of the layer in meters
!-----------------------------------------------------------------------
!     input parameters
!-----------------------------------------------------------------------
      real(r8), intent(out) :: u_wind,                                  & ! zonal wind in m/s
                               v_wind,                                  & ! meridional wind in m/s
                               temperature,                             & ! temperature in K
                               surface_geopotential,                    & ! surface geopotential in m^2/s^2
                               surface_pressure
      real(r8), optional, intent(out) :: pressure
!-----------------------------------------------------------------------
!     test case parameters
!-----------------------------------------------------------------------
      real(r8),parameter :: p0      = 100000._r8,                      & ! reference pressure
                            T0      = 300._r8,                         & ! reference temperature
                            RR      = a/3._r8,                         & ! half width
                            Lz      = 20.e3_r8,                        & ! vertical wave length, 20 km
                            delta_theta = 10._r8                         ! potential temperature perturbation amplitude

!-----------------------------------------------------------------------
!     local variables
!-----------------------------------------------------------------------
      real(r8) :: sin_tmp, cos_tmp
      real(r8) :: tmp1, tmp2, tmp3
      real(r8) :: theta                                                    ! potential temperature
      real(r8) :: theta_mean
      real(r8) :: pres                                                     ! pressure
      real(r8) :: r                                                        ! great circle distance

!-----------------------------------------------------------------------
!     more test case parameters
!-----------------------------------------------------------------------
      real(r8) :: N2,                                                  &   ! squared Brunt-Vaisala frequency
                  S,                                                   &   ! parameter
                  u0,                                                  &   ! background wind speed
                  lambda0,                                             &   ! center point in longitudes
                  phi0,                                                &   ! center point in latitudes
                  gw_omega,                                            &   ! rotation
                  p_eq

!-----------------------------------------------------------------------
!    initialize parameters
!-----------------------------------------------------------------------
      lambda0 = pi                                                         ! center point in longitudes
      p_eq    = p0                                                         ! surface pressure at the equator

      select case (choice)
      case (0)
        N2 = 1.e-4_r8                                                      ! squared Brunt Vaisala frequency N^2
        u0 = 0._r8                                                         ! background wind speed
        phi0 = 0._r8                                                       ! center point in latitudes (0 deg)
        gw_omega = 0._r8                                                   ! no rotation
      case (1)
        N2 = (g*g)/(cp*T0)                                                 ! squared Brunt Vaisala frequency N^2
        u0 = 0._r8                                                         ! background wind speed
        phi0 = 0._r8                                                       ! center point in latitudes (0 deg)
        gw_omega = 0._r8                                                   ! no rotation
      case (2)
        N2 = (g*g)/(cp*T0)                                                 ! squared Brunt Vaisala frequency N^2
        u0 = 40._r8                                                        ! background wind speed
        phi0 = 0._r8                                                       ! center point in latitudes (0 deg)
        gw_omega = 0._r8                                                   ! no rotation
      case (3)
        N2 = (g*g)/(cp*T0)                                                 ! squared  Brunt Vaisala frequency N^2
        u0 = 0._r8                                                         ! background wind speed
        phi0 = pi/4._r8                                                    ! center point in latitudes (45 deg)
        gw_omega = omega                                                   ! Earth's rotation
      end select
      S = g*g/(cp*N2)                                                      ! parameter

!-----------------------------------------------------------------------
!     initialize the wind components
!-----------------------------------------------------------------------
      u_wind = u0 * cos(lat)
      v_wind = 0._r8
!-----------------------------------------------------------------------
!     initialize surface geopotential
!-----------------------------------------------------------------------
      surface_geopotential = 0._r8
!-----------------------------------------------------------------------
!     initialize surface pressure
!-----------------------------------------------------------------------
      tmp1 = (a * N2 * u0)/(2._r8 * g*g * kappa) * (u0/a + 2._r8 * gw_omega)
      surface_pressure = p_eq * exp( - tmp1*((sin(lat))**2) )
!-----------------------------------------------------------------------
!     initialize temperature
!-----------------------------------------------------------------------
    ! height  = -(g/(N2)) * log( (T0/S) * ( (pressure/p0)**kappa - 1._r8 ) + 1._r8 )
      pres    = p0 * ( (1._r8 - S/T0) + S/T0 * exp(- (N2*height)/g) )**(cp/Rd)
      if ( present(pressure) ) pressure = pres
      sin_tmp = sin(lat) * sin(phi0)
      cos_tmp = cos(lat) * cos(phi0)
      theta_mean = T0 /( T0/S * ((pres/p0)**kappa - 1._r8) + 1._r8 )
      r = a * ACOS (sin_tmp + cos_tmp*cos(lon-lambda0))     ! great circle distance with radius
      if (r < RR) then
        tmp1 = 0.5_r8 * (1._r8 + cos(pi*r/RR))
      else
        tmp1 = 0._r8
      endif
      theta = theta_mean + delta_theta * tmp1 * sin(2._r8*pi*height/Lz)
      temperature = theta * (pres/p0)**kappa

  end subroutine gravity_wave

END MODULE testcases_3_4_5_6


      SUBROUTINE TRANS(R,V,T)
C
C
C      THE PURPOSE OF TRANS IS TO COMPUTE THE TRANSFORMATION
C      MATRIX FROM GEOCENTRIC INERTIAL TO LOCAL ORBITAL COORDINATES
C
C      ARGUMENTS IN THE CALLING SEQUENCE ARE DEFINED AS FOLLOWS--
C
C      ARGUMENT   TYPE   DIMENSION   I/O      DEFINITION
C
C         R        R*8      3         I        POSITION (INERTIAL)
C         V        R*8      3         I        VELOCITY (INERTIAL)
C         T        R*8     3,3        O        TRANSFORMATION MATRIX
C                                              (INERTIAL TO LOCAL
C                                                 ORBITAL)
      IMPLICIT REAL*8(A-H,O-Z)
      DIMENSION R(3),V(3),C(3),T1(3),T(3,3),R1(3),V1(3)
C  T IS TRANSFORMATION MATRIX FROM GEOCENTRIC INERTIAL
C  TO LOCAL ORBITAL SYSTEM
C
C   SAVE INITIAL VALUES
C
      DO 10 I=1,3
      R1(I)=R(I)
      V1(I)=V(I)
   10 CONTINUE
      CALL UNIVEC(R1)
      CALL UNIVEC(V1)
      CALL CROSS(V1,R1,C)
      CALL UNIVEC(C)
      CALL CROSS(R1,C,T1)
      DO 1 I=1,3
      T(1,I)=T1(I)
      T(2,I)=C(I)
      T(3,I)=-R1(I)
    1 CONTINUE
      RETURN
      END


*DECK GAUS8
      SUBROUTINE GAUS8 (FUN, A, B, ERR, ANS, IERR)
C***BEGIN PROLOGUE  GAUS8
C***PURPOSE  Integrate a real function of one variable over a finite
C            interval using an adaptive 8-point Legendre-Gauss
C            algorithm.  Intended primarily for high accuracy
C            integration or integration of smooth functions.
C***LIBRARY   SLATEC
C***CATEGORY  H2A1A1
C***TYPE      SINGLE PRECISION (GAUS8-S, DGAUS8-D)
C***KEYWORDS  ADAPTIVE QUADRATURE, AUTOMATIC INTEGRATOR,
C             GAUSS QUADRATURE, NUMERICAL INTEGRATION
C***AUTHOR  Jones, R. E., (SNLA)
C***DESCRIPTION
C
C     Abstract
C        GAUS8 integrates real functions of one variable over finite
C        intervals using an adaptive 8-point Legendre-Gauss algorithm.
C        GAUS8 is intended primarily for high accuracy integration
C        or integration of smooth functions.
C
C     Description of Arguments
C
C        Input--
C        FUN - name of external function to be integrated.  This name
C              must be in an EXTERNAL statement in the calling program.
C              FUN must be a REAL function of one REAL argument.  The
C              value of the argument to FUN is the variable of
C              integration which ranges from A to B.
C        A   - lower limit of integration
C        B   - upper limit of integration (may be less than A)
C        ERR - is a requested pseudorelative error tolerance.  Normally
C              pick a value of ABS(ERR) so that STOL .LT. ABS(ERR) .LE.
C              1.0E-3 where STOL is the single precision unit roundoff
C              R1MACH(4).  ANS will normally have no more error than
C              ABS(ERR) times the integral of the absolute value of
C              FUN(X).  Usually, smaller values for ERR yield more
C              accuracy and require more function evaluations.
C
C              A negative value for ERR causes an estimate of the
C              absolute error in ANS to be returned in ERR.  Note that
C              ERR must be a variable (not a constant) in this case.
C              Note also that the user must reset the value of ERR
C              before making any more calls that use the variable ERR.
C
C        Output--
C        ERR - will be an estimate of the absolute error in ANS if the
C              input value of ERR was negative.  (ERR is unchanged if
C              the input value of ERR was non-negative.)  The estimated
C              error is solely for information to the user and should
C              not be used as a correction to the computed integral.
C        ANS - computed value of integral
C        IERR- a status code
C            --Normal codes
C               1 ANS most likely meets requested error tolerance,
C                 or A=B.
C              -1 A and B are too nearly equal to allow normal
C                 integration.  ANS is set to zero.
C            --Abnormal code
C               2 ANS probably does not meet requested error tolerance.
C
C***REFERENCES  (NONE)
C***ROUTINES CALLED  I1MACH, R1MACH, XERMSG
C***REVISION HISTORY  (YYMMDD)
C   810223  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   890531  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900315  CALLs to XERROR changed to CALLs to XERMSG.  (THJ)
C   900326  Removed duplicate information from DESCRIPTION section.
C           (WRB)
C***END PROLOGUE  GAUS8
      INTEGER IERR, K, KML, KMX, L, LMN, LMX, LR, MXL, NBITS,
     1 NIB, NLMN, NLMX
      INTEGER I1MACH
      REAL A, AA, AE, ANIB, ANS, AREA, B, C, CE, EE, EF, EPS, ERR, EST,
     1 GL, GLR, GR, HH, SQ2, TOL, VL, VR, W1, W2, W3, W4, X1, X2, X3,
     2 X4, X, H
      REAL R1MACH, G8, FUN
      DIMENSION AA(30), HH(30), LR(30), VL(30), GR(30)
      SAVE X1, X2, X3, X4, W1, W2, W3, W4, SQ2,
     1 NLMN, KMX, KML
      DATA X1, X2, X3, X4/
     1     1.83434642495649805E-01,     5.25532409916328986E-01,
     2     7.96666477413626740E-01,     9.60289856497536232E-01/
      DATA W1, W2, W3, W4/
     1     3.62683783378361983E-01,     3.13706645877887287E-01,
     2     2.22381034453374471E-01,     1.01228536290376259E-01/
      DATA SQ2/1.41421356E0/
      DATA NLMN/1/,KMX/5000/,KML/6/
      G8(X,H)=H*((W1*(FUN(X-X1*H) + FUN(X+X1*H))
     1           +W2*(FUN(X-X2*H) + FUN(X+X2*H)))
     2          +(W3*(FUN(X-X3*H) + FUN(X+X3*H))
     3           +W4*(FUN(X-X4*H) + FUN(X+X4*H))))
C***FIRST EXECUTABLE STATEMENT  GAUS8
C
C     Initialize
C
      K = I1MACH(11)
      ANIB = R1MACH(5)*K/0.30102000E0
      NBITS = ANIB
      NLMX = MIN(30,(NBITS*5)/8)
      ANS = 0.0E0
      IERR = 1
      CE = 0.0E0
      IF (A .EQ. B) GO TO 140
      LMX = NLMX
      LMN = NLMN
      IF (B .EQ. 0.0E0) GO TO 10
      IF (SIGN(1.0E0,B)*A .LE. 0.0E0) GO TO 10
      C = ABS(1.0E0-A/B)
      IF (C .GT. 0.1E0) GO TO 10
      IF (C .LE. 0.0E0) GO TO 140
      ANIB = 0.5E0 - LOG(C)/0.69314718E0
      NIB = ANIB
      LMX = MIN(NLMX,NBITS-NIB-7)
      IF (LMX .LT. 1) GO TO 130
      LMN = MIN(LMN,LMX)
   10 TOL = MAX(ABS(ERR),2.0E0**(5-NBITS))/2.0E0
      IF (ERR .EQ. 0.0E0) TOL = SQRT(R1MACH(4))
      EPS = TOL
      HH(1) = (B-A)/4.0E0
      AA(1) = A
      LR(1) = 1
      L = 1
      EST = G8(AA(L)+2.0E0*HH(L),2.0E0*HH(L))
      K = 8
      AREA = ABS(EST)
      EF = 0.5E0
      MXL = 0
C
C     Compute refined estimates, estimate the error, etc.
C
   20 GL = G8(AA(L)+HH(L),HH(L))
      GR(L) = G8(AA(L)+3.0E0*HH(L),HH(L))
      K = K + 16
      AREA = AREA + (ABS(GL)+ABS(GR(L))-ABS(EST))
C     IF (L .LT. LMN) GO TO 11
      GLR = GL + GR(L)
      EE = ABS(EST-GLR)*EF
      AE = MAX(EPS*AREA,TOL*ABS(GLR))
      IF (EE-AE) 40, 40, 50
   30 MXL = 1
   40 CE = CE + (EST-GLR)
      IF (LR(L)) 60, 60, 80
C
C     Consider the left half of this level
C
   50 IF (K .GT. KMX) LMX = KML
      IF (L .GE. LMX) GO TO 30
      L = L + 1
      EPS = EPS*0.5E0
      EF = EF/SQ2
      HH(L) = HH(L-1)*0.5E0
      LR(L) = -1
      AA(L) = AA(L-1)
      EST = GL
      GO TO 20
C
C     Proceed to right half at this level
C
   60 VL(L) = GLR
   70 EST = GR(L-1)
      LR(L) = 1
      AA(L) = AA(L) + 4.0E0*HH(L)
      GO TO 20
C
C     Return one level
C
   80 VR = GLR
   90 IF (L .LE. 1) GO TO 120
      L = L - 1
      EPS = EPS*2.0E0
      EF = EF*SQ2
      IF (LR(L)) 100, 100, 110
  100 VL(L) = VL(L+1) + VR
      GO TO 70
  110 VR = VL(L+1) + VR
      GO TO 90
C
C     Exit
C
  120 ANS = VR
      IF ((MXL.EQ.0) .OR. (ABS(CE).LE.2.0E0*TOL*AREA)) GO TO 140
      IERR = 2
      CALL XERMSG ('SLATEC', 'GAUS8',
     +   'ANS is probably insufficiently accurate.', 3, 1)
      GO TO 140
  130 IERR = -1
      CALL XERMSG ('SLATEC', 'GAUS8',
     +   'A and B are too nearly equal to allow normal integration. $$'
     +   // 'ANS is set to zero and IERR to -1.', 1, -1)
  140 IF (ERR .LT. 0.0E0) ERR = CE
      RETURN
      END


	SUBROUTINE RU_TEMP  ( field, t, td, iret )
C************************************************************************
C* RU_TEMP								*
C*									*
C* This subroutine decodes a temperature/dewpoint field.  The field	*
C* is encoded as TTtDD where TT is temperature in degrees Celsius,	*
C* t is approximate tenths of degree and sign indicator, and DD is	*
C* the dewpoint depression in degrees Celsius.				*
C*									*
C* RU_TEMP ( FIELD, T, TD, IRET )					*
C*									*
C* Input parameters:							*
C*	FIELD		CHAR*		Encoded group			*
C*									*
C* Output parameters:							*
C*	T		REAL		Temperature			*
C*	TD		REAL		Dewpoint temperature		*
C*	IRET		INTEGER		Return code			*
C*					  0 = normal return		*
C**									*
C* Log:									*
C* M. desJardins/GSFC	 6/86						*
C************************************************************************
	INCLUDE		'GEMPRM.PRM'
C*
	CHARACTER*(*)	field
C------------------------------------------------------------------------
	iret = 0
C*
	t  = RMISSD
	td = RMISSD
C
C*	The first three digits of the field contain encoded temperature.
C*	If the temperature is missing (as indicated by a /) then the
C*	conversion to integer will fail.
C
	CALL ST_INTG  ( field (1:3), itemp, ier )
	IF  ( ier .eq. 0 )  THEN
C
C*	    If the integer is even, the temperature is positive.  Otherwise,
C*	    the temperature is negative.
C
	    isign = MOD ( itemp, 2 )
	    IF  ( isign .eq. 1 )  itemp = - itemp
	    t = FLOAT ( itemp ) / 10.
C
C*	    The last two digits contain the encoded dewpoint depression.
C
	    CALL ST_INTG ( field (4:5), idep, ier )
C
C*	    Check that the dewpoint value is not missing.
C
	    IF ( ier .eq. 0 ) THEN
C
C*		If the dewpoint given is less than 50, the dewpoint is
C*		given in tenths of a degree.  For numbers greater than
C*		55, the dewpoint is given in whole degrees plus 50.
C*		The values 51 - 55 are not used.
C
		IF  ( idep .le. 50 )  THEN
		    ddep = FLOAT ( idep ) / 10.
		  ELSE
		    ddep = FLOAT ( idep - 50 )
		END IF
		td = t - ddep
	    END IF
	END IF
C*
	RETURN
	END


      subroutine r8herm1ev(xget,x,nx,ilinx,f,ict,fval,ier)
C
C  evaluate a 1d cubic Hermite interpolant -- this is C1.
C
C  this subroutine calls two subroutines:
C     herm1x   -- find cell containing (xget,yget)
C     herm1fcn -- evaluate interpolant function and (optionally) derivatives
C
C  input arguments:
C  ================
C
!============
! idecl:  explicitize implicit INTEGER declarations:
      IMPLICIT NONE
      INTEGER, PARAMETER :: R8=SELECTED_REAL_KIND(12,100)
      INTEGER nx
!============
      REAL*8 xget                         ! target of this interpolation
      REAL*8 x(nx)                        ! ordered x grid
      integer ilinx                     ! ilinx=1 => assume x evenly spaced
C
      REAL*8 f(0:1,nx)                    ! function data
C
C       contents of f:
C
C  f(0,i) = f @ x(i)
C  f(1,i) = df/dx @ x(i)
C
      integer ict(2)                    ! code specifying output desired
C
C  ict(1)=1 -- return f  (0, don't)
C  ict(2)=1 -- return df/dx  (0, don't)
C
C output arguments:
C =================
C
      REAL*8 fval(*)                      ! output data
      integer ier                       ! error code =0 ==> no error
C
C  fval(1) receives the first output (depends on ict(...) spec)
C  fval(2) receives the second output (depends on ict(...) spec)
C
C  examples:
C    on input ict = [1,1]
C   on output fval= [f,df/dx]
C
C    on input ict = [1,0]
C   on output fval= [f] ... element 2 never referenced
C
C    on input ict = [0,1]
C   on output fval= [df/dx] ... element 2 never referenced
C
C  ier -- completion code:  0 means OK
C-------------------
C  local:
C
      integer i                         ! cell index
C
C  normalized displacement from (x(i)) corner of cell.
C    xparam=0 @x(i)  xparam=1 @x(i+1)
C
      REAL*8 xparam
C
C  cell dimensions and
C  inverse cell dimensions hxi = 1/(x(i+1)-x(i))
C
      REAL*8 hx
      REAL*8 hxi
C
C  0 .le. xparam .le. 1
C
C---------------------------------------------------------------------
C
      call r8herm1x(xget,x,nx,ilinx,i,xparam,hx,hxi,ier)
      if(ier.ne.0) return
c
      call r8herm1fcn(ict,1,1,fval,i,xparam,hx,hxi,f,nx)
C
      return
      end
C---------------------------------------------------------------------
c  herm1xy -- look up x zone
c
c  this is the "first part" of herm1ev, see comments, above.
c
      subroutine r8herm1x(xget,x,nx,ilinx,i,xparam,hx,hxi,ier)
c
c  input of herm1x
c  ===============
c
!============
! idecl:  explicitize implicit INTEGER declarations:
      IMPLICIT NONE
      INTEGER, PARAMETER :: R8=SELECTED_REAL_KIND(12,100)
      INTEGER nxm,ii
!============
! idecl:  explicitize implicit REAL declarations:
      REAL*8 zxget,zxtol
!============
      integer nx                        ! x array dimension
c
      REAL*8 xget                         ! target point
      REAL*8 x(nx)                        ! indep. coordinate, strict ascending
c
      integer ilinx                     ! =1:  x evenly spaced
c
c  output of herm1x
c  =================
      integer i                         ! index to cell containing target pt
c          on exit:  1.le.i.le.nx-1
c
c  normalized position w/in (i) cell (always btw 0 and 1):
c
      REAL*8 xparam                       ! (xget-x(i))/(x(i+1)-x(i))
c
c  grid spacing
c
      REAL*8 hx                           ! hx = x(i+1)-x(i)
c
c  inverse grid spacing:
c
      REAL*8 hxi                          ! 1/hx = 1/(x(i+1)-x(i))
c
      integer ier                       ! return ier.ne.0 on error
c
c------------------------------------
c
      ier=0
c
c  range check
c
      zxget=xget
      if((xget.lt.x(1)).or.(xget.gt.x(nx))) then
         zxtol=4.0E-7_r8*max(abs(x(1)),abs(x(nx)))
         if((xget.lt.x(1)-zxtol).or.(xget.gt.x(nx)+zxtol)) then
            ier=1
            write(6,1001) xget,x(1),x(nx)
 1001       format(' ?herm1ev:  xget=',1pe11.4,' out of range ',
     >         1pe11.4,' to ',1pe11.4)
         else
            if((xget.lt.x(1)-0.5_r8*zxtol).or.
     >         (xget.gt.x(nx)+0.5_r8*zxtol))
     >      write(6,1011) xget,x(1),x(nx)
 1011       format(' %herm1ev:  xget=',1pe15.8,' beyond range ',
     >         1pe15.8,' to ',1pe15.8,' (fixup applied)')
            if(xget.lt.x(1)) then
               zxget=x(1)
            else
               zxget=x(nx)
            endif
         endif
      endif
      if(ier.ne.0) return
c
c  now find interval in which target point lies..
c
      nxm=nx-1
c
      if(ilinx.eq.1) then
         ii=1+nxm*(zxget-x(1))/(x(nx)-x(1))
         i=min(nxm, ii)
         if(zxget.lt.x(i)) then
            i=i-1
         else if(zxget.gt.x(i+1)) then
            i=i+1
         endif
      else
         if((1.le.i).and.(i.lt.nxm)) then
            if((x(i).le.zxget).and.(zxget.le.x(i+1))) then
               continue  ! already have the zone
            else
               call r8zonfind(x,nx,zxget,i)
            endif
         else
            i=nx/2
            call r8zonfind(x,nx,zxget,i)
         endif
      endif
c
      hx=(x(i+1)-x(i))
c
      hxi=1.0_r8/hx
c
      xparam=(zxget-x(i))*hxi
c
      return
      end
C---------------------------------------------------------------------
C  evaluate C1 cubic Hermite function interpolation -- 1d fcn
C   --vectorized-- dmc 10 Feb 1999
C
      subroutine r8herm1fcn(ict,ivec,ivecd,
     >   fval,ii,xparam,hx,hxi,fin,nx)
C
C  input:
C
!============
! idecl:  explicitize implicit INTEGER declarations:
      IMPLICIT NONE
      INTEGER, PARAMETER :: R8=SELECTED_REAL_KIND(12,100)
      INTEGER nx,i,iadr
!============
! idecl:  explicitize implicit REAL declarations:
      REAL*8 xp,xpi,xp2,xpi2,ax,axbar,bx,bxbar,axp,axbarp,bxp,bxbarp
!============
      integer ict(2)                    ! requested output control
      integer ivec                      ! vector length
      integer ivecd                     ! vector dimension (1st dim of fval)
C
      integer ii(ivec)                  ! target cells
      REAL*8 xparam(ivec)
                                  ! normalized displacements in cells
C
      REAL*8 hx(ivec)                     ! grid spacing, and
      REAL*8 hxi(ivec)                    ! inverse grid spacing 1/(x(i+1)-x(i))
C
      REAL*8 fin(0:1,nx)                  ! Hermite dataset
C
C  output:
C
      REAL*8 fval(ivecd,*)                ! interpolation results
C
C  for detailed description of fin, ict and fval see subroutine
C  herm1ev comments.  Note ict is not vectorized -- the same output
C  is expected to be returned for all input vector data points.
C
C  note that the index inputs ii,jj and parameter inputs
C     xparam,yparam,hx,hxi,hy,hyi are vectorized, and the
C
C     output array fval has a vector ** 1st dimension ** whose
C     size must be given as a separate argument; ivecd.ge.ivec
C     expected!
C
C  to use this routine in scalar mode, pass in ivec=ivecd=1
C
C---------------
C  Hermite cubic basis functions
C  -->for function value matching
C     a(0)=0 a(1)=1        a'(0)=0 a'(1)=0
C   abar(0)=1 abar(1)=0  abar'(0)=0 abar'(1)=0
C
C   a(x)=-2*x**3 + 3*x**2    = x*x*(-2.0*x+3.0)
C   abar(x)=1-a(x)
C   a'(x)=-abar'(x)          = 6.0*x*(1.0-x)
C
C  -->for derivative matching
C     b(0)=0 b(1)=0          b'(0)=0 b'(1)=1
C   bbar(0)=0 bbar(1)=0  bbar'(0)=1 bbar'(1)=0
C
C     b(x)=x**3-x**2         b'(x)=3*x**2-2*x
C     bbar(x)=x**3-2*x**2+x  bbar'(x)=3*x**2-4*x+1
C
C   ...in x direction
C
      REAL*8 sum
      integer v
C
      do v=1,ivec
         i=ii(v)
         xp=xparam(v)
         xpi=1.0_r8-xp
         xp2=xp*xp
         xpi2=xpi*xpi
C
         iadr=0
C
C  get desired values:
C
         if(ict(1).eq.1) then
C
C  function value:
C
            iadr=iadr+1
C
C  Hermite basis functions
C
            ax=xp2*(3.0_r8-2.0_r8*xp)
            axbar=1.0_r8-ax
            bx=-xp2*xpi
            bxbar=xpi2*xp
C
            sum=axbar*fin(0,i) + ax*fin(0,i+1)
C
            sum=sum+hx(v)*(bxbar*fin(1,i) + bx*fin(1,i+1))
C
            fval(v,iadr)=sum
         endif
C
         if(ict(2).eq.1) then
C
C  df/dx:
C
            iadr=iadr+1
C
            axp=6.0_r8*xp*xpi
            axbarp=-axp
            bxp=xp*(3.0_r8*xp-2.0_r8)
            bxbarp=xpi*(3.0_r8*xpi-2.0_r8)
C
            sum=hxi(v)*(axbarp*fin(0,i) +axp*fin(0,i+1))
C
            sum=sum+ bxbarp*fin(1,i) + bxp*fin(1,i+1)
C
            fval(v,iadr)=sum
         endif
C
      enddo                             ! vector loop
C
      return
      end


!! --------------------------------------------------------------------------
!!
!!                            FyMcPack Example
!!
!!  Example : testDict
!!
!!      Initiaize dictionary with input file and get variables
!!
!!  Authors
!!      YoungMyung Choi, Ecole Centrale de Nantes
!!
!! --------------------------------------------------------------------------
    Program main

        use mfpGlobal
        use mfpGeneral
        use mfpGeometry

    Implicit None
        type(typDictionaryPtr)  :: surfDict
        class(typSurfMesh), allocatable :: surfMesh
        integer  :: iPanel, iLine, iGauss
        real(rp),dimension(3) :: moment
        Real(rp),dimension(3) :: tmpMoment
        real(rp) :: mx, my, mz

        !!... Intialize Dictionary
        Call surfDict%initialize("./", "surfMesh", ".dict")

        !!... Initialize SurfMesh
        Call initializeSurfMesh(surfMesh, surfDict%subDict("surfaceMesh"))

        !!... Test Gauss Point and Weight
        do iPanel = 1, surfMesh%nPanel
        ! do iPanel = 1, 1

            moment = 0.0_RP

            do iGauss = 1, surfMesh%panel(iPanel)%nGauss

                tmpMoment = surfMesh%panel(iPanel)%gWeight(iGauss) &
                          * surfMesh%panel(iPanel)%gPoint(iGauss)%vec()

                moment = moment + tmpMoment

            enddo

            mx = surfMesh%panel(iPanel)%area * surfMesh%panel(iPanel)%center%x()
            my = surfMesh%panel(iPanel)%area * surfMesh%panel(iPanel)%center%y()
            mz = surfMesh%panel(iPanel)%area * surfMesh%panel(iPanel)%center%z()

            write(*,*) moment(1), mx, (mx - moment(1)) / mx
            write(*,*) moment(2), my, (my - moment(2)) / my
            write(*,*) moment(3), mz, (mz - moment(3)) / mz
            write(*,*) " "

        enddo

    End Program


C vim: set noexpandtab:
	PROGRAM MAIN
	IMPLICIT NONE
	REAL*4 ALPHA,POWER,P0,N,M,P1L,ODDSL,RL,P1H,ODDSH,RH
	INTEGER*4 UORF

	ALPHA = 5D-2
	POWER = 8D-1
	P0 = 1D-1
	N = 325
	M = 9
	UORF = 1

	CALL IPRELRISK(ALPHA,POWER,P0,N,M,UORF,P1L,ODDSL,RL,P1H,ODDSH,RH)

	PRINT *, "IPRELRISK(0.05, 0.8, 0.1, 325, 9, 1) =", P1L, P1H
	END


      SUBROUTINE TG01GD( JOBS, L, N, M, P, A, LDA, E, LDE, B, LDB,
     $                   C, LDC, D, LDD, LR, NR, RANKE, INFRED, TOL,
     $                   IWORK, DWORK, LDWORK, INFO )
C
C     SLICOT RELEASE 5.7.
C
C     Copyright (c) 2002-2020 NICONET e.V.
C
C     PURPOSE
C
C     To find a reduced descriptor representation (Ar-lambda*Er,Br,Cr)
C     without non-dynamic modes for a descriptor representation
C     (A-lambda*E,B,C). Optionally, the reduced descriptor system can
C     be put into a standard form with the leading diagonal block
C     of Er identity.
C
C     ARGUMENTS
C
C     Mode Parameters
C
C     JOBS    CHARACTER*1
C             Indicates whether the user wishes to transform the leading
C             diagonal block of Er to an identity matrix, as follows:
C             = 'S':  make Er with leading diagonal identity;
C             = 'D':  keep Er unreduced or upper triangular.
C
C     Input/Output Parameters
C
C     L       (input) INTEGER
C             The number of rows of the matrices A, E, and B;
C             also the number of differential equations.  L >= 0.
C
C     N       (input) INTEGER
C             The number of columns of the matrices A, E, and C;
C             also the dimension of descriptor state vector.  N >= 0.
C
C     M       (input) INTEGER
C             The number of columns of the matrix B;
C             also the dimension of the input vector.  M >= 0.
C
C     P       (input) INTEGER
C             The number of rows of the matrix C.
C             also the dimension of the output vector.  P >= 0.
C
C     A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
C             On entry, the leading L-by-N part of this array must
C             contain the state dynamics matrix A.
C             On exit, if NR < N, the leading LR-by-NR part of this
C             array contains the reduced order state matrix Ar of a
C             descriptor realization without non-dynamic modes.
C             Array A contains the original state dynamics matrix if
C             INFRED < 0.
C
C     LDA     INTEGER
C             The leading dimension of the array A.  LDA >= MAX(1,L).
C
C     E       (input/output) DOUBLE PRECISION array, dimension (LDE,N)
C             On entry, the leading L-by-N part of this array must
C             contain the descriptor matrix E.
C             On exit, if INFRED >= 0, the leading LR-by-NR part of this
C             array contains the reduced order descriptor matrix Er of a
C             descriptor realization without non-dynamic modes.
C             In this case, only the leading RANKE-by-RANKE submatrix
C             of Er is nonzero and this submatrix is nonsingular and
C             upper triangular. Array E contains the original descriptor
C             matrix if INFRED < 0. If JOBS = 'S', then the leading
C             RANKE-by-RANKE submatrix results in an identity matrix.
C
C     LDE     INTEGER
C             The leading dimension of the array E.  LDE >= MAX(1,L).
C
C     B       (input/output) DOUBLE PRECISION array, dimension (LDB,M)
C             On entry, the leading L-by-M part of this array must
C             contain the input matrix B.
C             On exit, the leading LR-by-M part of this array contains
C             the reduced order input matrix Br of a descriptor
C             realization without non-dynamic modes. Array B contains
C             the original input matrix if INFRED < 0.
C
C     LDB     INTEGER
C             The leading dimension of the array B.  LDB >= MAX(1,L).
C
C     C       (input/output) DOUBLE PRECISION array, dimension (LDC,N)
C             On entry, the leading P-by-N part of this array must
C             contain the output matrix C.
C             On exit, the leading P-by-NR part of this array contains
C             the reduced order output matrix Cr of a descriptor
C             realization without non-dynamic modes. Array C contains
C             the original output matrix if INFRED < 0.
C
C     LDC     INTEGER
C             The leading dimension of the array C.  LDC >= MAX(1,P).
C
C     D       (input/output) DOUBLE PRECISION array, dimension (LDD,M)
C             On entry, the leading P-by-M part of this array must
C             contain the original feedthrough matrix D.
C             On exit, the leading P-by-M part of this array contains
C             the feedthrough matrix Dr of a reduced descriptor
C             realization without non-dynamic modes.
C
C     LDD     INTEGER
C             The leading dimension of the array D.  LDD >= MAX(1,P).
C
C     LR      (output) INTEGER
C             The number of reduced differential equations.
C
C     NR      (output) INTEGER
C             The dimension of the reduced descriptor state vector.
C
C     RANKE   (output) INTEGER
C             The estimated rank of the matrix E.
C
C     INFRED  (output) INTEGER
C             This parameter contains information on performed reduction
C             and on structure of resulting system matrices, as follows:
C             INFRED >= 0 the reduced system is in an SVD-like
C                         coordinate form with Er upper triangular;
C                         INFRED is the achieved order reduction.
C             INFRED  < 0 no reduction achieved and the original
C                         system has been restored.
C
C     Tolerances
C
C     TOL     DOUBLE PRECISION
C             The tolerance to be used in rank determinations when
C             transforming (A-lambda*E). If the user sets TOL > 0,
C             then the given value of TOL is used as a lower bound for
C             reciprocal condition numbers in rank determinations; a
C             (sub)matrix whose estimated condition number is less than
C             1/TOL is considered to be of full rank.  If the user sets
C             TOL <= 0, then an implicitly computed, default tolerance,
C             defined by  TOLDEF = L*N*EPS,  is used instead, where EPS
C             is the machine precision (see LAPACK Library routine
C             DLAMCH).  TOL < 1.
C
C     Workspace
C
C     IWORK   INTEGER array, dimension (N)
C
C     DWORK   DOUBLE PRECISION array, dimension (LDWORK)
C             On exit, if INFO = 0, DWORK(1) returns the optimal value
C             of LDWORK.
C
C     LDWORK  INTEGER
C             The length of the array DWORK.
C             LDWORK >= 1, if MIN(L,N) = 0; otherwise,
C             LDWORK >= MAX( N+P, MIN(L,N)+MAX(3*N-1,M,L) ).
C             If LDWORK >= 2*L*N+L*M+N*P+
C                          MAX( 1, N+P, MIN(L,N)+MAX(3*N-1,M,L) ) then
C             the original matrices are restored if no order reduction
C             is possible. This is achieved by saving system matrices
C             before reduction and restoring them if no order reduction
C             took place.
C
C             If LDWORK = -1, then a workspace query is assumed; the
C             routine only calculates the optimal size of the DWORK
C             array, returns this value as the first entry of the DWORK
C             array, and no error message related to LDWORK is issued by
C             XERBLA. The optimal size does not necessarily include the
C             space needed for saving the original system matrices.
C
C     Error Indicator
C
C     INFO    INTEGER
C             = 0:  successful exit;
C             < 0:  if INFO = -i, the i-th argument had an illegal
C                   value.
C
C     METHOD
C
C     The subroutine elliminates the non-dynamics modes in two steps:
C
C     Step 1: Reduce the system to the SVD-like coordinate form
C     (Q'*A*Z-lambda*Q'*E*Z, Q'*B, C*Z) , where
C
C              ( A11 A12 A13 )           ( E11 0 0 )         ( B1 )
C     Q'*A*Z = ( A21 A22  0  ), Q'*E*Z = (  0  0 0 ), Q'*B = ( B2 ),
C              ( A31  0   0  )           (  0  0 0 )         ( B3 )
C
C        C*Z = ( C1  C2  C3 ),
C
C     where E11 and A22 are upper triangular invertible matrices.
C
C     Step 2: Compute the reduced system as (Ar-lambda*Er,Br,Cr,Dr),
C     where
C          ( A11 - A12*inv(A22)*A21, A13 )        ( E11 0 )
C     Ar = (                             ),  Er = (       ),
C          (     A31                  0  )        (  0  0 )
C
C          ( B1 - A12*inv(A22)*B2 )
C     Br = (                      ),  Cr = ( C1 - C2*inv(A22)*A21, C3 ),
C          (        B3            )
C
C     Dr = D - C2*inv(A22)*B2.
C
C     Step 3: If desired (JOBS = 'S'), reduce the descriptor system to
C     the standard form
C
C     Ar <- diag(inv(E11),I)*Ar;  Br <- diag(inv(E11),I)*Br;
C     Er  = diag(I,0).
C
C     If L = N and LR = NR = RANKE, then if Step 3 is performed,
C     the resulting system is a standard state space system.
C
C     NUMERICAL ASPECTS
C
C     If L = N, the algorithm requires 0( N**3 ) floating point
C     operations.
C
C     CONTRIBUTOR
C
C     A. Varga, German Aerospace Center, DLR Oberpfaffenhofen.
C     May 1999.
C
C     REVISIONS
C
C     July 1999, V. Sima, Research Institute for Informatics, Bucharest.
C     A. Varga, DLR Oberpfaffenhofen, March 2002.
C     V. Sima, Dec. 2016, Feb. 2017.
C
C     KEYWORDS
C
C     Minimal realization, orthogonal transformation.
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION   ONE, ZERO
      PARAMETER          ( ONE = 1.0D0, ZERO = 0.0D0 )
C     .. Scalar Arguments ..
      CHARACTER         JOBS
      INTEGER           INFO, INFRED, L, LDA, LDB, LDC, LDD, LDE,
     $                  LDWORK, LR, M, N, NR, P, RANKE
      DOUBLE PRECISION  TOL
C     .. Array Arguments ..
      INTEGER           IWORK(*)
      DOUBLE PRECISION  A(LDA,*), B(LDB,*), C(LDC,*), D(LDD,*),
     $                  DWORK(*), E(LDE,*)
C     .. Local Scalars ..
      LOGICAL           LQUERY, LSPACE, SSTYPE
      INTEGER           K, K1, KWA, KWB, KWC, KWE, KWR, LS, LWRMIN, NS,
     $                  RNKA22, WRKOPT
C     .. Local Arrays ..
      DOUBLE PRECISION  DUM(1)
C     .. External Functions ..
      LOGICAL           LSAME
      EXTERNAL          LSAME
C     .. External Subroutines ..
      EXTERNAL          DGEMM, DLACPY, DLASET, DTRSM, TG01FD, XERBLA
C     .. Intrinsic Functions ..
      INTRINSIC         INT, MAX, MIN
C     .. Executable Statements ..
C
C     Decode JOBS.
C
      SSTYPE = LSAME( JOBS, 'S' )
C
      INFO = 0
C
C     Test the input scalar arguments.
C
      IF( .NOT.SSTYPE .AND. .NOT.LSAME( JOBS, 'D' )  ) THEN
         INFO = -1
      ELSE IF( L.LT.0 ) THEN
         INFO = -2
      ELSE IF( N.LT.0 ) THEN
         INFO = -3
      ELSE IF( M.LT.0 ) THEN
         INFO = -4
      ELSE IF( P.LT.0 ) THEN
         INFO = -5
      ELSE IF( LDA.LT.MAX( 1, L) ) THEN
         INFO = -7
      ELSE IF( LDE.LT.MAX( 1, L ) ) THEN
         INFO = -9
      ELSE IF( LDB.LT.MAX( 1, L ) ) THEN
         INFO = -11
      ELSE IF( LDC.LT.MAX( 1, P ) ) THEN
         INFO = -13
      ELSE IF( LDD.LT.MAX( 1, P ) ) THEN
         INFO = -15
      ELSE IF( TOL.GE.ONE ) THEN
         INFO = -20
      ELSE
         IF( MIN( L, N ).EQ.0 ) THEN
            LWRMIN = 1
         ELSE
            LWRMIN = MAX( N + P, MIN( L, N ) + MAX( 3*N - 1, M, L ) )
         END IF
         LQUERY = LDWORK.EQ.-1
C
         IF( LQUERY ) THEN
            CALL TG01FD( 'Not Q', 'Not Z', 'Reduce A', L, N, M, P, A,
     $                   LDA, E, LDE, B, LDB, C, LDC, DUM, 1, DUM, 1,
     $                   RANKE, RNKA22, TOL, IWORK, DWORK, -1, INFO )
            WRKOPT = MAX( LWRMIN, INT( DWORK(1) ) )
         ELSE IF( LDWORK.LT.LWRMIN ) THEN
            INFO = -23
         END IF
      END IF
C
      IF ( INFO.NE.0 ) THEN
C
C        Error return.
C
         CALL XERBLA( 'TG01GD', -INFO )
         RETURN
      ELSE IF( LQUERY ) THEN
         DWORK(1) = WRKOPT
         RETURN
       END IF
C
C     Quick return if possible.
C
      LR = L
      NR = N
      IF( MIN( L, N ).EQ.0 ) THEN
         DWORK(1) = ONE
         RANKE    =  0
         INFRED   = -1
         RETURN
      END IF
C
C     Set large workspace option.
C
      LSPACE = LDWORK.GE.( LWRMIN + L*( 2*N + M) + P*N ) .AND.
     $         .NOT.SSTYPE
C
      IF( LSPACE) THEN
C
C        Determine offsets and save system matrices.
C
         KWA = 1
         KWE = KWA + L*N
         KWB = KWE + L*N
         KWC = KWB + L*M
         KWR = KWC + P*N
         CALL DLACPY( 'Full', L, N, A, LDA, DWORK(KWA), L )
         CALL DLACPY( 'Full', L, N, E, LDE, DWORK(KWE), L )
         CALL DLACPY( 'Full', L, M, B, LDB, DWORK(KWB), L )
         CALL DLACPY( 'Full', P, N, C, LDC, DWORK(KWC), MAX( 1, P ) )
      ELSE
         KWR = 1
      END IF
C
C     Reduce the descriptor system to the SVD-like coordinate form
C     (At-lambda*Et, Bt, Ct) , where
C
C             ( A11 A12 A13 )       ( E11 0 0 )       ( B1 )
C        At = ( A21 A22  0  ), Et = (  0  0 0 ), Bt = ( B2 ),
C             ( A31  0   0  )       (  0  0 0 )       ( B3 )
C
C        Ct = ( C1  C2  C3  ),
C
C     and E11 and A22 are RANKE-by-RANKE and RNKA22-by-RNKA22
C     upper triangular invertible matrices, respectively.
C     Workspace: needed real MAX( N+P, MIN(L,N)+MAX(3*N-1,M,L) );
C                needed integer N.
C
      CALL TG01FD( 'Not Q', 'Not Z', 'Reduce A', L, N, M, P, A, LDA,
     $              E, LDE, B, LDB, C, LDC, DUM, 1, DUM, 1, RANKE,
     $              RNKA22, TOL, IWORK, DWORK(KWR), LDWORK-KWR+1, INFO )
C
      IF( INFO.EQ.0 ) THEN
         INFRED = RNKA22
         IF( RNKA22.GT.0 ) THEN
C
C           Apply residualization formulas.
C
            K  = RANKE + 1
            K1 = MIN( L, N, K + RNKA22 )
            LR = L  - RNKA22
            NR = N  - RNKA22
            LS = LR - RANKE
            NS = NR - RANKE
C
C           Compute A21 <- INV(A22)*A21.
C
            CALL DTRSM( 'Left', 'Upper', 'No Transpose', 'Non-unit',
     $                  RNKA22, RANKE, ONE, A(K,K), LDA, A(K,1), LDA )
C
C           Compute B2 <- INV(A22)*B2.
C
            CALL DTRSM( 'Left', 'Upper', 'No Transpose', 'Non-unit',
     $                  RNKA22, M, ONE, A(K,K), LDA, B(K,1), LDB )
C
C           Compute the residualized systems matrices.
C
C           Dr = D - C2*INV(A22)*B2.
C
            CALL DGEMM( 'No Transpose', 'No Transpose', P, M, RNKA22,
     $                  -ONE, C(1,K), LDC, B(K,1), LDB, ONE, D, LDD )
C
C           Br = ( B1 - A12*INV(A22)*B2 ).
C                (         B3           )
C
            CALL DGEMM( 'No Transpose', 'No Transpose', RANKE, M,
     $                  RNKA22, -ONE, A(1,K), LDA, B(K,1), LDB, ONE,
     $                  B, LDB )
            CALL DLACPY( 'Full', LS, M, B(K1,1), LDB, B(K,1), LDB )
C
C           Cr = ( C1 - C2*INV(A22)*A21 C3 ).
C
            CALL DGEMM( 'NoTranspose', 'NoTranspose', P, RANKE, RNKA22,
     $                  -ONE, C(1,K), LDC, A(K,1), LDA, ONE, C, LDC )
            CALL DLACPY( 'Full', P, NS, C(1,K1), LDC, C(1,K), LDC )
C
C           Ar = ( A11 - A12*INV(A22)*A21  A13 ).
C                (       A31                0  )
C
            CALL DGEMM( 'No Transpose', 'No Transpose', RANKE, RANKE,
     $                  RNKA22, -ONE, A(1,K), LDA, A(K,1), LDA, ONE, A,
     $                  LDA )
C
            CALL DLACPY( 'Full', LS,    NR, A(K1,1), LDA, A(K,1), LDA )
            CALL DLACPY( 'Full', RANKE, NS, A(1,K1), LDA, A(1,K), LDA )
         ELSE
            IF( LSPACE ) THEN
C
C              Restore system matrices.
C
               CALL DLACPY( 'Full', L, N, DWORK(KWA), L, A, LDA )
               CALL DLACPY( 'Full', L, N, DWORK(KWE), L, E, LDE )
               CALL DLACPY( 'Full', L, M, DWORK(KWB), L, B, LDB )
               CALL DLACPY( 'Full', P, N, DWORK(KWC), MAX( 1, P ), C,
     $                      LDC )
               INFRED = -1
            END IF
         END IF
C
         IF( SSTYPE ) THEN
C
C           Ar <- diag(inv(E11),I)*Ar.
C
            CALL DTRSM( 'Left', 'Upper', 'No Transpose', 'Non-unit',
     $                  RANKE, NR, ONE, E, LDE, A, LDA )
C
C           Br <- diag(inv(E11),I)*Br.
C
            CALL DTRSM( 'Left', 'Upper', 'No Transpose', 'Non-unit',
     $                  RANKE, M, ONE, E, LDE, B, LDB )
C
C           E11 = I.
C
            CALL DLASET( 'Full', RANKE, RANKE, ZERO, ONE, E, LDE )
         END IF
         DWORK(1) = DWORK(KWR)
      END IF
C
      RETURN
C *** Last line of TG01GD ***
      END


! { dg-do run }

module udr10m
  type dt
    integer :: x = 0
  end type
!$omp declare reduction(.add.:dt:omp_out=omp_out.add.omp_in)
!$omp declare reduction(+:dt:omp_out=omp_out+omp_in)
  interface operator(+)
    module procedure addme
  end interface
  interface operator(.add.)
    module procedure addme
  end interface
contains
  type(dt) function addme (x, y)
    type (dt), intent (in) :: x, y
    addme%x = x%x + y%x
  end function addme
end module udr10m
program udr10
  use udr10m, only : operator(.localadd.) => operator(.add.), &
& operator(+), dl => dt
  type(dl) :: j, k
  integer :: i
!$omp parallel do reduction(+:j) reduction(.localadd.:k)
  do i = 1, 100
    j = j .localadd. dl(i)
    k = k + dl(i * 2)
  end do
  if (j%x /= 5050 .or. k%x /= 10100) call abort
end


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

*   Logical operators (.NOT., .AND., .OR., .EQV., and .NEQV.)
*   used outside of IF conditions.

      implicit logical (r, e-f, t)
      parameter (N = 36, TT = .true., FF = .false.)
      common f
      dimension rslts(N), expect(N)
      data t, f / .true., .false. /

      data expect /
c tests 1 - 4:
     +			FF, TT, FF, TT,
c tests 5 - 12:
     +			FF, FF, FF, TT, FF, FF, FF, TT,
c tests 13 - 20:
     +			FF, TT, TT, TT, FF, TT, TT, TT,
c tests 21 - 24:
     +			TT, FF, FF, TT,
c tests 25 - 28:
     +			FF, TT, TT, FF,
c tests 29 - 33:
     +			TT, FF, TT, TT, FF,
c tests 34 - 36:
     +			TT, FF, FF          /

C   tests 1 - 4:   .NOT. operator:

	rslts(1) = .NOT. t
	rslts(2) = .not. f
	rslts(3) = .not. .TRUE.
	rslts(4) = .not..FALSE.

C   tests 5 - 12:   .AND. operator:

	rslts(5) = f .and. f
	rslts(6) = f .and. t
	rslts(7) = t .and. f
	rslts(8) = t .and. t

c       ... one constant operand:

	rslts(9) = f .and. .false.
	rslts(10) = f .and. .true.
	rslts(11) = .true. .and. f
	rslts(12) = .true. .and. t

C   tests 13 - 20:   .OR. operator:

	rslts(13) = f .or. f
	rslts(14) = f .or. t
	rslts(15) = t .or. f
	rslts(16) = t .or. t

c       ... one constant operand:

	rslts(17) = .false. .or. f
	rslts(18) = f .or. .true.
	rslts(19) = .true. .or. f
	rslts(20) = t .or. .true.

C   tests 21 - 24:   .EQV. operator:

	rslts(21) = f .eqv. f
	rslts(22) = f .eqv. t
	rslts(23) = t .eqv. .false.
	rslts(24) = .true. .eqv. t

C   tests 25 - 28:   .NEQV operator:

	rslts(25) = .false. .neqv. f
	rslts(26) = f .neqv. t
	rslts(27) = t .neqv. f
	rslts(28) = t .neqv. .true.

C   tests 29 - 33:   test precedence of logical operators:

	rslts(29) = .not. t .or. t
	rslts(30) = .not. f .and. f
	rslts(31) = t .or. t .and. f
	rslts(32) = f .eqv. f .and. f
	rslts(33) = t .neqv. f .or. t

C   tests 34 - 36:   test .not. of .not.:

        rslts(34) = .not. .not. t
        rslts(35) = .not. .not. f
        rslts(36) = .not. .not. .not. t

C   check results:

	call check(rslts, expect, N)
	end


      REAL*4 function scamaxf(n,zx,incx)
c
c     finds the index of element having max. absolute value.
c     jack dongarra, 1/15/85.
c     modified 3/93 to return if incx .le. 0.
c     modified 12/3/93, array(1) declarations changed to array(*)
c
      COMPLEX*8 zx(*)
      integer i,incx,ix,n
      REAL*4 scabs1
c
      scamaxf = 0.
      if( n.lt.1 .or. incx.le.0 )return
      scamaxf = scabs1(zx(1))
      if(n.eq.1)return
      if(incx.eq.1)go to 20
c
c        code for increment not equal to 1
c
      ix = 1
      scamaxf = scabs1(zx(1))
      ix = ix + incx
      do 10 i = 2,n
         if(scabs1(zx(ix)).le.scamaxf) go to 5
         scamaxf = i
         scamaxf = scabs1(zx(ix))
    5    ix = ix + incx
   10 continue
      return
c
c        code for increment equal to 1
c
   20 scamaxf = scabs1(zx(1))
      do 30 i = 2,n
         if(scabs1(zx(i)).le.scamaxf) go to 30
         scamaxf = i
         scamaxf = scabs1(zx(i))
   30 continue
      return
      end


!> @file
!! \brief Fortran code for reading a sparse matrix in Harwell-Boeing format.
!!
!
      subroutine dhbcode1(nrow, ncol, nnzero, values, rowind, colptr)

!     ================================================================
!     ... SAMPLE CODE FOR READING A SPARSE MATRIX IN STANDARD FORMAT
!     ================================================================

      CHARACTER      TITLE*72, KEY*8, MXTYPE*3, PTRFMT*16, &
                     INDFMT*16, VALFMT*20, RHSFMT*20

      INTEGER        TOTCRD, PTRCRD, INDCRD, VALCRD, RHSCRD,  NROW,  &
                     NCOL  , NNZERO, NELTVL

      INTEGER        COLPTR (*), ROWIND (*)

      REAL*8         VALUES (*)

!    ------------------------
!     ... READ IN HEADER BLOCK
!     ------------------------

      READ ( 5, 1000 ) TITLE , KEY , TOTCRD, PTRCRD, INDCRD, VALCRD, &
                       RHSCRD, MXTYPE, NROW  , NCOL  , NNZERO, NELTVL, &
                       PTRFMT, INDFMT, VALFMT, RHSFMT
 1000 FORMAT ( A72, A8 / 5I14 / A3, 11X, 4I14 / 2A16, 2A20 )

!     -------------------------
!     ... READ MATRIX STRUCTURE
!     -------------------------

      READ ( 5, PTRFMT ) ( COLPTR (I), I = 1, NCOL+1 )

      READ ( 5, INDFMT ) ( ROWIND (I), I = 1, NNZERO )

      IF  ( VALCRD .GT. 0 )  THEN

!         ----------------------
!         ... READ MATRIX VALUES
!         ----------------------

          READ ( 5, VALFMT ) ( VALUES (I), I = 1, NNZERO )

      ENDIF

      return
      end


! { dg-do run }
! { dg-require-effective-target fortran_large_real }
! Take the pack intrinsic through its paces, with all types that are
! normally accessible.
program main
  implicit none
  integer,parameter :: k = selected_real_kind (precision (0.0_8) + 1)
  integer :: i
  real(kind=k), dimension(3,3) :: rk
  real(kind=k), dimension(9) :: vrk
  real(kind=k), dimension(9) :: rrk
  complex(kind=k), dimension(3,3) :: ck
  complex(kind=k), dimension(9) :: vck
  complex(kind=k), dimension(9) :: rck

  vrk = (/(i+10,i=1,9)/)
  rk = reshape((/1.0_k, -3.0_k, 2.1_k, -4.21_k, 1.2_k, 0.98_k, -1.2_k, &
  &              -7.1_k, -9.9_k, 0.3_k /), shape(rk))
  rrk = pack(rk,rk>0,vrk)
  if (any(rrk /= (/ 1.0_k, 2.1_k, 1.2_k, 0.98_k,  15._k, 16._k, 17._k, &
  &                  18._k, 19._k /))) STOP 1

  vck = (/(i+10,i=1,9)/)
  ck = reshape((/1.0_k, -3.0_k, 2.1_k, -4.21_k, 1.2_k, 0.98_k, -1.2_k, &
  &              -7.1_k, -9.9_k, 0.3_k /), shape(ck))
  rck = pack(ck,real(ck)>0,vck)
  if (any(real(rck) /= (/ 1.0_k, 2.1_k, 1.2_k, 0.98_k,  15._k, 16._k, 17._k, &
  &                  18._k, 19._k /))) STOP 2
  if (any(aimag(rck) /= 0)) STOP 3

end program main


!
!     CalculiX - A 3-dimensional finite element program
!              Copyright (C) 1998-2019 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 writeev(x,nx,xmin,xmax)
!
!     writes the eigenvalues in the .dat file and replaces the
!     eigenvalue by its square root = frequency (in rad/time)
!
      implicit none
!
      integer j,nx
      real*8 x(nx),pi,xmin,xmax,xnull
!
!     for real symmetric matrices the eigenvalue is real;
!     the frequency, which is the square root of the eigenvalue
!     can be real or complex (in the latter case buckling occurs)
!
      pi=4.d0*datan(1.d0)
      xnull=0.d0
!
      write(5,*)
      write(5,*) '    E I G E N V A L U E   O U T P U T'
      write(5,*)
      write(5,*) 'MODE NO    EIGENVALUE                       FREQUENCY
     &  '
      write(5,*) '                                    REAL PART
     &   IMAGINARY PART'
      write(5,*) '                          (RAD/TIME)      (CYCLES/TIME
     &     (RAD/TIME)'
      write(5,*)
!
      do j=1,nx
!
!        user-defined minimum frequency
!
         if(xmin.gt.-0.5d0) then
            if(xmin*xmin.gt.x(j)) cycle
         endif
!
!        user-defined maximum frequency
!
         if(xmax.gt.-0.5d0) then
            if(xmax*xmax.lt.x(j)) exit
         endif
!
         if(x(j).lt.0.d0) then
            write(5,'(i7,4(2x,e14.7))') j,x(j),xnull,
     &         xnull,dsqrt(-x(j))
         else
            write(5,'(i7,4(2x,e14.7))') j,x(j),dsqrt(x(j)),
     &     dsqrt(x(j))/(2.d0*pi),xnull
         endif
      enddo
!
      return
      end