      SUBROUTINE ZLAROR( SIDE, INIT, M, N, A, LDA, ISEED, X, INFO )
*
*  -- LAPACK auxiliary test routine (version 3.1) --
*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
*     November 2006
*
*     .. Scalar Arguments ..
      CHARACTER          INIT, SIDE
      INTEGER            INFO, LDA, M, N
*     ..
*     .. Array Arguments ..
      INTEGER            ISEED( 4 )
      COMPLEX*16         A( LDA, * ), X( * )
*     ..
*
*  Purpose
*  =======
*
*     ZLAROR pre- or post-multiplies an M by N matrix A by a random
*     unitary matrix U, overwriting A. A may optionally be
*     initialized to the identity matrix before multiplying by U.
*     U is generated using the method of G.W. Stewart
*     ( SIAM J. Numer. Anal. 17, 1980, pp. 403-409 ).
*     (BLAS-2 version)
*
*  Arguments
*  =========
*
*  SIDE   - CHARACTER*1
*           SIDE specifies whether A is multiplied on the left or right
*           by U.
*       SIDE = 'L'   Multiply A on the left (premultiply) by U
*       SIDE = 'R'   Multiply A on the right (postmultiply) by U*
*       SIDE = 'C'   Multiply A on the left by U and the right by U*
*       SIDE = 'T'   Multiply A on the left by U and the right by U'
*           Not modified.
*
*  INIT   - CHARACTER*1
*           INIT specifies whether or not A should be initialized to
*           the identity matrix.
*              INIT = 'I'   Initialize A to (a section of) the
*                           identity matrix before applying U.
*              INIT = 'N'   No initialization.  Apply U to the
*                           input matrix A.
*
*           INIT = 'I' may be used to generate square (i.e., unitary)
*           or rectangular orthogonal matrices (orthogonality being
*           in the sense of ZDOTC):
*
*           For square matrices, M=N, and SIDE many be either 'L' or
*           'R'; the rows will be orthogonal to each other, as will the
*           columns.
*           For rectangular matrices where M < N, SIDE = 'R' will
*           produce a dense matrix whose rows will be orthogonal and
*           whose columns will not, while SIDE = 'L' will produce a
*           matrix whose rows will be orthogonal, and whose first M
*           columns will be orthogonal, the remaining columns being
*           zero.
*           For matrices where M > N, just use the previous
*           explaination, interchanging 'L' and 'R' and "rows" and
*           "columns".
*
*           Not modified.
*
*  M      - INTEGER
*           Number of rows of A. Not modified.
*
*  N      - INTEGER
*           Number of columns of A. Not modified.
*
*  A      - COMPLEX*16 array, dimension ( LDA, N )
*           Input and output array. Overwritten by U A ( if SIDE = 'L' )
*           or by A U ( if SIDE = 'R' )
*           or by U A U* ( if SIDE = 'C')
*           or by U A U' ( if SIDE = 'T') on exit.
*
*  LDA    - INTEGER
*           Leading dimension of A. Must be at least MAX ( 1, M ).
*           Not modified.
*
*  ISEED  - INTEGER array, dimension ( 4 )
*           On entry ISEED specifies the seed of the random number
*           generator. The array elements should be between 0 and 4095;
*           if not they will be reduced mod 4096.  Also, ISEED(4) must
*           be odd.  The random number generator uses a linear
*           congruential sequence limited to small integers, and so
*           should produce machine independent random numbers. The
*           values of ISEED are changed on exit, and can be used in the
*           next call to ZLAROR to continue the same random number
*           sequence.
*           Modified.
*
*  X      - COMPLEX*16 array, dimension ( 3*MAX( M, N ) )
*           Workspace. Of length:
*               2*M + N if SIDE = 'L',
*               2*N + M if SIDE = 'R',
*               3*N     if SIDE = 'C' or 'T'.
*           Modified.
*
*  INFO   - INTEGER
*           An error flag.  It is set to:
*            0  if no error.
*            1  if ZLARND returned a bad random number (installation
*               problem)
*           -1  if SIDE is not L, R, C, or T.
*           -3  if M is negative.
*           -4  if N is negative or if SIDE is C or T and N is not equal
*               to M.
*           -6  if LDA is less than M.
*
*  =====================================================================
*
*     .. Parameters ..
      DOUBLE PRECISION   ZERO, ONE, TOOSML
      PARAMETER          ( ZERO = 0.0D+0, ONE = 1.0D+0,
     $                   TOOSML = 1.0D-20 )
      COMPLEX*16         CZERO, CONE
      PARAMETER          ( CZERO = ( 0.0D+0, 0.0D+0 ),
     $                   CONE = ( 1.0D+0, 0.0D+0 ) )
*     ..
*     .. Local Scalars ..
      INTEGER            IROW, ITYPE, IXFRM, J, JCOL, KBEG, NXFRM
      DOUBLE PRECISION   FACTOR, XABS, XNORM
      COMPLEX*16         CSIGN, XNORMS
*     ..
*     .. External Functions ..
      LOGICAL            LSAME
      DOUBLE PRECISION   DZNRM2
      COMPLEX*16         ZLARND
      EXTERNAL           LSAME, DZNRM2, ZLARND
*     ..
*     .. External Subroutines ..
      EXTERNAL           XERBLA, ZGEMV, ZGERC, ZLACGV, ZLASET, ZSCAL
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          ABS, DCMPLX, DCONJG
*     ..
*     .. Executable Statements ..
*
      IF( N.EQ.0 .OR. M.EQ.0 )
     $   RETURN
*
      ITYPE = 0
      IF( LSAME( SIDE, 'L' ) ) THEN
         ITYPE = 1
      ELSE IF( LSAME( SIDE, 'R' ) ) THEN
         ITYPE = 2
      ELSE IF( LSAME( SIDE, 'C' ) ) THEN
         ITYPE = 3
      ELSE IF( LSAME( SIDE, 'T' ) ) THEN
         ITYPE = 4
      END IF
*
*     Check for argument errors.
*
      INFO = 0
      IF( ITYPE.EQ.0 ) THEN
         INFO = -1
      ELSE IF( M.LT.0 ) THEN
         INFO = -3
      ELSE IF( N.LT.0 .OR. ( ITYPE.EQ.3 .AND. N.NE.M ) ) THEN
         INFO = -4
      ELSE IF( LDA.LT.M ) THEN
         INFO = -6
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'ZLAROR', -INFO )
         RETURN
      END IF
*
      IF( ITYPE.EQ.1 ) THEN
         NXFRM = M
      ELSE
         NXFRM = N
      END IF
*
*     Initialize A to the identity matrix if desired
*
      IF( LSAME( INIT, 'I' ) )
     $   CALL ZLASET( 'Full', M, N, CZERO, CONE, A, LDA )
*
*     If no rotation possible, still multiply by
*     a random complex number from the circle |x| = 1
*
*      2)      Compute Rotation by computing Householder
*              Transformations H(2), H(3), ..., H(n).  Note that the
*              order in which they are computed is irrelevant.
*
      DO 10 J = 1, NXFRM
         X( J ) = CZERO
   10 CONTINUE
*
      DO 30 IXFRM = 2, NXFRM
         KBEG = NXFRM - IXFRM + 1
*
*        Generate independent normal( 0, 1 ) random numbers
*
         DO 20 J = KBEG, NXFRM
            X( J ) = ZLARND( 3, ISEED )
   20    CONTINUE
*
*        Generate a Householder transformation from the random vector X
*
         XNORM = DZNRM2( IXFRM, X( KBEG ), 1 )
         XABS = ABS( X( KBEG ) )
         IF( XABS.NE.CZERO ) THEN
            CSIGN = X( KBEG ) / XABS
         ELSE
            CSIGN = CONE
         END IF
         XNORMS = CSIGN*XNORM
         X( NXFRM+KBEG ) = -CSIGN
         FACTOR = XNORM*( XNORM+XABS )
         IF( ABS( FACTOR ).LT.TOOSML ) THEN
            INFO = 1
            CALL XERBLA( 'ZLAROR', -INFO )
            RETURN
         ELSE
            FACTOR = ONE / FACTOR
         END IF
         X( KBEG ) = X( KBEG ) + XNORMS
*
*        Apply Householder transformation to A
*
         IF( ITYPE.EQ.1 .OR. ITYPE.EQ.3 .OR. ITYPE.EQ.4 ) THEN
*
*           Apply H(k) on the left of A
*
            CALL ZGEMV( 'C', IXFRM, N, CONE, A( KBEG, 1 ), LDA,
     $                  X( KBEG ), 1, CZERO, X( 2*NXFRM+1 ), 1 )
            CALL ZGERC( IXFRM, N, -DCMPLX( FACTOR ), X( KBEG ), 1,
     $                  X( 2*NXFRM+1 ), 1, A( KBEG, 1 ), LDA )
*
         END IF
*
         IF( ITYPE.GE.2 .AND. ITYPE.LE.4 ) THEN
*
*           Apply H(k)* (or H(k)') on the right of A
*
            IF( ITYPE.EQ.4 ) THEN
               CALL ZLACGV( IXFRM, X( KBEG ), 1 )
            END IF
*
            CALL ZGEMV( 'N', M, IXFRM, CONE, A( 1, KBEG ), LDA,
     $                  X( KBEG ), 1, CZERO, X( 2*NXFRM+1 ), 1 )
            CALL ZGERC( M, IXFRM, -DCMPLX( FACTOR ), X( 2*NXFRM+1 ), 1,
     $                  X( KBEG ), 1, A( 1, KBEG ), LDA )
*
         END IF
   30 CONTINUE
*
      X( 1 ) = ZLARND( 3, ISEED )
      XABS = ABS( X( 1 ) )
      IF( XABS.NE.ZERO ) THEN
         CSIGN = X( 1 ) / XABS
      ELSE
         CSIGN = CONE
      END IF
      X( 2*NXFRM ) = CSIGN
*
*     Scale the matrix A by D.
*
      IF( ITYPE.EQ.1 .OR. ITYPE.EQ.3 .OR. ITYPE.EQ.4 ) THEN
         DO 40 IROW = 1, M
            CALL ZSCAL( N, DCONJG( X( NXFRM+IROW ) ), A( IROW, 1 ),
     $                  LDA )
   40    CONTINUE
      END IF
*
      IF( ITYPE.EQ.2 .OR. ITYPE.EQ.3 ) THEN
         DO 50 JCOL = 1, N
            CALL ZSCAL( M, X( NXFRM+JCOL ), A( 1, JCOL ), 1 )
   50    CONTINUE
      END IF
*
      IF( ITYPE.EQ.4 ) THEN
         DO 60 JCOL = 1, N
            CALL ZSCAL( M, DCONJG( X( NXFRM+JCOL ) ), A( 1, JCOL ), 1 )
   60    CONTINUE
      END IF
      RETURN
*
*     End of ZLAROR
*
      END


c***********************************************************************
c> \file contebl.f
c> \brief Solves the Orr-Sommerfeld equation for incompressible boundary
c>        layers solving first the Blasius equation
c> \author S. Scott Collis
c***********************************************************************
      program conte_bl
c***********************************************************************
c
c     Purpose:  Solve the Orr-Sommerfeld equation using 4th order Runge-
c               Kutta explicit integration with orthogonalization using
c               the method of Conte.
c
c               This routine finds a single eigensolution to the Orr-
c               Sommerfeld equation for the boundary layer.
c
c               This routine works rather well but to get good
c               eigenvalues you must really resolve the boundary-layer
c               profile well.  The OS shooting solution appears to be
c               quite sensitive to the profile.
c
c     Output:   Complex valued eignenfunction is phi
c
c               Set eigfun=1 if you want eigenfunction
c
c               fort.10     Mean velocity profile
c               fort.11     phi(y)
c               fort.12     phi'(y)
c               fort.13     phi''(y)
c               fort.14     phi'''(y)
c
c     Author:   Scott Collis
c
c     Date:     7-17-1992
c
c     Revised:  12-29-2019
c
c***********************************************************************
c     Common variables
c***********************************************************************
      parameter   (imax=50000)
      integer     nbl
      complex     alpha, c
      real        U(0:imax), d2U(0:imax), Re, ymin, ymax, h, beta
      real        Uspl(0:imax), d2Uspl(0:imax), ydat(0:imax), f2p

      common      /setup/ nbl, alpha, u, d2u, Re, ymin, ymax, h, c,
     &                    f2p, beta, uspl, d2uspl, ydat
c***********************************************************************
      parameter (neq=4, inunit=20)
      complex   bc1(neq), bc2(neq)
      real      testalpha
      integer   north, nstep
      logical   eigfun
      character input*1
      character infile*20
      character string*80

      complex   INPROD
      external  BL_IC, OSHOMO, OSPART, INPROD
c
c     Defaults
c
      nbl = 1000
      nstep = 1000
      north = 50
c
c     testalpha = [0,90] degrees (10 deg seems good)
c
      testalpha = 10.0
      Re = 580.
      beta = 0.0
      alphar = 0.179
      alphai = 0.0
      cr =  0.36413124E+00
      ci =  0.79527387E-02
      ymin = 0.0
      ymax = 17.0
c
c     ymin = 20.0 leads to an underflow and denormal, 17 is okay
c
      eigfun = .true.
      f2p = 0.5
c
c     Input parameters
c
      write (*,10)
  10  format (/,10x,'Solve Orr-Sommerfeld for Boundary Layer using ',
     &        'shooting',/)
      write (*,15)
  15  format(/,1x,'Read from keyboard, file, default (k,f,d) ==> ',$)
      read (*,'(a)') input
      if (input .eq. 'k' .or. input .eq. 'K') then
        write (*,20)
  20    format (/,1x,'Enter number of steps for BL solve ==> ',$)
        read (*,*) nbl
        write (*,25)
  25    format (/,1x,'Enter number of steps for shooting ==> ',$)
        read (*,*) nstep
        write (*,30)
  30    format (/,1x,'Enter Reynolds number ==> ',$)
        read (*,*) Re
        write (*,35)
  35    format (/,1x,'Enter beta ==> ',$)
        read (*,*) beta
        write (*,40)
  40    format (/,1x,'Enter alpha_r ==> ',$)
        read (*,*) alphar
        write (*,45)
  45    format (/,1x,'Enter alpha_i ==> ',$)
        read (*,*) alphai
        write (*,50)
  50    format (/,1x,'Enter guess for (c_r, c_i) ==> ',$)
        read (*,*) cr, ci
        write (*,55)
  55    format (/,1x,'Enter Ymin and Ymax ==> ',$)
        read (*,*) Ymin, Ymax
      else if (input .eq. 'f' .or. input .eq. 'F') then
        write (*,60)
  60    format (/,1x,'Enter filename ==> ',$)
        read (*,'(a)') infile
        open (unit=inunit, file=infile, form='formatted')
        string(1:1) = '#'
        do while (string(1:1) .eq. '#')
          read(inunit,'(a)',err=99) string
        end do
        call readi (string,nbl)
        read(inunit,'(a)') string
        call readi (string,nstep)
        read(inunit,'(a)') string
        call readr (string,testalpha)
        read(inunit,'(a)') string
        call readr (string,Re)
        read(inunit,'(a)') string
        call readr (string,beta)
        read(inunit,'(a)') string
        call readr (string,f2p)
        read(inunit,'(a)') string
        call readr (string,alphar)
        read(inunit,'(a)') string
        call readr (string,alphai)
        read(inunit,'(a)') string
        call readr (string,cr)
        read(inunit,'(a)') string
        call readr (string,ci)
        read(inunit,'(a)') string
        call readr (string,Ymin)
        read(inunit,'(a)') string
        call readr (string,Ymax)
      end if
c
c     Echo input
c
      write (*,100) nbl
 100  format (/,1x,'nbl = ',i5)
      write (*,102) nstep
 102  format (1x,'nstep = ',i5)
      write (*,105) testalpha
 105  format (1x,'Test Alpha = ',e20.10)
      write (*,110) Re
 110  format (1x,'Re = ',e20.10)
      write (*,115) beta
 115  format (1x,'Beta = ',e20.10)
      write (*,117) f2p
 117  format (1x,'f2p = ',e20.10)
      write (*,140) ymin, ymax
 140  format (1x,'Ymin = ',e20.10,'  Ymax = ',e20.10)
      write (*,120) alphar, alphai
 120  format (1x,'alpha = (',e20.10,', ',e20.10,')')
      write (*,130) cr, ci
 130  format (1x,'c = (',e20.10,', ',e20.10,')',/)
c
c     Set constants
c
      alpha = cmplx(alphar,alphai)
      c = cmplx(cr,ci)
      h = (ymax-ymin)/float(nbl)
c
c     Fix to make my nondimensionalization match Mack's
c
      Re = Re*SQRT(2.)
      alpha = alpha*SQRT(2.)
      ymin = ymin
      ymax = ymax
c
c     Check problem size
c
      if (nbl .gt. imax) then
        write (*,300)
 300    format (/,/,1x,'N > Idim...Stopping',/,/)
        goto 210
      end if
c
c     Solve the Blasius boundary layer equations
c
      call SOLVE_BL
c
c     set the boundary conditions
c
      do i = 1, neq
        bc1(i) = 0.0
        bc2(i) = 0.0
      end do

      call CONTE_IC(nstep,testalpha,neq,2,bc1,bc2,ymin,ymax,c,eigfun,
     &              BL_IC, OSHOMO, OSPART, INPROD)
c
c     Read error
c
      goto 210
  99  write (*,200)
 200  format(/,/1x,'Error in input file...',/,/)
 210  continue

      stop
      end

C***********************************************************************
      function INPROD(n, v1, v2)
C***********************************************************************
C
C     Perform and inner product on two comples vectors, v1 and v2
C
c***********************************************************************
      complex     v1(n), v2(n)
      complex     INPROD
      integer     n, i
#if USE_ANALYTIC_INPROD
c
c     Lets define a different complex inner product so that the
c     iteration is analytic
c
      INPROD = 0.0
      do i = 1, n
        INPROD = INPROD + v1(i)*v2(i)
      end do
#else
      INPROD = 0.0
      do i = 1, n
        INPROD = INPROD + v1(i)*conjg(v2(i))
      end do
#endif
      return
      end

C***********************************************************************
      subroutine BL_IC(n,r,Uo)
C***********************************************************************
C
C     Set the initial condition at infinity for the Orr-Sommerfeld
C     equation for a boundary layer.   This works better than using
C     a simple Green's function
C
C***********************************************************************
      integer     n, r
      complex     Uo(n,n-r)
C***********************************************************************
      parameter   (imax=50000)
      integer     nbl
      complex     alpha, c
      real        U(0:imax), d2U(0:imax), Re, ymin, ymax, h, beta
      real        Uspl(0:imax), d2Uspl(0:imax), ydat(0:imax), f2p

      common      /setup/ nbl, alpha, u, d2u, Re, ymin, ymax, h, c,
     &                    f2p, beta, uspl, d2uspl, ydat
C***********************************************************************
      complex     rgamma
C***********************************************************************
      Uo(1,1) = CEXP(-alpha*ymax)
      Uo(2,1) = (-alpha)*CEXP(-alpha*ymax)
      Uo(3,1) = (alpha**2)*CEXP(-alpha*ymax)
      Uo(4,1) = (-alpha**3)*CEXP(-alpha*ymax)

      rgamma = SQRT(alpha**2+(0.,1.)*alpha*Re*(1.0-c))

      Uo(1,2) = CEXP(-rgamma*ymax)
      Uo(2,2) = (-rgamma)*CEXP(-rgamma*ymax)
      Uo(3,2) = (rgamma**2)*CEXP(-rgamma*ymax)
      Uo(4,2) = (-rgamma**3)*CEXP(-rgamma*ymax)

      return
      end

C***********************************************************************
      subroutine FHOMO_VODE(neq,t,yo,yf,rpar,ipar)
C***********************************************************************
      integer neq
      integer ipar(2)
      real rpar
      real t
      complex yo(IPAR(1),IPAR(2)), yf(IPAR(1),IPAR(2))
c     write(*,*) NEQ, IPAR(1), IPAR(2)
      do m = 1, IPAR(2)
        call OSHOMO(IPAR(1),yo(1,m),t,yf(1,m))
      end do
      return
      end

C***********************************************************************
      subroutine OSHOMO(neq,yo,t,yf)
C***********************************************************************
C
C     Function evaluation for the Orr-Sommerfeld equation
C
c***********************************************************************
c     Common variables
c***********************************************************************
      parameter   (imax=50000)
      integer     n
      complex     alpha, c
      real        U(0:imax), d2U(0:imax), Re, ymin, ymax, h, beta
      real        Uspl(0:imax), d2Uspl(0:imax), ydat(0:imax), f2p

      common      /setup/ nbl, alpha, u, d2u, Re, ymin, ymax, h, c,
     &                    f2p, beta, uspl, d2uspl, ydat
c***********************************************************************
      integer     neq
      complex     yo(neq), yf(neq)
      real        t
      real        UU, d2UU
      real        Pi
      pi = acos(-1.0)
c
c     Get the velocity field
c
#ifdef USE_SPINE_DERIVATIVE
      call SPEVAL(nbl+1,ydat,U,Uspl,t,UU)
      call SPEVAL(nbl+1,ydat,d2U,d2Uspl,t,d2UU)
#else
      call SPDER(nbl+1,ydat,U,Uspl,t,UU,dUU,d2UU)
#endif
      do j = 1 , neq-1
        yf(j) = yo(j+1)
      end do
      yf(neq) = 2.*alpha**2*yo(3)-alpha**4*yo(1) +
     &          (0.,1.)*alpha*Re*((UU-c)*(yo(3)-alpha**2*yo(1))-
     &          d2UU*yo(1))

      return
      end

C***********************************************************************
      subroutine OSPART(neq, yo,t,yf)
C***********************************************************************
C
C     Function evaluation for the Orr-Sommerfeld equation
C
c***********************************************************************
c     Common variables
c***********************************************************************
      parameter   (imax=50000)
      integer     n
      complex     alpha, c
      real        U(0:imax), d2U(0:imax), Re, ymin, ymax, h, beta
      real        Uspl(0:imax), d2Uspl(0:imax), ydat(0:imax), f2p

      common      /setup/ nbl, alpha, u, d2u, Re, ymin, ymax, h, c,
     &                    f2p, beta, uspl, d2uspl, ydat
c***********************************************************************
      integer     neq
      complex     yo(neq), yf(neq)
      real        t
      real        UU, d2UU
      real        Pi
      pi = acos(-1.0)
c
c     Get the velocity field
c
#ifdef USE_SPINE_DERIVATIVE
      call SPEVAL(nbl+1,ydat,U,Uspl,t,UU)
      call SPEVAL(nbl+1,ydat,d2U,d2Uspl,t,d2UU)
#else
      call SPDER(nbl+1,ydat,U,Uspl,t,UU,dUU,d2UU)
#endif
      do j = 1 , neq-1
        yf(j) = yo(j+1)
      end do
      yf(neq) = 2.*alpha**2*yo(3)-alpha**4*yo(1) +
     &          (0.,1.)*alpha*Re*((UU-c)*(yo(3)-alpha**2*yo(1))-
     &          d2UU*yo(1))

      return
      end

C***********************************************************************
      subroutine SOLVE_BL
C***********************************************************************
C
C     Integrate the boundary layer similarity equation to get velocity
C     profile.
C
c***********************************************************************
c     Common variables
c***********************************************************************
      parameter   (imax=50000)
      integer     n
      complex     alpha, c
      real        U(0:imax), d2U(0:imax), Re, ymin, ymax, h, beta
      real        Uspl(0:imax), d2Uspl(0:imax), ydat(0:imax), f2p

      common      /setup/ nbl, alpha, u, d2u, Re, ymin, ymax, h, c,
     &                    f2p, beta, uspl, d2uspl, ydat
c***********************************************************************
      integer     i, j, k, p
      real        xi(3,0:imax), f(3), eta(3), y
      real        k1(3), k2(3), k3(3), k4(3), err, x2old, f1old
      external    BLASIUS, RKQCR, BL
#ifdef USE_RKF45
      real t, tout, work(imax), abserr, relerr
      integer iflag, iwork(5)
#endif
      do j = 1,3
        do i = 0,nbl
          xi(j,i) = 0.0
        end do
        f(j) = 0.0
        eta(j) = 0.0
      end do
c
c     Set the boundary conditions including guess for f"(0)
c
      xi(1,0) = 0
      xi(2,0) = 0
      xi(3,0) = f2p
      err = 1.0
      p = 1
      do while ( abs(err) .gt. 1.e-10)

        do i = 1, nbl
          y = ymin + float(i)*h
#ifdef USE_NR_ODEINT
          do j = 1, 3
            eta(j) = xi(j,i-1)
          end do
          call ODEINTR(eta,3,y-h,y,1.E-7,h/2.,1.e-20,nok,nbad,
     &                 BLASIUS,RKQCR)
          do j = 1, 3
            xi(j,i) = eta(j)
          end do
#elif USE_RKF45
          t = y-h
          tout = y
          do j = 1, 3
            eta(j) = xi(j,i-1)
          end do
          relerr = 1.0e-9
          abserr = 0.0
          iflag = 1
          call RKF45(BL,3,eta,t,tout,relerr,abserr,iflag,work,iwork)
          if (iflag .ne. 2) call exit(1)
          do j = 1, 3
            xi(j,i) = eta(j)
          end do
#elif USE_LSRK14
          call SLSRK14(3, xi(1,i-1), xi(1,i), y-h, h, BLASIUS)
#elif USE_RKCK45
          call SRKCK45(3, xi(1,i-1), xi(1,i), y-h, h, BLASIUS)
#else
          call SRK4(3, xi(1,i-1), xi(1,i), y-h, h, BLASIUS)
#endif
        end do
c
c       Check f'(ymax)
c
        if (p .eq. 1) then
          xi3old = xi(3,0)
          xi(3,0) = xi(3,0)*.99
        else
          xi3temp = xi(3,0)
          xi(3,0) = xi(3,0)+((xi3old-xi(3,0))/(xi2old-xi(2,nbl)))*
     &              (1.0 - xi(2,nbl))
          xi3old = xi3temp
        end if
        p = p + 1
        xi2old = xi(2,nbl)
        err = 1.0 - xi2old
c       write (*,*) p, err
      end do
c
c     Now assemble the velocity field
c
      do i = 0, nbl
        u(i) = xi(2,i)
      end do
c
c     Compute 2nd order finite difference approximation to
c     second derivative
c
      do i = 1, nbl-1
        d2u(i) = (u(i+1)-2*u(i)+u(i-1))/(h)**2
      end do
      d2u(0) = (-u(4)+4*u(3)-5*u(2)+2*u(1))/(h)**2
      d2u(nbl) = (2*u(nbl)-5*u(nbl-1)+4*u(nbl-2)-u(nbl-3))/(h)**2
c
c     Need to interpolate the velocity profile to evaluate it at
c     arbitrary y
c
      do i = 0, nbl
        ydat(i) = ymin + i*h
      end do
      call SPLINE(nbl+1,ydat,u,uspl)
c
c     Use the spline result for the second derivative instead of FD
c
      do i = 0, nbl
        d2u(i) = uspl(i)
      end do
      call SPLINE(nbl+1,ydat,d2u,d2uspl)

c     open (10, FILE='bl.dat', ACTION='WRITE', FORM='FORMATTED')
      do i = 0, nbl
        y = ymin + i*h
#ifdef USE_SPLINE_DERIVATIVE
        call SPEVAL(nbl+1,ydat,u,uspl,y,us)
        call SPEVAL(nbl+1,ydat,d2u,d2uspl,y,d2us)
        write (10,10) y, us, d2us, u(i), d2u(i)
#else
        call SPDER(nbl+1,ydat,u,uspl,y,us,dus,d2us)
#ifdef USE_OUTPUT_DERIVATIVE
        write (10,10) y, us, dus, d2us, u(i), d2u(i)
#else
        write (10,10) y, us, d2us, u(i), d2u(i)
#endif
#endif
  10    format (1x,7(ES16.8E3,1x))
      end do
c     close(10)

      write (*,20)
  20  format (1x,'Blasius velocity profile completed...',/)

      return
      end

C***********************************************************************
      subroutine BLASIUS(neq,xi,y,f)
C***********************************************************************
C
C     Function evaluation for the boundary-layer similarity equation
C
c***********************************************************************
c     Common variables
c***********************************************************************
      parameter   (imax=50000)
      integer     nbl
      complex     alpha, c
      real        U(0:imax), d2U(0:imax), Re, ymin, ymax, h, beta
      real        Uspl(0:imax), d2Uspl(0:imax), ydat(0:imax), f2p

      common      /setup/ nbl, alpha, u, d2u, Re, ymin, ymax, h, c,
     &                    f2p, beta, uspl, d2uspl, ydat
c***********************************************************************
      integer     neq
      real        xi(neq), f(neq), y

      do j = 1 , 2
        f(j) = xi(j+1)
      end do
      f(3) = -xi(1)*xi(3)-beta*(1.-xi(2)**2)

      return
      end

C***********************************************************************
      subroutine READI(string, I)
C***********************************************************************
C
C     Read an integer from an input file
C
c***********************************************************************

      integer   I, iloc, floc
      character string*80

      iloc = index (string,'=')
      if (iloc .ne. 0) then
        iloc = iloc + 1
        floc = index (string,'#')
        if (floc .eq. 0) then
          floc = 80
        else
          floc = floc - 1
        end if
        read (string(iloc:floc),'(I10)',err=99) I
      else
        write (*,10)
  10    format (/,/,1x,'ERROR in input file...',/,/)
        stop
      end if
      goto 100
c
c     Error
c
  99  continue
      write (*,10)
      stop

 100  return
      end

C***********************************************************************
      subroutine READR(string, R)
C***********************************************************************
C
C     Read an integer from an input file
C
c***********************************************************************
      integer    iloc, floc
      real       R
      character  string*80

      iloc = index (string,'=')
      if (iloc .ne. 0) then
        iloc = iloc + 1
        floc = index (string,'#')
        if (floc .eq. 0) then
          floc = 80
        else
          floc = floc - 1
        end if
        read (string(iloc:floc),'(g20.10)',err=99) R
      else
        write (*,10)
 10     format (/,/,1x,'ERROR in input file...',/,/)
        stop
      end if
      goto 100
c
c     Error
c
  99  continue
      write (*,10)
      stop

 100  return
      end


      DOUBLE PRECISION FUNCTION dcddexpm1(x)
C**********************************************************************
C
C      DOUBLE PRECISION FUNCTION dcddexpm1(x)
C            Evaluation of the function EXP(X) - 1
C
C
C                              Arguments
C
C
C     X --> Argument at which exp(x)-1 desired
C                    DOUBLE PRECISION X
C
C
C                              Method
C
C
C     Renaming of function rexp from code of:
C
C     DiDinato, A. R. and Morris,  A.   H.  Algorithm 708: Significant
C     Digit Computation of the Incomplete  Beta  Function Ratios.  ACM
C     Trans. Math.  Softw. 18 (1993), 360-373.
C
C**********************************************************************
C     .. Scalar Arguments ..
      DOUBLE PRECISION x
C     ..
C     .. Local Scalars ..
      DOUBLE PRECISION p1,p2,q1,q2,q3,q4,w
C     ..
C     .. Intrinsic Functions ..
      INTRINSIC abs,exp
C     ..
C     .. Data statements ..
      DATA p1/.914041914819518D-09/,p2/.238082361044469D-01/,
     +     q1/-.499999999085958D+00/,q2/.107141568980644D+00/,
     +     q3/-.119041179760821D-01/,q4/.595130811860248D-03/
C     ..
C     .. Executable Statements ..
C
      IF (abs(x).GT.0.15D0) GO TO 10
      dcddexpm1 = x* (((p2*x+p1)*x+1.0D0)/
     +         ((((q4*x+q3)*x+q2)*x+q1)*x+1.0D0))
      RETURN
C
   10 w = exp(x)
      IF (x.GT.0.0D0) GO TO 20
      dcddexpm1 = (w-0.5D0) - 0.5D0
      RETURN

   20 dcddexpm1 = w* (0.5D0+ (0.5D0-1.0D0/w))
      RETURN

      END


c. This subroutine randomly assigns the droplet position and
c. remove the drops when they are in the parcel. (j.ge.M2)
c. and (j.le.M3)

	subroutine assign(ndrop,ngrid,jcell_pop,delta_x
     1  ,m1,x,dsize,csize,icat,M2,M3,BL,igrid)
	parameter(idimen=5000)

	integer*4 igrid
	double precision rand

	dimension jcell_pop(0:10,igrid)
        real*8 dsize(idimen),csize(idimen),rnr(idimen)
	real*8  x(idimen)
	real*8 delta_x
	integer icat(idimen)
	real*8 pjw

c. initialize jcell_pop(0,j) which is the index
c. used in drop_map.f

	do j=1,ngrid
	jcell_pop(0,j)=0
	end do

	ncut=0
	icount=0

c. ncut : a active iteration index to update the droplet
c. index when they fall in the diluted parcel
	do k=1,ndrop

c. ndrop: original droplet input number

 	ichange=k
	i=k-ncut

c. randomly assign j_cell for drop(i)
c. also find x(i) corrosponding to this j_cell for drop(i)
c. note: in here x(i)=0 when j=M1, this is for consistent
c. the x(i) definition in d.f
c
 330    continue
Copen(25,file='assigd.dat') --060796 -earlier one
Copen(25,file='assigd.dat1')
	open(25,file='assigd_100m.dat')

Copen(25,file='a2.dat')
	read(25,*)rand_no
	icount=icount+1
	j=int(rand_no*ngrid)+m1
	if((j.ge.m2).and.(j.le.m3))goto 330
	pjw0=float(j-m1)
	x(i)=pjw0*delta_x+0.5*delta_x
	if(x(i).gt.BL)then
	  x(i)=x(i)-BL
	endif
	j_old=j
	dsize(i)=dsize(ichange)
	csize(i)=csize(ichange)
	rnr(i)=rnr(ichange)
	icat(i)=icat(ichange)
c.
c. make the drop's index jcell_pop
c. note check this: j become j-m1 in d.f
	pjw=x(i)/delta_x
	j=INT(pjw)+M1
	jcell_pop(0,j-m1+1)=jcell_pop(0,j-m1+1)+1

c
c 12-27-96 comment out the drops assigning at different cell
c

	if(jcell_pop(0,j-m1+1).ge.2)then
 	jcell_pop(0,j-m1+1)=1
	goto 330
	endif

	jcell_pop(jcell_pop(0,j-m1+1),j-m1+1)=i
	end do
	write(*,*)'icount=',icount

	ndrop=ndrop-ncut

	return
	end


MODULE mo_mad

  ! This module provides a median absolute deviation (MAD) test

  ! Written March 2011, Matthias Cuntz

  ! License
  ! -------
  ! This file is part of the JAMS Fortran package, distributed under the MIT License.
  !
  ! Copyright (c) 2011 Matthias Cuntz - mc (at) macu (dot) de
  !
  ! Permission is hereby granted, free of charge, to any person obtaining a copy
  ! of this software and associated documentation files (the "Software"), to deal
  ! in the Software without restriction, including without limitation the rights
  ! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
  ! copies of the Software, and to permit persons to whom the Software is
  ! furnished to do so, subject to the following conditions:
  !
  ! The above copyright notice and this permission notice shall be included in all
  ! copies or substantial portions of the Software.
  !
  ! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
  ! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
  ! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
  ! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
  ! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
  ! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
  ! SOFTWARE.

  USE mo_kind,       ONLY: i4, sp, dp
  USE mo_percentile, ONLY: median

  Implicit NONE

  PUBLIC :: mad             ! Mean absolute deviation test

  ! ------------------------------------------------------------------

  !     NAME
  !         mad

  !     PURPOSE
  !         Mean absolute deviation test with optional z-value (default: 7) and mask,
  !         and 3 optional variants: 0. raw values (default), 1. 1st derivative, 2. 2nd derivative
  !         Returns mask with true everywhere except where <(median-MAD*z/0.6745) or >(md+MAD*z/0.6745)
  !
  !         If an optinal mask is given, the mad test is only performed on those locations that correspond
  !         to true values in the mask.

  !     CALLING SEQUENCE
  !         out = mad(vec, z=z, mask=mask, deriv=deriv)

  !     INTENT(IN)
  !         real(sp/dp) :: vec(:)     1D-array with input numbers

  !     INTENT(INOUT)
  !         None

  !     INTENT(OUT)
  !         logical :: out            mask with true everywhere except where input deviates more
  !                                   than z standard deviations from median

  !     INTENT(IN), OPTIONAL
  !         real(sp/dp) :: z          Input is allowed to deviate maximum z standard deviations from the median (default: 7)
  !         integer(i4) :: deriv      0: Act on raw input (default: 0)
  !                                   1: Use first derivatives
  !                                   2: Use 2nd derivatives
  !         logical     :: mask(:)    1D-array of logical values with size(vec).
  !                                   If present, only those locations in vec corresponding to the true values in mask are used.

  !     INTENT(INOUT), OPTIONAL
  !         None

  !     INTENT(OUT), OPTIONAL
  !         None

  !     RESTRICTIONS
  !         1st derivative is
  !             d = datin[1:n]-datin[0:n-1]
  !         because mean of left and right would give 0 for spikes.

  !     EXAMPLE
  !         vec = (/ -0.25,0.68,0.94,1.15,2.26,2.35,2.37,2.40,2.47,2.54,2.62, &
  !                   2.64,2.90,2.92,2.92,2.93,3.21,3.26,3.30,3.59,3.68,4.30, &
  !                   4.64,5.34,5.42,8.01 /)
  !         mask(:) = true
  !         ! Sets last entry false
  !         mask = mask .and. mad(vec, z=4., deriv=0, mask=mask)
  !         -> see also example in test directory

  !     LITERATURE
  !         None

  !     HISTORY
  !         Written,  Matthias Cuntz, Mar 2011
  INTERFACE mad
     MODULE PROCEDURE mad_sp, mad_dp
  END INTERFACE mad

  ! ------------------------------------------------------------------

  PRIVATE

  ! ------------------------------------------------------------------

CONTAINS

  ! ------------------------------------------------------------------

  FUNCTION mad_dp(arr, z, mask, deriv)

    IMPLICIT NONE

    REAL(dp),    DIMENSION(:),           INTENT(IN) :: arr
    REAL(dp),                  OPTIONAL, INTENT(IN) :: z
    LOGICAL,     DIMENSION(:), OPTIONAL, INTENT(IN) :: mask
    INTEGER(i4),               OPTIONAL, INTENT(IN) :: deriv
    LOGICAL,     DIMENSION(size(arr))               :: mad_dp

    LOGICAL,  DIMENSION(size(arr)) :: maske
    REAL(dp), DIMENSION(size(arr)) :: d
    LOGICAL,  DIMENSION(size(arr)) :: dmask
    INTEGER(i4) :: n, ideriv
    !INTEGER(i4) :: m
    REAL(dp)    :: iz, med, mabsdev, thresh

    n = size(arr)
    maske(:) = .true.
    if (present(mask)) then
       if (size(mask) /= n) stop 'Error mad_dp: size(mask) /= size(arr)'
       maske = mask
    endif
    if (present(z)) then
       iz = z
    else
       iz = 7.0_dp
    endif
    if (present(deriv)) then
       ideriv = deriv
    else
       ideriv = 0
    endif

    select case(ideriv)
    case(0) ! pure values
       !m       = count(maske)
       med     = median(arr,mask=maske)
       mabsdev = median(abs(arr-med),mask=maske)
       thresh  = mabsdev * iz/0.6745_dp
       mad_dp     = (arr .ge. (med-thresh)) .and. (arr .le. (med+thresh)) .and. maske
    case(1) ! 1st derivative
       ! d(1:n-2) = 0.5_dp* (arr(3:n) - arr(1:n-2)) ! does not work -> ask Clemens & Matthias M
       d(1:n-1)     = arr(2:n) - arr(1:n-1)
       dmask(1:n-1) = maske(2:n) .and. maske(1:n-1)
       !m            = count(dmask(1:n-1))
       med          = median(d(1:n-1),mask=dmask(1:n-1))
       mabsdev      = median(abs(d(1:n-1)-med),mask=dmask(1:n-1))
       thresh       = mabsdev * iz/0.6745_dp
       mad_dp(n)       = .true.
       mad_dp(1:n-1)   = (d(1:n-1) .ge. (med-thresh)) .and. (d(1:n-1) .le. (med+thresh)) .and. dmask(1:n-1)
    case(2) ! -2nd derivative
       d(1:n-2)     = arr(2:n-1) + arr(2:n-1) - arr(1:n-2) - arr(3:n)
       dmask(1:n-2) = maske(2:n-1) .and. maske(1:n-2) .and. maske(3:n)
       !m            = count(dmask(1:n-2))
       med          = median(d(1:n-2),mask=dmask(1:n-2))
       mabsdev      = median(abs(d(1:n-2)-med),mask=dmask(1:n-2))
       thresh       = mabsdev * iz/0.6745_dp
       mad_dp(1)       = .true.
       mad_dp(n)       = .true.
       mad_dp(2:n-1)   = (d(1:n-2) .ge. (med-thresh)) .and. (d(1:n-2) .le. (med+thresh)) .and. dmask(1:n-2)
    case default
       stop 'Unimplemented option in mad_dp'
    end select

  END FUNCTION mad_dp

  FUNCTION mad_sp(arr, z, mask, deriv)

    IMPLICIT NONE

    REAL(sp),    DIMENSION(:),           INTENT(IN) :: arr
    REAL(sp),                  OPTIONAL, INTENT(IN) :: z
    LOGICAL,     DIMENSION(:), OPTIONAL, INTENT(IN) :: mask
    INTEGER(i4),               OPTIONAL, INTENT(IN) :: deriv
    LOGICAL,     DIMENSION(size(arr))               :: mad_sp

    LOGICAL,  DIMENSION(size(arr)) :: maske
    REAL(sp), DIMENSION(size(arr)) :: d
    LOGICAL,  DIMENSION(size(arr)) :: dmask
    INTEGER(i4) :: n, ideriv
    !INTEGER(i4) :: m
    REAL(sp)    :: iz, med, mabsdev, thresh

    n = size(arr)
    maske(:) = .true.
    if (present(mask)) then
       if (size(mask) /= n) stop 'Error mad_sp: size(mask) /= size(arr)'
       maske = mask
    endif
    if (present(z)) then
       iz = z
    else
       iz = 7.0_sp
    endif
    if (present(deriv)) then
       ideriv = deriv
    else
       ideriv = 0
    endif

    select case(ideriv)
    case(0) ! pure values
       !m       = count(maske)
       med     = median(arr,mask=maske)
       mabsdev = median(abs(arr-med),mask=maske)
       thresh  = mabsdev * iz/0.6745_sp
       mad_sp     = (arr .ge. (med-thresh)) .and. (arr .le. (med+thresh)) .and. maske
    case(1) ! 1st derivative
       ! d(1:n-2) = 0.5_sp* (arr(3:n) - arr(1:n-2)) ! does not work -> ask Clemens & Matthias M
       d(1:n-1)     = arr(2:n) - arr(1:n-1)
       dmask(1:n-1) = maske(2:n) .and. maske(1:n-1)
       !m            = count(dmask(1:n-1))
       med          = median(d(1:n-1),mask=dmask(1:n-1))
       mabsdev      = median(abs(d(1:n-1)-med),mask=dmask(1:n-1))
       thresh       = mabsdev * iz/0.6745_sp
       mad_sp(n)       = .true.
       mad_sp(1:n-1)   = (d(1:n-1) .ge. (med-thresh)) .and. (d(1:n-1) .le. (med+thresh)) .and. dmask(1:n-1)
    case(2) ! -2nd derivative
       d(1:n-2)     = arr(2:n-1) + arr(2:n-1) - arr(1:n-2) - arr(3:n)
       dmask(1:n-2) = maske(2:n-1) .and. maske(1:n-2) .and. maske(3:n)
       !m            = count(dmask(1:n-2))
       med          = median(d(1:n-2),mask=dmask(1:n-2))
       mabsdev      = median(abs(d(1:n-2)-med),mask=dmask(1:n-2))
       thresh       = mabsdev * iz/0.6745_sp
       mad_sp(1)       = .true.
       mad_sp(n)       = .true.
       mad_sp(2:n-1)   = (d(1:n-2) .ge. (med-thresh)) .and. (d(1:n-2) .le. (med+thresh)) .and. dmask(1:n-2)
    case default
       stop 'Unimplemented option in mad_sp'
    end select

  END FUNCTION mad_sp

  ! ------------------------------------------------------------------

END MODULE mo_mad


program integer_kinds
    implicit none
    integer :: range
    integer :: kind

    do range = 0, 45
        kind = selected_int_kind(range)
        print *, range, kind
    end do
end program integer_kinds


! 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
!
! test for negative operation of quad precision.

program test
  use check_mod
  integer, parameter :: n = 6
  real(16) :: c1, rst1, rst2
  real(16) :: rst3 = - (-15.213513214321532163123412431412417090_16)
  real(16), parameter :: rst4 = - (-1.2135132143215321631234124311241709083_16)
  real(16), parameter :: rst5(2) = - [1.0_16, -3.0_16]
  real(16) :: result(n), expect(n)

  c1 = 42.58879788522658767867845243213578_16

  rst1 = - c1
  rst2 = -(-7.1233687476876737257454577868787564_16)

  expect(1) = -42.58879788522658767867845243213578_16
  expect(2) = 7.1233687476876737257454577868787564_16
  expect(3) = 15.213513214321532163123412431412417090_16
  expect(4) = 1.2135132143215321631234124311241709083_16
  expect(5) = -1.0_16
  expect(6) = 3.0_16

  result(1) = rst1
  result(2) = rst2
  result(3) = rst3
  result(4) = rst4
  result(5) = rst5(1)
  result(6) = rst5(2)

  call checkr16(result, expect, n)
end


c------------------------------------------------------------
      subroutine ZETA(T,Q,USR,TSR,QSR,Z,ZL)
C
C TO EVALUATE OBUKHOVS STABILITY PARAMETER Z/L FROM AVERAGE
C TEMP T IN DEG C, AVERAGE HUMIDITY Q IN GM/GM, HEIGHT IN M,
C AND FRICTIONAL VEL,TEMP.,HUM. IN MKS UNITS
C SEE LIU ET AL. (1979)
C
      real*8 T,Q,OB,TVSR,TV,TA,sgn
      real*8 USR,TSR,QSR,Z,ZL
      real*8 al,beta,cpa,cpw,grav,xlv,rhoa,rhow,rgas,toK,visa
      real*8 visw,von,fdg
      COMMON/const/al,beta,cpa,cpw,grav,xlv,rhoa,rhow,rgas,toK,
     &             visa,visw,von,fdg
c
      TA=T+toK
      TV=TA*(1.+0.61*Q)
      TVSR=TSR*(1.+0.61*Q)+0.61*TA*QSR
      sgn=sign(1.,tvsr)               !added this to avoid program
      if(abs(tvsr) .lt. 1.e-3) then   !failure when TVSR is very small
         tvsr=sgn*tvsr
      endif
      OB=TV*USR*USR/(grav*VON*TVSR)
      ZL=Z/OB
      if(ZL .gt. 1000) ZL=1000.
      goto 99
   10 ZL=0.
   99 return
      end


      SUBROUTINE FTRNEX(DTA)
C
C THIS IS THE MAIN COMPUTATIONAL PROCEDURE FOR ONE EXPLICIT TIME-
C STEP. THIS TIMESTEPPING IS DONE FOR THE PROGNOSTIC VARIABLES
C GEOPOTENTIAL, DIVERGENCE AND VORTICITY (SPECTRAL TRANSFORM
C ALGORITHM), USING A LEAPFROG TIMESTEPPING ALGORITHM.
C THE OLD TIMELEVEL IS LNM1, THE DERIVATIVE IS EVALUATED AT
C TIMELEVEL LN, AND THE COMPUTED VALUES GO INTO TIMELEVEL LNP1.
C THE FORCING TERMS ARE ADDED FOR TEST CASE 4, USING
C THE ROUTINE FORCE TO OBTAIN THE GRID FORCING.
C THE NONLINEAR PRODUCTS ARE EVALUATED AT THE GRIDPOINTS, AND
C A FFT TRANSFORM (FFT991) IS USED FOR EACH LATITUDE.
C THE NEW TIMELEVEL SPECTRAL COEFFICIENTS ARE COMPUTED BY THE
C ROUTINES
C VORTICITY: FTRNVE
C DIVERGENCE: FTRNDE
C GEOPOTENTIAL: FTRNPE
C
C CALLED BY: COMP1
C CALLS: FFT991, FORCE, FTRNDE, FTRNPE, FTRNVE, GLAT
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 TIME DEPENDENT FIELDS
      INCLUDE 'tdvars.i'
C CONSTANTS & TIMESTEPS
      INCLUDE 'consts.i'
C WORKSPACE
      INCLUDE 'wrkspc.i'
C MOUNTAIN DATA FOR CASE 5
      INCLUDE 'finit.i'
C
C------------ Arguments ------------------------------------------------
C
C     Input
C
C TIMESTEP IN SECONDS
      REAL DTA
C
C------ Local Variables ------------------------------------------------
C
C     EQUIVALENCE TO STORAGE POOL IN COMMON BLOCK WRKSPC WHERE POSSIBLE
C
      REAL TRMA(NLON+2,NLAT), TRMB(NLON+2,NLAT),
     $     TRMC(NLON+2,NLAT), TRMD(NLON+2,NLAT),
     $     TRME(NLON+2,NLAT), TRMF(NLON+2,NLAT),
     $     TRMG(NLON+2,NLAT), TRMH(NLON+2,NLAT)
      COMPLEX TRMAFC(NFC,NLAT), TRMBFC(NFC,NLAT),
     $        TRMCFC(NFC,NLAT), TRMDFC(NFC,NLAT),
     $        TRMEFC(NFC,NLAT), TRMFFC(NFC,NLAT),
     $        TRMGFC(NFC,NLAT), TRMHFC(NFC,NLAT)
      EQUIVALENCE (TRMA(1,1), TRMAFC(1,1), WS1(1,1)),
     $            (TRMB(1,1), TRMBFC(1,1), WS2(1,1)),
     $            (TRMC(1,1), TRMCFC(1,1), WS3(1,1)),
     $            (TRMD(1,1), TRMDFC(1,1), WS4(1,1)),
     $            (TRME(1,1), TRMEFC(1,1), WS5(1,1)),
     $            (TRMF(1,1), TRMFFC(1,1), WS6(1,1)),
     $            (TRMG(1,1), TRMGFC(1,1), WS7(1,1)),
     $            (TRMH(1,1), TRMHFC(1,1), WS8(1,1))
C
C     FORCING TERMS (PHYSICAL & SPECTRAL)
C
      REAL ETAFCG(NLON+2,NLAT), DIVFCG(NLON+2,NLAT),
     $     PHIFCG(NLON+2,NLAT)
C
C     TEMPORARIES
C
      REAL FAC,RLAT
      INTEGER I,J,L
C
C----- External Functions ----------------------------------------------
C
C     GAUSSIAN LATITUDES
C
      REAL GLAT
      EXTERNAL GLAT
C
C----- Executable Statements -------------------------------------------
C
C     MAIN COMPUTATIONAL ROUTINE
C
C     ZERO TERMS FOR LATER ACCUMULATIONS
C
      DO 815 L=1,NALP
         ZETASC(L) = (0.0,0.0)
         DIVSC(L) = (0.0,0.0)
         PHISC(L) = (0.0,0.0)
  815 CONTINUE
C
C     COMPUTE THE MOMENTUM FORCING TERMS (TEST CASE 4)
C
      IF (FORCED) THEN
         CALL FORCE(ETAFCG,DIVFCG,PHIFCG)
      ENDIF
C
C     EVALUATE NON-LINEAR ADVECTION TERMS
C     AND OLD TIMELEVEL OF VORTICITY, DIVERGENCE, GEOPOTENTIAL
C
      DO 20 J=1,NLAT
         RLAT = GLAT(J)
C
C        LATITUDE = RLAT
C
         FAC = 1.0/(2.0*COS(RLAT)**2)
         DO 10 I=1,NLON
            TRMA(I,J) = UCOS(I,J)*ZETA(I,J,LN)
            TRMB(I,J) = VCOS(I,J)*ZETA(I,J,LN)

            IF (FORCED .AND. MOMENT) THEN
               TRMA(I,J) = TRMA(I,J)-DIVFCG(I,J)
               TRMB(I,J) = TRMB(I,J)+ETAFCG(I,J)
            ENDIF
            TRMC(I,J) = UCOS(I,J)*PHI(I,J,LN)
            TRMD(I,J) = VCOS(I,J)*PHI(I,J,LN)
            TRME(I,J) = ZETA(I,J,LNM1)
            IF (FORCED .AND. (.NOT. MOMENT)) THEN
               TRME(I,J) = TRME(I,J)+DTA*ETAFCG(I,J)
            ENDIF
            TRMF(I,J) = DIV(I,J,LNM1)
            IF (FORCED .AND. (.NOT. MOMENT)) THEN
               TRMF(I,J) = TRMF(I,J)+DTA*DIVFCG(I,J)
            ENDIF
            TRMG(I,J) = (UCOS(I,J)**2 + VCOS(I,J)**2)*FAC +
     $                  PHI(I,J,LN)
            IF (FTOPO) THEN
               TRMG(I,J) = TRMG(I,J) + GRAV*MOUNT(I,J)
            ENDIF
            TRMH(I,J) = PHI(I,J,LNM1) - DTA*PHIBAR*DIV(I,J,LN)
            IF (FORCED) THEN
               TRMH(I,J) = TRMH(I,J) + DTA*PHIFCG(I,J)
            ENDIF
   10    CONTINUE
   20 CONTINUE
C
C     FOURIER TRANSFORM NON-LINEAR TERMS IN PLACE
C
      CALL FFT991(TRMA,FFTWS2,TRIGS,IFAX,1,NLON+2,NLON,NLAT,-1)
      CALL FFT991(TRMB,FFTWS2,TRIGS,IFAX,1,NLON+2,NLON,NLAT,-1)
      CALL FFT991(TRMC,FFTWS2,TRIGS,IFAX,1,NLON+2,NLON,NLAT,-1)
      CALL FFT991(TRMD,FFTWS2,TRIGS,IFAX,1,NLON+2,NLON,NLAT,-1)
      CALL FFT991(TRME,FFTWS2,TRIGS,IFAX,1,NLON+2,NLON,NLAT,-1)
      CALL FFT991(TRMF,FFTWS2,TRIGS,IFAX,1,NLON+2,NLON,NLAT,-1)
      CALL FFT991(TRMG,FFTWS2,TRIGS,IFAX,1,NLON+2,NLON,NLAT,-1)
      CALL FFT991(TRMH,FFTWS2,TRIGS,IFAX,1,NLON+2,NLON,NLAT,-1)
C
C     FWD LEGENDRE TRANSFORM & UPDATE OF VORTICITY SPECTRAL COEFFICIENTS
C
      CALL FTRNVE (DTA, TRMAFC, TRMBFC, TRMEFC, ZETASC)
C
C     FWD LEGENDRE TRANSFORM NONLINEAR TERMS AND TIMESTEPPING
C     IN DIVERGENCE EQUATION
C
      CALL FTRNDE (DTA, TRMAFC, TRMBFC, TRMFFC, TRMGFC, DIVSC)
C
C     FWD LEGENDRE TRANSFORM NONLINEAR TERMS IN CONTINUITY EQUATION
C     (BECOMES ADVECTION EQUATION FOR NONDIVERGENT FIELD)
C
      CALL FTRNPE (DTA, TRMCFC, TRMDFC, TRMHFC, PHISC)
C
      RETURN
C
      END


      double complex function ttbqqbtqpp(k1,k2,k3,k4,k5,k6,k7)
      implicit none
      include 'constants.f'
      include 'sprods_com.f'
      include 'zprods_com.f'
      include 'masses.f'
      integer k1,k2,k3,k4,k5,k6,k7
      double precision s129,s6789,mtsq
      s129=s(k1,k2)+s(k1,k3)+s(k2,k3)
      s6789=s(k3,k6)+s(k3,k7)
      mtsq=mt**2
      ttbqqbtqpp =  + s129**(-1) * (  - 1/(za(k1,k2))/(za(k5,k3))/(zb(
     &    k1,k2))*za(k1,k5)**2*za(k6,k7)*zb(k1,k3)*zb(k2,k6)*zb(k4,k5)
     &     + 1/(za(k1,k2))/(za(k5,k3))/(zb(k1,k2))*za(k1,k5)**2*za(k6,
     &    k7)*zb(k1,k6)*zb(k2,k3)*zb(k4,k5) - 1/(za(k2,k3))*za(k1,k5)*
     &    za(k6,k7)*zb(k4,k5)*zb(k6,k3) - 1/(za(k2,k3))/(za(k5,k3))*za(
     &    k1,k5)*za(k2,k5)*za(k6,k7)*zb(k2,k6)*zb(k4,k5) )
      ttbqqbtqpp = ttbqqbtqpp + s6789**(-1) * (  - 1/(za(k1,k2))/(za(k5
     &    ,k3))/(zb(k1,k2))*za(k1,k5)*za(k5,k6)*za(k6,k7)*zb(k2,k6)*zb(
     &    k4,k5)*zb(k6,k3) - 1/(za(k1,k2))/(za(k5,k3))/(zb(k1,k2))*za(
     &    k1,k5)*za(k5,k7)*za(k6,k7)*zb(k2,k7)*zb(k4,k5)*zb(k6,k3) -
     &    1/(za(k1,k2))/(zb(k1,k2))*za(k1,k5)*za(k6,k7)*zb(k2,k3)*zb(k4
     &    ,k5)*zb(k6,k3) )
      ttbqqbtqpp = ttbqqbtqpp + mtsq*s129**(-1) * ( 1/(za(k1,k2))/(za(
     &    k5,k3))/(zb(k1,k2))*za(k1,k3)*za(k5,k7)*zb(k2,k3)*zb(k4,k3)
     &     + 1/(za(k1,k2))/(za(k5,k3))/(zb(k1,k2))*za(k1,k5)*za(k1,k7)*
     &    zb(k1,k3)*zb(k2,k4) - 1/(za(k1,k2))/(za(k5,k3))/(zb(k1,k2))*
     &    za(k1,k5)*za(k1,k7)*zb(k1,k4)*zb(k2,k3) - 1/(za(k1,k2))/(za(
     &    k5,k3))/(zb(k1,k2))*za(k1,k5)*za(k2,k7)*zb(k2,k3)*zb(k2,k4)
     &     + 1/(za(k1,k2))/(za(k5,k3))/(zb(k1,k2))*za(k1,k7)*za(k2,k5)*
     &    zb(k2,k3)*zb(k2,k4) + 1/(za(k2,k3))*za(k1,k7)*zb(k4,k3) + 1/(
     &    za(k2,k3))/(za(k5,k3))*za(k1,k7)*za(k2,k5)*zb(k2,k4) )
      ttbqqbtqpp = ttbqqbtqpp + mtsq*s6789**(-1) * (  - 1/(za(k1,k2))/(
     &    za(k5,k3))/(zb(k1,k2))*za(k1,k5)*za(k5,k7)*zb(k2,k3)*zb(k4,k5
     &    ) - 1/(za(k1,k2))/(za(k5,k3))/(zb(k1,k2))*za(k1,k5)*za(k6,k7)
     &    *zb(k2,k4)*zb(k6,k3) + 1/(za(k1,k2))/(za(k5,k3))/(zb(k1,k2))*
     &    za(k1,k6)*za(k5,k7)*zb(k2,k4)*zb(k6,k3) + 1/(za(k1,k2))/(za(
     &    k5,k3))/(zb(k1,k2))*za(k1,k7)*za(k5,k7)*zb(k2,k4)*zb(k7,k3) )

      return
      end


C
C       $Id: shgivens.f,v 1.4 2008-07-27 03:10:13 haley Exp $
C
C                Copyright (C)  2000
C        University Corporation for Atmospheric Research
C                All Rights Reserved
C
C The use of this Software is governed by a License Agreement.
C
      SUBROUTINE SHGIVENS ( A,B, C,S)
      REAL A, B, C, S
C
C***********************************************************
C
C                                               ROBERT RENKA
C                                       UNIV. OF NORTH TEXAS
C                                             (817) 565-2767
C
C  This routine constructs the Givens plane rotation --
C
C      ( C  S)
C  G = (     ) where C*C + S*S = 1 -- which zeros the second
C      (-S  C)
C
C  entry of the 2-vector (A B)-transpose.  A call to SHGIVENS
C  is normally followed by a call to SHROT which applieS
C  the transformation to a 2 by N matrix.  This routine was
C  taken from LINPACK.
C
C  ON INPUT --
C
C    A,B = Components of the 2-vector to be rotated.
C
C  ON OUTPUT --
C
C    A = value overwritten by R = +/-SQRT(A*A + B*B)
C
C    B = value overwritten by a value Z which allows C
C        and S to be recovered as follows --
C
C          C = SQRT(1-Z*Z), S=Z     if ABS(Z) .LE. 1.
C          C = 1/Z, S = SQRT(1-C*C) if ABS(Z) .GT. 1.
C
C    C = +/-(A/R)
C
C    S = +/-(B/R)
C
C  MODULES REQUIRED BY SHGIVENS -- NONE
C
C  INTRINSIC FUNCTIONS CALLED BY SHGIVENS - ABS, SQRT
C
C***********************************************************
C
      REAL AA, BB, R, U, V
C
C  Local parameters --
C
C  AA,BB = local copies of A and B
C  R =     C*A + S*B = +/-SQRT(A*A+B*B)
C  U,V =   variables used to scale A and B for computing R
C
      AA = A
      BB = B
      IF (ABS(AA) .LE. ABS(BB)) GO TO 1
C
C  ABS(A) .GT. ABS(B)
C
      U = AA + AA
      V = BB/U
      IF (ABS(V) .LT. 1.E-25) V = 0.
      R = SQRT(.25 + V*V) * U
      C = AA/R
      S = V * (C + C)
C
C  Note that R has the sign of A, C .GT. 0, and S has
C  SIGN(A)*SIGN(B).
C
      B = S
      A = R
      RETURN
C
C  ABS(A) .LE. ABS(B)
C
    1 IF (BB .EQ. 0.) GO TO 2
      U = BB + BB
      V = AA/U
C
C  Store R in A.
C
      IF (ABS(V) .LT. 1.E-25) V = 0.
      A = SQRT(.25 + V*V) * U
      S = BB/A
      C = V * (S + S)
C
C  Note that R has the sign of B, S .GT. 0, and C has
C  SIGN(A)*SIGN(B).
C
      B = 1.
      IF (C .NE. 0.) B = 1./C
      RETURN
C
C  A = B = 0.
C
    2 C = 1.
      S = 0.
      RETURN
      END