      PROGRAM EXAMPLE_ZGELS_F
*
*********************************************************************
*     PLASMA example routine (version 2.8.0)
*     Author: Bilel Hadri
*     Release Date: November, 15th 2010
*     PLASMA is a software package provided by Univ. of Tennessee,
*     Univ. of California Berkeley and Univ. of Colorado Denver.
*     @precisions normal z -> c d s
*********************************************************************
*
      IMPLICIT NONE
*
      INCLUDE "plasmaf.h"
*
*     Purpose
*     =======
*
*     FORTRAN EXAMPLE FOR PLASMA_ZGELS
*     Example for solving a system of linear equations using QR factorization
*
*     =====================================================================
*
*     .. Parameters ..
      INTEGER           CORES, M, N, NRHS, LDA, LDB
      PARAMETER         ( CORES = 2 )
      PARAMETER         ( M = 20 )
      PARAMETER         ( N = 15 )
      PARAMETER         ( NRHS = 5 )
      PARAMETER         ( LDA = 20 )
      PARAMETER         ( LDB = 20 )
      COMPLEX*16        ZONE
      PARAMETER         ( ZONE = ( 1.0D+0, 0.0D+0 ) )
*     ..
*     .. Local Scalars ..
      COMPLEX*16  A1( LDA, N ), B1( LDB, NRHS )
      COMPLEX*16  A2( LDA, N ), B2( LDB, NRHS )
      COMPLEX*16  RISU( MAX(M,N), NRHS )
      DOUBLE PRECISION  RWORK( MAX(M,N) )
      INTEGER           HT( 2 )
      DOUBLE PRECISION  XNORM, ANORM, BNORM, RNORM, RESULT, EPS
      INTEGER           I, INFO
      INTEGER           ISEED( 4 )
*     ..
*     .. External Subroutines ..
      DOUBLE PRECISION  DLAMCH, ZLANGE
      EXTERNAL          ZLARNV, DLAMCH, ZLANGE
      EXTERNAL          PLASMA_INIT, PLASMA_ALLOC_WORKSPACE_ZGELS
      EXTERNAL          PLASMA_ZGELS, PLASMA_FINALIZE
      EXTERNAL          PLASMA_DEALLOC_HANDLE
      EXTERNAL          ZGEMM
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          MAX, MIN
*     ..
*     .. Executable Statements ..
*
      DO  I = 1, 3
         ISEED( I ) = 0
      ENDDO
      ISEED( 4 ) = 1
*
*     Initialize Plasma
*
      CALL PLASMA_INIT( CORES, INFO )
      WRITE(*,*) "-- PLASMA is initialized on", CORES, "cores."
*
*     Initialization of the matrix
*
      CALL ZLARNV( 1, ISEED, LDA*N, A1 )
      A2(:,:) = A1(:,:)
*
*     Initialization of the RHS
*
      CALL ZLARNV( 1, ISEED, LDB*NRHS, B1 )
      B2(:,:) = B1(:,:)

      RISU(:,:) = 0.
*
*     Allocate T
*
      CALL PLASMA_ALLOC_WORKSPACE_ZGELS( M, N, HT, INFO )
*
*     Perform the QR solve
*
      CALL PLASMA_ZGELS( PlasmaNoTrans, M, N, NRHS,
     &     A2, LDA, HT, B2, LDB, INFO )
*
*     Check the solution
*
      ANORM = ZLANGE('I', M, N,    A1, LDA, RWORK)
      XNORM = ZLANGE('I', M, NRHS, B2, LDB, RWORK)
      BNORM = ZLANGE('I', M, NRHS, B1, LDB, RWORK)

      CALL ZGEMM('No transpose','No transpose', M, NRHS, N, ZONE,
     $     A1, LDA, B2, LDB, -ZONE, B1, LDB)

      IF ( M >=N ) THEN
         CALL ZGEMM('ConjTranspose','No transpose', N, NRHS, M, ZONE,
     $        A1, LDA, B1, LDB, -ZONE, RISU, M)
         RNORM = ZLANGE('I', M, NRHS, RISU, M, RWORK)
      ELSE
         CALL ZGEMM('ConjTranspose','No transpose', N, NRHS, M, ZONE,
     $        A1, LDA, B1, LDB, -ZONE, RISU, N)
         RNORM = ZLANGE('I', N, NRHS, RISU, N, RWORK)
      ENDIF

      EPS= DLAMCH('Epsilon')
      RESULT = RNORM / ((ANORM * XNORM + BNORM) * N * EPS)

      WRITE(*,*) '============'
      WRITE(*,*) 'Checking the Residual of the solution '
      WRITE(*,*) '-- ||Ax-B||_oo/((||A||_oo||x||_oo+||B||_oo).N.eps)=',
     $     RESULT

      IF (( INFO .ne. 0 ) .OR. (RESULT > 60.0)) THEN
         WRITE(*,*) "-- Error in ZGELS example !"
      ELSE
         WRITE(*,*) "-- Run of ZGELS example successful !"
      ENDIF
*
*     Deallocate T
*
      CALL PLASMA_DEALLOC_HANDLE_TILE( HT, INFO )
*
*     Finalize Plasma
*
      CALL PLASMA_FINALIZE( INFO )
*
*     End of EXAMPLE_ZGELS.
*
      END PROGRAM EXAMPLE_ZGELS_F


    MODULE blas_dense_mat_mov

      ! Fortran 95 Bindings Generic Interface Blocks
      ! .  for section 2.8.9 -- Data Movement with Matrices
      ! .  using external procedures.
      ! Written on 14 December 2000
      ! .  Zohair Maany and Sven Hammarling, NAG Central Office.

      PRIVATE
      PUBLIC :: ge_copy, gb_copy, sy_copy, sb_copy, sp_copy, tr_copy, tb_copy, &
       tp_copy, he_copy, hb_copy, hp_copy, ge_trans, ge_permute

      INTERFACE ge_copy
        ! a has shape (m,n)
        ! b has same shape as a if trans = blas_no_trans
        ! . has shape (n,m)     if trans /= blas_no_trans
        SUBROUTINE ge_copy_d(a,b,trans)
          USE blas_operator_arguments, ONLY : blas_trans_type
          USE blas_precision, ONLY : wp => dp
          REAL (wp), INTENT (IN) :: a(:,:)
          REAL (wp), INTENT (OUT) :: b(:,:)
          TYPE (blas_trans_type), INTENT (IN), OPTIONAL :: trans
        END SUBROUTINE ge_copy_d
        SUBROUTINE ge_copy_z(a,b,trans)
          USE blas_operator_arguments, ONLY : blas_trans_type
          USE blas_precision, ONLY : wp => dp
          COMPLEX (wp), INTENT (IN) :: a(:,:)
          COMPLEX (wp), INTENT (OUT) :: b(:,:)
          TYPE (blas_trans_type), INTENT (IN), OPTIONAL :: trans
        END SUBROUTINE ge_copy_z
        SUBROUTINE ge_copy_s(a,b,trans)
          USE blas_operator_arguments, ONLY : blas_trans_type
          USE blas_precision, ONLY : wp => sp
          REAL (wp), INTENT (IN) :: a(:,:)
          REAL (wp), INTENT (OUT) :: b(:,:)
          TYPE (blas_trans_type), INTENT (IN), OPTIONAL :: trans
        END SUBROUTINE ge_copy_s
        SUBROUTINE ge_copy_c(a,b,trans)
          USE blas_operator_arguments, ONLY : blas_trans_type
          USE blas_precision, ONLY : wp => sp
          COMPLEX (wp), INTENT (IN) :: a(:,:)
          COMPLEX (wp), INTENT (OUT) :: b(:,:)
          TYPE (blas_trans_type), INTENT (IN), OPTIONAL :: trans
        END SUBROUTINE ge_copy_c
      END INTERFACE

      INTERFACE gb_copy
        ! a has shape (kl+ku+1,n), ku=SIZE(a,1)-1-kl
        ! b has same shape as a     if trans = blas_no_trans
        ! . has shape ((kl+ku+1,m)  if trans /= blas_no_trans
        SUBROUTINE gb_copy_d(a,b,m,kl,trans)
          USE blas_operator_arguments, ONLY : blas_trans_type
          USE blas_precision, ONLY : wp => dp
          REAL (wp), INTENT (IN) :: a(:,:)
          INTEGER, INTENT (IN) :: m, kl
          REAL (wp), INTENT (OUT) :: b(:,:)
          TYPE (blas_trans_type), INTENT (IN), OPTIONAL :: trans
        END SUBROUTINE gb_copy_d
        SUBROUTINE gb_copy_z(a,b,m,kl,trans)
          USE blas_operator_arguments, ONLY : blas_trans_type
          USE blas_precision, ONLY : wp => dp
          COMPLEX (wp), INTENT (IN) :: a(:,:)
          INTEGER, INTENT (IN) :: m, kl
          COMPLEX (wp), INTENT (OUT) :: b(:,:)
          TYPE (blas_trans_type), INTENT (IN), OPTIONAL :: trans
        END SUBROUTINE gb_copy_z
        SUBROUTINE gb_copy_s(a,b,m,kl,trans)
          USE blas_operator_arguments, ONLY : blas_trans_type
          USE blas_precision, ONLY : wp => sp
          REAL (wp), INTENT (IN) :: a(:,:)
          INTEGER, INTENT (IN) :: m, kl
          REAL (wp), INTENT (OUT) :: b(:,:)
          TYPE (blas_trans_type), INTENT (IN), OPTIONAL :: trans
        END SUBROUTINE gb_copy_s
        SUBROUTINE gb_copy_c(a,b,m,kl,trans)
          USE blas_operator_arguments, ONLY : blas_trans_type
          USE blas_precision, ONLY : wp => sp
          COMPLEX (wp), INTENT (IN) :: a(:,:)
          INTEGER, INTENT (IN) :: m, kl
          COMPLEX (wp), INTENT (OUT) :: b(:,:)
          TYPE (blas_trans_type), INTENT (IN), OPTIONAL :: trans
        END SUBROUTINE gb_copy_c
      END INTERFACE

      INTERFACE sy_copy
        ! a and b have shape (n,n)
        SUBROUTINE sy_copy_d(a,b,uplo)
          USE blas_operator_arguments, ONLY : blas_uplo_type
          USE blas_precision, ONLY : wp => dp
          REAL (wp), INTENT (IN) :: a(:,:)
          REAL (wp), INTENT (OUT) :: b(:,:)
          TYPE (blas_uplo_type), INTENT (IN), OPTIONAL :: uplo
        END SUBROUTINE sy_copy_d
        SUBROUTINE sy_copy_z(a,b,uplo)
          USE blas_operator_arguments, ONLY : blas_uplo_type
          USE blas_precision, ONLY : wp => dp
          COMPLEX (wp), INTENT (IN) :: a(:,:)
          COMPLEX (wp), INTENT (OUT) :: b(:,:)
          TYPE (blas_uplo_type), INTENT (IN), OPTIONAL :: uplo
        END SUBROUTINE sy_copy_z
        SUBROUTINE sy_copy_s(a,b,uplo)
          USE blas_operator_arguments, ONLY : blas_uplo_type
          USE blas_precision, ONLY : wp => sp
          REAL (wp), INTENT (IN) :: a(:,:)
          REAL (wp), INTENT (OUT) :: b(:,:)
          TYPE (blas_uplo_type), INTENT (IN), OPTIONAL :: uplo
        END SUBROUTINE sy_copy_s
        SUBROUTINE sy_copy_c(a,b,uplo)
          USE blas_operator_arguments, ONLY : blas_uplo_type
          USE blas_precision, ONLY : wp => sp
          COMPLEX (wp), INTENT (IN) :: a(:,:)
          COMPLEX (wp), INTENT (OUT) :: b(:,:)
          TYPE (blas_uplo_type), INTENT (IN), OPTIONAL :: uplo
        END SUBROUTINE sy_copy_c
      END INTERFACE

      INTERFACE sb_copy
        ! a and b have shape (k+1,n), k=band width=size(a,1)-1
        SUBROUTINE sb_copy_d(a,b,uplo)
          USE blas_operator_arguments, ONLY : blas_uplo_type
          USE blas_precision, ONLY : wp => dp
          REAL (wp), INTENT (IN) :: a(:,:)
          REAL (wp), INTENT (OUT) :: b(:,:)
          TYPE (blas_uplo_type), INTENT (IN), OPTIONAL :: uplo
        END SUBROUTINE sb_copy_d
        SUBROUTINE sb_copy_z(a,b,uplo)
          USE blas_operator_arguments, ONLY : blas_uplo_type
          USE blas_precision, ONLY : wp => dp
          COMPLEX (wp), INTENT (IN) :: a(:,:)
          COMPLEX (wp), INTENT (OUT) :: b(:,:)
          TYPE (blas_uplo_type), INTENT (IN), OPTIONAL :: uplo
        END SUBROUTINE sb_copy_z
        SUBROUTINE sb_copy_s(a,b,uplo)
          USE blas_operator_arguments, ONLY : blas_uplo_type
          USE blas_precision, ONLY : wp => sp
          REAL (wp), INTENT (IN) :: a(:,:)
          REAL (wp), INTENT (OUT) :: b(:,:)
          TYPE (blas_uplo_type), INTENT (IN), OPTIONAL :: uplo
        END SUBROUTINE sb_copy_s
        SUBROUTINE sb_copy_c(a,b,uplo)
          USE blas_operator_arguments, ONLY : blas_uplo_type
          USE blas_precision, ONLY : wp => sp
          COMPLEX (wp), INTENT (IN) :: a(:,:)
          COMPLEX (wp), INTENT (OUT) :: b(:,:)
          TYPE (blas_uplo_type), INTENT (IN), OPTIONAL :: uplo
        END SUBROUTINE sb_copy_c
      END INTERFACE

      INTERFACE sp_copy
        ! ap and bp have shape ((n+1)*n/2)
        SUBROUTINE sp_copy_d(ap,bp,uplo)
          USE blas_operator_arguments, ONLY : blas_uplo_type
          USE blas_precision, ONLY : wp => dp
          REAL (wp), INTENT (IN) :: ap(:)
          REAL (wp), INTENT (OUT) :: bp(:)
          TYPE (blas_uplo_type), INTENT (IN), OPTIONAL :: uplo
        END SUBROUTINE sp_copy_d
        SUBROUTINE sp_copy_z(ap,bp,uplo)
          USE blas_operator_arguments, ONLY : blas_uplo_type
          USE blas_precision, ONLY : wp => dp
          COMPLEX (wp), INTENT (IN) :: ap(:)
          COMPLEX (wp), INTENT (OUT) :: bp(:)
          TYPE (blas_uplo_type), INTENT (IN), OPTIONAL :: uplo
        END SUBROUTINE sp_copy_z
        SUBROUTINE sp_copy_s(ap,bp,uplo)
          USE blas_operator_arguments, ONLY : blas_uplo_type
          USE blas_precision, ONLY : wp => sp
          REAL (wp), INTENT (IN) :: ap(:)
          REAL (wp), INTENT (OUT) :: bp(:)
          TYPE (blas_uplo_type), INTENT (IN), OPTIONAL :: uplo
        END SUBROUTINE sp_copy_s
        SUBROUTINE sp_copy_c(ap,bp,uplo)
          USE blas_operator_arguments, ONLY : blas_uplo_type
          USE blas_precision, ONLY : wp => sp
          COMPLEX (wp), INTENT (IN) :: ap(:)
          COMPLEX (wp), INTENT (OUT) :: bp(:)
          TYPE (blas_uplo_type), INTENT (IN), OPTIONAL :: uplo
        END SUBROUTINE sp_copy_c
      END INTERFACE

      INTERFACE tr_copy
        ! a and b have shape (n,n)
        SUBROUTINE tr_copy_d(a,b,uplo,trans,diag)
          USE blas_operator_arguments, ONLY : blas_uplo_type, blas_diag_type, &
           blas_trans_type
          USE blas_precision, ONLY : wp => dp
          REAL (wp), INTENT (IN) :: a(:,:)
          REAL (wp), INTENT (OUT) :: b(:,:)
          TYPE (blas_uplo_type), INTENT (IN), OPTIONAL :: uplo
          TYPE (blas_trans_type), INTENT (IN), OPTIONAL :: trans
          TYPE (blas_diag_type), INTENT (IN), OPTIONAL :: diag
        END SUBROUTINE tr_copy_d
        SUBROUTINE tr_copy_z(a,b,uplo,trans,diag)
          USE blas_operator_arguments, ONLY : blas_uplo_type, blas_diag_type, &
           blas_trans_type
          USE blas_precision, ONLY : wp => dp
          COMPLEX (wp), INTENT (IN) :: a(:,:)
          COMPLEX (wp), INTENT (OUT) :: b(:,:)
          TYPE (blas_uplo_type), INTENT (IN), OPTIONAL :: uplo
          TYPE (blas_trans_type), INTENT (IN), OPTIONAL :: trans
          TYPE (blas_diag_type), INTENT (IN), OPTIONAL :: diag
        END SUBROUTINE tr_copy_z
        SUBROUTINE tr_copy_s(a,b,uplo,trans,diag)
          USE blas_operator_arguments, ONLY : blas_uplo_type, blas_diag_type, &
           blas_trans_type
          USE blas_precision, ONLY : wp => sp
          REAL (wp), INTENT (IN) :: a(:,:)
          REAL (wp), INTENT (OUT) :: b(:,:)
          TYPE (blas_uplo_type), INTENT (IN), OPTIONAL :: uplo
          TYPE (blas_trans_type), INTENT (IN), OPTIONAL :: trans
          TYPE (blas_diag_type), INTENT (IN), OPTIONAL :: diag
        END SUBROUTINE tr_copy_s
        SUBROUTINE tr_copy_c(a,b,uplo,trans,diag)
          USE blas_operator_arguments, ONLY : blas_uplo_type, blas_diag_type, &
           blas_trans_type
          USE blas_precision, ONLY : wp => sp
          COMPLEX (wp), INTENT (IN) :: a(:,:)
          COMPLEX (wp), INTENT (OUT) :: b(:,:)
          TYPE (blas_uplo_type), INTENT (IN), OPTIONAL :: uplo
          TYPE (blas_trans_type), INTENT (IN), OPTIONAL :: trans
          TYPE (blas_diag_type), INTENT (IN), OPTIONAL :: diag
        END SUBROUTINE tr_copy_c
      END INTERFACE

      INTERFACE tb_copy
        ! a and b have shape (k+1,n), k=band width=size(a,1)-1
        SUBROUTINE tb_copy_d(a,b,uplo,trans,diag)
          USE blas_operator_arguments, ONLY : blas_uplo_type, blas_diag_type, &
           blas_trans_type
          USE blas_precision, ONLY : wp => dp
          REAL (wp), INTENT (IN) :: a(:,:)
          REAL (wp), INTENT (OUT) :: b(:,:)
          TYPE (blas_uplo_type), INTENT (IN), OPTIONAL :: uplo
          TYPE (blas_trans_type), INTENT (IN), OPTIONAL :: trans
          TYPE (blas_diag_type), INTENT (IN), OPTIONAL :: diag
        END SUBROUTINE tb_copy_d
        SUBROUTINE tb_copy_z(a,b,uplo,trans,diag)
          USE blas_operator_arguments, ONLY : blas_uplo_type, blas_diag_type, &
           blas_trans_type
          USE blas_precision, ONLY : wp => dp
          COMPLEX (wp), INTENT (IN) :: a(:,:)
          COMPLEX (wp), INTENT (OUT) :: b(:,:)
          TYPE (blas_uplo_type), INTENT (IN), OPTIONAL :: uplo
          TYPE (blas_trans_type), INTENT (IN), OPTIONAL :: trans
          TYPE (blas_diag_type), INTENT (IN), OPTIONAL :: diag
        END SUBROUTINE tb_copy_z
        SUBROUTINE tb_copy_s(a,b,uplo,trans,diag)
          USE blas_operator_arguments, ONLY : blas_uplo_type, blas_diag_type, &
           blas_trans_type
          USE blas_precision, ONLY : wp => sp
          REAL (wp), INTENT (IN) :: a(:,:)
          REAL (wp), INTENT (OUT) :: b(:,:)
          TYPE (blas_uplo_type), INTENT (IN), OPTIONAL :: uplo
          TYPE (blas_trans_type), INTENT (IN), OPTIONAL :: trans
          TYPE (blas_diag_type), INTENT (IN), OPTIONAL :: diag
        END SUBROUTINE tb_copy_s
        SUBROUTINE tb_copy_c(a,b,uplo,trans,diag)
          USE blas_operator_arguments, ONLY : blas_uplo_type, blas_diag_type, &
           blas_trans_type
          USE blas_precision, ONLY : wp => sp
          COMPLEX (wp), INTENT (IN) :: a(:,:)
          COMPLEX (wp), INTENT (OUT) :: b(:,:)
          TYPE (blas_uplo_type), INTENT (IN), OPTIONAL :: uplo
          TYPE (blas_trans_type), INTENT (IN), OPTIONAL :: trans
          TYPE (blas_diag_type), INTENT (IN), OPTIONAL :: diag
        END SUBROUTINE tb_copy_c
      END INTERFACE

      INTERFACE tp_copy
        ! ap and bp have shape ((n+1)*n/2)
        SUBROUTINE tp_copy_d(ap,bp,uplo,trans,diag)
          USE blas_operator_arguments, ONLY : blas_uplo_type, blas_diag_type, &
           blas_trans_type
          USE blas_precision, ONLY : wp => dp
          REAL (wp), INTENT (IN) :: ap(:)
          REAL (wp), INTENT (OUT) :: bp(:)
          TYPE (blas_uplo_type), INTENT (IN), OPTIONAL :: uplo
          TYPE (blas_trans_type), INTENT (IN), OPTIONAL :: trans
          TYPE (blas_diag_type), INTENT (IN), OPTIONAL :: diag
        END SUBROUTINE tp_copy_d
        SUBROUTINE tp_copy_z(ap,bp,uplo,trans,diag)
          USE blas_operator_arguments, ONLY : blas_uplo_type, blas_diag_type, &
           blas_trans_type
          USE blas_precision, ONLY : wp => dp
          COMPLEX (wp), INTENT (IN) :: ap(:)
          COMPLEX (wp), INTENT (OUT) :: bp(:)
          TYPE (blas_uplo_type), INTENT (IN), OPTIONAL :: uplo
          TYPE (blas_trans_type), INTENT (IN), OPTIONAL :: trans
          TYPE (blas_diag_type), INTENT (IN), OPTIONAL :: diag
        END SUBROUTINE tp_copy_z
        SUBROUTINE tp_copy_s(ap,bp,uplo,trans,diag)
          USE blas_operator_arguments, ONLY : blas_uplo_type, blas_diag_type, &
           blas_trans_type
          USE blas_precision, ONLY : wp => sp
          REAL (wp), INTENT (IN) :: ap(:)
          REAL (wp), INTENT (OUT) :: bp(:)
          TYPE (blas_uplo_type), INTENT (IN), OPTIONAL :: uplo
          TYPE (blas_trans_type), INTENT (IN), OPTIONAL :: trans
          TYPE (blas_diag_type), INTENT (IN), OPTIONAL :: diag
        END SUBROUTINE tp_copy_s
        SUBROUTINE tp_copy_c(ap,bp,uplo,trans,diag)
          USE blas_operator_arguments, ONLY : blas_uplo_type, blas_diag_type, &
           blas_trans_type
          USE blas_precision, ONLY : wp => sp
          COMPLEX (wp), INTENT (IN) :: ap(:)
          COMPLEX (wp), INTENT (OUT) :: bp(:)
          TYPE (blas_uplo_type), INTENT (IN), OPTIONAL :: uplo
          TYPE (blas_trans_type), INTENT (IN), OPTIONAL :: trans
          TYPE (blas_diag_type), INTENT (IN), OPTIONAL :: diag
        END SUBROUTINE tp_copy_c
      END INTERFACE

      INTERFACE he_copy
        ! a and b have shape (n,n)
        SUBROUTINE he_copy_z(a,b,uplo)
          USE blas_operator_arguments, ONLY : blas_uplo_type
          USE blas_precision, ONLY : wp => dp
          COMPLEX (wp), INTENT (IN) :: a(:,:)
          COMPLEX (wp), INTENT (OUT) :: b(:,:)
          TYPE (blas_uplo_type), INTENT (IN), OPTIONAL :: uplo
        END SUBROUTINE he_copy_z
        SUBROUTINE he_copy_c(a,b,uplo)
          USE blas_operator_arguments, ONLY : blas_uplo_type
          USE blas_precision, ONLY : wp => sp
          COMPLEX (wp), INTENT (IN) :: a(:,:)
          COMPLEX (wp), INTENT (OUT) :: b(:,:)
          TYPE (blas_uplo_type), INTENT (IN), OPTIONAL :: uplo
        END SUBROUTINE he_copy_c
      END INTERFACE

      INTERFACE hb_copy
        ! a and b have shape (k+1,n), k=band width=size(a,1)-1
        SUBROUTINE hb_copy_z(a,b,uplo)
          USE blas_operator_arguments, ONLY : blas_uplo_type
          USE blas_precision, ONLY : wp => dp
          COMPLEX (wp), INTENT (IN) :: a(:,:)
          COMPLEX (wp), INTENT (OUT) :: b(:,:)
          TYPE (blas_uplo_type), INTENT (IN), OPTIONAL :: uplo
        END SUBROUTINE hb_copy_z
        SUBROUTINE hb_copy_c(a,b,uplo)
          USE blas_operator_arguments, ONLY : blas_uplo_type
          USE blas_precision, ONLY : wp => sp
          COMPLEX (wp), INTENT (IN) :: a(:,:)
          COMPLEX (wp), INTENT (OUT) :: b(:,:)
          TYPE (blas_uplo_type), INTENT (IN), OPTIONAL :: uplo
        END SUBROUTINE hb_copy_c
      END INTERFACE

      INTERFACE hp_copy
        ! ap and bp have shape ((n+1)*n/2)
        SUBROUTINE hp_copy_z(ap,bp,uplo)
          USE blas_operator_arguments, ONLY : blas_uplo_type
          USE blas_precision, ONLY : wp => dp
          COMPLEX (wp), INTENT (IN) :: ap(:)
          COMPLEX (wp), INTENT (OUT) :: bp(:)
          TYPE (blas_uplo_type), INTENT (IN), OPTIONAL :: uplo
        END SUBROUTINE hp_copy_z
        SUBROUTINE hp_copy_c(ap,bp,uplo)
          USE blas_operator_arguments, ONLY : blas_uplo_type
          USE blas_precision, ONLY : wp => sp
          COMPLEX (wp), INTENT (IN) :: ap(:)
          COMPLEX (wp), INTENT (OUT) :: bp(:)
          TYPE (blas_uplo_type), INTENT (IN), OPTIONAL :: uplo
        END SUBROUTINE hp_copy_c
      END INTERFACE

      INTERFACE ge_trans
        ! a has shape (n,n)
        SUBROUTINE ge_trans_d(a,conj)
          USE blas_operator_arguments, ONLY : blas_conj_type
          USE blas_precision, ONLY : wp => dp
          REAL (wp), INTENT (INOUT) :: a(:,:)
          TYPE (blas_conj_type), INTENT (IN), OPTIONAL :: conj
        END SUBROUTINE ge_trans_d
        SUBROUTINE ge_trans_z(a,conj)
          USE blas_operator_arguments, ONLY : blas_conj_type
          USE blas_precision, ONLY : wp => dp
          COMPLEX (wp), INTENT (INOUT) :: a(:,:)
          TYPE (blas_conj_type), INTENT (IN), OPTIONAL :: conj
        END SUBROUTINE ge_trans_z
        SUBROUTINE ge_trans_s(a,conj)
          USE blas_operator_arguments, ONLY : blas_conj_type
          USE blas_precision, ONLY : wp => sp
          REAL (wp), INTENT (INOUT) :: a(:,:)
          TYPE (blas_conj_type), INTENT (IN), OPTIONAL :: conj
        END SUBROUTINE ge_trans_s
        SUBROUTINE ge_trans_c(a,conj)
          USE blas_operator_arguments, ONLY : blas_conj_type
          USE blas_precision, ONLY : wp => sp
          COMPLEX (wp), INTENT (INOUT) :: a(:,:)
          TYPE (blas_conj_type), INTENT (IN), OPTIONAL :: conj
        END SUBROUTINE ge_trans_c
      END INTERFACE

      INTERFACE ge_permute
        ! a has shape (m,n)
        ! p has shape (m) if side = blas_left_side
        ! .           (n) if side = blas_right_side
        SUBROUTINE ge_permute_d(p,a,side)
          USE blas_operator_arguments, ONLY : blas_side_type
          USE blas_precision, ONLY : wp => dp
          INTEGER, INTENT (IN) :: p(:)
          REAL (wp), INTENT (INOUT) :: a(:,:)
          TYPE (blas_side_type), INTENT (IN), OPTIONAL :: side
        END SUBROUTINE ge_permute_d
        SUBROUTINE ge_permute_z(p,a,side)
          USE blas_operator_arguments, ONLY : blas_side_type
          USE blas_precision, ONLY : wp => dp
          INTEGER, INTENT (IN) :: p(:)
          COMPLEX (wp), INTENT (INOUT) :: a(:,:)
          TYPE (blas_side_type), INTENT (IN), OPTIONAL :: side
        END SUBROUTINE ge_permute_z
        SUBROUTINE ge_permute_s(p,a,side)
          USE blas_operator_arguments, ONLY : blas_side_type
          USE blas_precision, ONLY : wp => sp
          INTEGER, INTENT (IN) :: p(:)
          REAL (wp), INTENT (INOUT) :: a(:,:)
          TYPE (blas_side_type), INTENT (IN), OPTIONAL :: side
        END SUBROUTINE ge_permute_s
        SUBROUTINE ge_permute_c(p,a,side)
          USE blas_operator_arguments, ONLY : blas_side_type
          USE blas_precision, ONLY : wp => sp
          INTEGER, INTENT (IN) :: p(:)
          COMPLEX (wp), INTENT (INOUT) :: a(:,:)
          TYPE (blas_side_type), INTENT (IN), OPTIONAL :: side
        END SUBROUTINE ge_permute_c
      END INTERFACE
    END MODULE blas_dense_mat_mov


submodule(euler_interface_m) euler_prob_0013_m
    use euler_multiprecision_m
    implicit none

contains

    module character(len=20) function euler0013()
        type(multiprecision_int_t) :: val
        val = answer()
        write (euler0013, "(10(' '), 10(i1))") val%arr(1:10)
    end function euler0013

    function answer() result(ret)
        use euler_data_m, only: get_euler_data_0013
        implicit none

        integer :: i
        type(multiprecision_int_t) :: tmp, ret
        character(len=:), allocatable :: euler_data(:)

        call get_euler_data_0013(euler_data)
        tmp%sgn = '+'; allocate (tmp%arr(50)); ret = 0
        do i = 1, 100
            read (euler_data(i), "(50(i1))") tmp%arr
            ret = ret + tmp
        end do
    end function answer

end submodule euler_prob_0013_m


!The object is to write a FUNCTION that takes an array of integers, and returns the index of the first non-zero element.

FUNCTION l(a,j)
  IMPLICIT NONE

  INTEGER, DIMENSION(:), INTENT(IN) :: a
  INTEGER :: l,j,i,k

  Do i=1,j
    k=a(i)
    If (k>0) Exit
  End Do
l=i
END FUNCTION l

PROGRAM Subprograms
  IMPLICIT NONE

  INTEGER :: j,i,value
  INTEGER, DIMENSION(:), ALLOCATABLE :: a

INTERFACE
  FUNCTION l(a,j)
    INTEGER, DIMENSION(:), INTENT(IN) :: a
    INTEGER :: l,j
  END FUNCTION l
END INTERFACE
  i=0

  WRITE(6,*) 'The size of the array is'
  READ(5,*) j

  !Allocate a size to a

  ALLOCATE(a(j))

  WRITE(6,*) 'array a has size',SIZE(a)
  Do i=1,j
    WRITE(6,*) 'Enter value of a(',i,')'
    READ(5,*) value
    a(i) = value
  END DO
WRITE (6,*) "The array is",a
WRITE (6,*) "position of first non zero value in array is",l(a,j)

END PROGRAM Subprograms


      SUBROUTINE gridset(lats, lons, lats0, lons0, dx, dy)
C     Assign initial positions to the virtual floes.
C     Robert Grumbine 4 April 1994.
C     Variant for assigning points on a lat-long grid
C     Robert Grumbine 7 May 2012

      IMPLICIT none
      INCLUDE "sicedrft.inc"

      REAL lats(nx*ny), lons(nx*ny), lats0(nx*ny), lons0(nx*ny)
      REAL dx(nx*ny), dy(nx*ny)

      INTEGER i, j, k
      REAL tlat, tlon
      REAL x, y, e

      e = sqrt(eccen2)
      k = 0
      lons = 0
      lats = 0
      lons0 = 0
      lats0 = 0

      DO j = 1, ny
      DO i = 1, nx
        k = k + 1
        y = yorig + j*deltay
        x = xorig + i*deltax
        CALL mapxy(x, y, tlat, tlon, slat, slon, sgn, e, rearth)
        lons(k)  = tlon
        lons0(k) = lons(k)
        lats(k)  = tlat
        lats0(k) = lats(k)
CD        PRINT *,"grid ",i,j,tlon, tlat, lons(k), lats(k),
CD     1            lons0(k), lats0(k)
      ENDDO
      ENDDO

      DO i = 1, k
        dx(i) = 0.0
        dy(i) = 0.0
        IF (lons(i) .LT. 0) THEN
          lons(i)  = lons(i)  + 360.
          lons0(i) = lons0(i) + 360.
        ENDIF
        IF (lons0(i) .LT. 0) THEN
          lons(i)  = lons(i)  + 360.
          lons0(i) = lons0(i) + 360.
        ENDIF
        IF (lats(i) .LT. -90.0) THEN
          PRINT *,"lats ",i,lats(i),lons(i)-360.
        ENDIF
        IF (lats(i) .GT. 90.0) THEN
          PRINT *,"lats ",i,lats(i),lons(i)
        ENDIF
      ENDDO

CD      PRINT *,'max lon = ', MINVAL(lons), MAXVAL(lons)
CD      PRINT *,'max lat = ', MINVAL(lats), MAXVAL(lats)
CD      PRINT *,'max lon0 = ', MINVAL(lons0), MAXVAL(lons0)
CD      PRINT *,'max lat0 = ', MINVAL(lats0), MAXVAL(lats0)
      IF (MAXVAL(lats) .GT. 90.0 .OR. MINVAL(lats) .LT. -90.0 ) THEN
        PRINT *,'lats off planet, according to maxval, minval'
      ENDIF

      RETURN
      END


module grid

  implicit none

  integer :: Nele, Nnodes ! Number of elements and nodes

  real(kind=8), dimension(:,:),  allocatable :: ele_geom       ! Geometry of the cells
  real(kind=8), dimension(:,:),  allocatable :: ele_int_len    ! Interfaces length
  real(kind=8), dimension(:,:),  allocatable :: ele_int_nx     ! Interfaces normals along x
  real(kind=8), dimension(:,:),  allocatable :: ele_int_ny     ! Interfaces normals along y
  integer,      dimension(:,:),  allocatable :: ele_neigh      ! Connectivity (neighbors)
  logical,      dimension(:),    allocatable :: ele_bound_bool ! Useful for going second order
  integer,      dimension(:,:),  allocatable :: ele_nodes      ! Necessary for plotting the solution

  real(kind=8), dimension(:,:),  allocatable :: nodes_xy ! Necessary for exporting the solution to VTK

  contains

  ! ================================================

  subroutine load_grid_from_file

    ! This subroutine loads the grid data from a file

    implicit none

    character(len=512) :: dummy
    integer :: eleID, nodeID, dummyINT

    integer :: neigh_12, neigh_23, neigh_34, neigh_41
    integer :: p1, p2, p3, p4
    real(kind=8) :: A, xC, yC
    real(kind=8) :: L12, n12_x, n12_y
    real(kind=8) :: L23, n23_x, n23_y
    real(kind=8) :: L34, n34_x, n34_y
    real(kind=8) :: L41, n41_x, n41_y

    real(kind=8) :: xP, yP

    ! -------- READ NODES --------

    open(98765, file="nodes.hyp") ! Open file

    read(98765, *) Nnodes  ! Read number of elements

    allocate(nodes_xy(Nnodes, 2))

    do nodeID = 1, Nnodes

      read(98765, *) xP, yP

      nodes_xy(nodeID,1) = xP
      nodes_xy(nodeID,2) = yP

    end do

    close(98765)

    ! -------- READ ELEMENTS --------

    open(54321, file="mesh.hyp") ! Open file

    read(54321, *) dummy ! Read header line (useless)
    read(54321, *) Nele  ! Read number of elements

    write(*,*) "  Number of grid elements: ", Nele

    ! Allocate arrays
    allocate(ele_geom(Nele, 3))
    allocate(ele_neigh(Nele, 4))
    allocate(ele_int_len(Nele, 4))
    allocate(ele_int_nx(Nele, 4))
    allocate(ele_int_ny(Nele, 4))
    allocate(ele_nodes(Nele, 4))
    allocate(ele_bound_BOOL(Nele))

    ! Read line by line
    do eleID = 1, Nele

      read(54321, *) dummyINT, A, xC, yC, L12, n12_x, n12_y, neigh_12, &
                                          L23, n23_x, n23_y, neigh_23, &
                                          L34, n34_x, n34_y, neigh_34, &
                                          L41, n41_x, n41_y, neigh_41, &
                                          p1,  p2,  p3,  p4

      ele_geom(eleID,1)  = A
      ele_geom(eleID,2)  = xC
      ele_geom(eleID,3)  = yC

      ele_int_len(eleID,1) = L12
      ele_int_len(eleID,2) = L23
      ele_int_len(eleID,3) = L34
      ele_int_len(eleID,4) = L41

      ele_int_nx(eleID,1) = n12_x ! First interface
      ele_int_nx(eleID,2) = n23_x ! second int
      ele_int_nx(eleID,3) = n34_x ! third
      ele_int_nx(eleID,4) = n41_x ! fourth interface

      ele_int_ny(eleID,1) = n12_y ! First interface
      ele_int_ny(eleID,2) = n23_y ! second int
      ele_int_ny(eleID,3) = n34_y ! third
      ele_int_ny(eleID,4) = n41_y ! fourth interface

      ele_neigh(eleID,1) = neigh_12
      ele_neigh(eleID,2) = neigh_23
      ele_neigh(eleID,3) = neigh_34
      ele_neigh(eleID,4) = neigh_41

      ! Set a bool to assess quickly if the element is boundarying
      ! (useful for second order)

      if ( (neigh_12 .le. 0) .or. (neigh_23 .le. 0) .or. &
           (neigh_34 .le. 0) .or. (neigh_41 .le. 0) ) then
        ele_bound_bool(eleID) = .TRUE.
      else
        ele_bound_bool(eleID) = .FALSE.
      end if

      ! Save nodes, for plotting the solution
      ele_nodes(eleID,1) = p1
      ele_nodes(eleID,2) = p2
      ele_nodes(eleID,3) = p3
      ele_nodes(eleID,4) = p4

    end do

    close(54321)

    !! DBDBDB FOR DEBUG !! ! WRITE STUFF, FOR DEBUGGING PURPOSES
    !! DBDBDB FOR DEBUG !! ! -------------------
    !! DBDBDB FOR DEBUG !! open(5, file="test/nodes_debug.dat", status="replace", form="formatted")
    !! DBDBDB FOR DEBUG !! do nodeID = 1, Nnodes
    !! DBDBDB FOR DEBUG !!   write(5,*)  nodes_xy(nodeID,1), nodes_xy(nodeID,2)
    !! DBDBDB FOR DEBUG !! end do
    !! DBDBDB FOR DEBUG !!
    !! DBDBDB FOR DEBUG !! close(5)
    !! DBDBDB FOR DEBUG !!
    !! DBDBDB FOR DEBUG !! ! ELEMENTS -------------------
    !! DBDBDB FOR DEBUG !! open(5, file="test/elements_debug.dat", status="replace", form="formatted")
    !! DBDBDB FOR DEBUG !!
    !! DBDBDB FOR DEBUG !! do eleID = 1, Nele
    !! DBDBDB FOR DEBUG !!   write(5,*)  ele_nodes(eleID,1), ele_nodes(eleID,2), ele_nodes(eleID,3), ele_nodes(eleID,4), &
    !! DBDBDB FOR DEBUG !!               ele_neigh(eleID,1), ele_neigh(eleID,2), ele_neigh(eleID,3), ele_neigh(eleID,4), &
    !! DBDBDB FOR DEBUG !!               ele_geom(eleID,1), ele_geom(eleID,2), ele_geom(eleID,3), &  ! A, xC, yC
    !! DBDBDB FOR DEBUG !!               ele_int_len(eleID,1),ele_int_len(eleID,2),ele_int_len(eleID,3),ele_int_len(eleID,4), &
    !! DBDBDB FOR DEBUG !!               ele_int_nx(eleID,1),ele_int_nx(eleID,2),ele_int_nx(eleID,3),ele_int_nx(eleID,4),     &
    !! DBDBDB FOR DEBUG !!               ele_int_ny(eleID,1),ele_int_ny(eleID,2),ele_int_ny(eleID,3),ele_int_ny(eleID,4)
    !! DBDBDB FOR DEBUG !! end do
    !! DBDBDB FOR DEBUG !!
    !! DBDBDB FOR DEBUG !! close(5)

  end subroutine

end module


PROGRAM disturb_atomic_coordinates
!MODULE disturb_module
!
  implicit none
!
!  PRIVATE
!  PUBLIC :: disturb

  real(8) :: ratio
  real(8) :: ax,aa(3,3)
  real(8),allocatable :: aa_atom(:,:)
  integer,allocatable :: ki_atom(:),md_atom(:)
  integer,parameter :: u=970, w=971
  integer :: nelem,natom,zatom(9),i
  character(3) :: cbuf,cformat

  write(*,*) "input the ratio of disturbance [0.0~1.0]"
  read(*,*) ratio
  write(*,*) "atomic coordinates are read from fort.970"
  read(u,*) cbuf,ax
  read(u,*) cbuf,aa(1:3,1)
  read(u,*) cbuf,aa(1:3,2)
  read(u,*) cbuf,aa(1:3,3)
  read(u,*) cformat
  read(u,*) nelem, natom, zatom(1:nelem)
  allocate( aa_atom(3,natom) ) ; aa_atom=0.0d0
  allocate( ki_atom(natom)   ) ; ki_atom=0
  allocate( md_atom(natom)   ) ; md_atom=0
  do i=1,natom
     read(u,*) ki_atom(i),aa_atom(1:3,i),md_atom(i)
  end do

  call disturb( aa_atom, ratio )

  write(*,*) "the disturbed atomic coordinates are written in fort.971"

  write(w,'("AX", f20.16)') ax
  write(w,'("A1",3f20.16)') aa(1:3,1)
  write(w,'("A2",3f20.16)') aa(1:3,2)
  write(w,'("A3",3f20.16)') aa(1:3,3)
  write(w,'(a3)') cformat
  write(w,'(1x,i4,10i8)') nelem,natom,zatom(1:nelem)
  do i=1,natom
     write(w,'(1x,i5,3f20.12,i4)') ki_atom(i),aa_atom(1:3,i),md_atom(i)
  end do

CONTAINS

  SUBROUTINE disturb( a, ratio )

    implicit none
    real(8),intent(INOUT) :: a(:,:)
    real(8),intent(IN) :: ratio
    real(8),allocatable :: d(:)
    real(8) :: r
    integer :: i

    if ( ratio <= 0.0d0 ) return
    r = min( ratio, 1.0d0 )

    allocate( d(size(a,1)) ) ; d=0.0d0

    do i=1,size(a,2)
       call random_number( d )
       d(:) = ( 2.0d0*d(:) - 1.0d0 )*r
       a(:,i) = a(:,i) + d(:)
!       write(*,'(1x,i4,2(5x,3f15.10))') i,a(:,i)-d(:),a(:,i)
    end do

    deallocate( d )

  END SUBROUTINE disturb

END PROGRAM disturb_atomic_coordinates
!END MODULE disturb_module


      SUBROUTINE PHO_CSDIFF(Id1,Id2,Ss,Xi_min,Xi_max,Sig_sd1,Sig_sd2,
     &                      Sig_dd)
C***********************************************************************
C
C     cross section for diffraction dissociation according to
C     Goulianos' parametrization (Ref: PL B358 (1995) 379)
C
C     in addition rescaling for different particles is applied using
C     internal rescaling tables (not implemented yet)
C
C     input:     Id1/2       PDG ID's of incoming particles
C                SS          squared c.m. energy (GeV**2)
C                Xi_min      min. diff mass (squared) = Xi_min*SS
C                Xi_max      max. diff mass (squared) = Xi_max*SS
C
C     output:    sig_sd1     cross section for diss. of particle 1 (mb)
C                sig_sd2     cross section for diss. of particle 2 (mb)
C                sig_dd      cross section for diss. of both particles
C
C***********************************************************************

      IMPLICIT NONE

      SAVE

      INTEGER Id1 , Id2
      DOUBLE PRECISION Ss , Xi_min , Xi_max , Sig_sd1 , Sig_sd2 , Sig_dd

C  input/output channels
      INCLUDE 'inc/poinou'
C  some constants
      INCLUDE 'inc/pocons'

      DOUBLE PRECISION xpos1(96) , xwgh1(96) , xpos2(96) , xwgh2(96)
      DOUBLE PRECISION delta , alphap , beta0 , gpom0 , xm_p , x_rad2 ,
     &                 xm4_p2 , fac , tt , t1 , t2 , tl , tu , xnorm ,
     &                 xi , xil , xiu , w_xi , alpha_t , f2_t , xms_1 ,
     &                 xms_2 , csdiff

      INTEGER ngau1 , ngau2 , i1 , i2

C  model parameters

      DATA delta/0.104D0/
      DATA alphap/0.25D0/
      DATA beta0/6.56D0/
      DATA gpom0/1.21D0/
      DATA xm_p/0.938D0/
      DATA x_rad2/0.71D0/

C  integration precision

      DATA ngau1/96/
      DATA ngau2/96/

      Sig_sd1 = 0.D0
      Sig_sd2 = 0.D0
      Sig_dd = 0.D0

      IF ( (ABS(Id1).EQ.2212) .AND. (ABS(Id2).EQ.2212) ) THEN

         xm4_p2 = 4.D0*xm_p**2
         fac = beta0**2/(16.D0*PI)

         t1 = -5.D0
         t2 = 0.D0
         tl = x_rad2/3.D0/(1.D0-t1/x_rad2)**3
         tu = x_rad2/3.D0/(1.D0-t2/x_rad2)**3

C  flux renormalization and cross section

         xnorm = 0.D0

         xil = LOG(1.5D0/Ss)
         xiu = LOG(0.1D0)

         IF ( xiu.GT.xil ) THEN

            CALL PHO_GAUSET(xil,xiu,ngau1,xpos1,xwgh1)
            CALL PHO_GAUSET(tl,tu,ngau2,xpos2,xwgh2)

            DO i1 = 1 , ngau1

               xi = EXP(xpos1(i1))
               w_xi = xwgh1(i1)

               DO i2 = 1 , ngau2

                  tt = x_rad2 - x_rad2*(x_rad2/(3.D0*xpos2(i2)))
     &                 **(1.D0/3.D0)

                  alpha_t = 1.D0 + delta + alphap*tt
                  f2_t = ((xm4_p2-2.8D0*tt)/(xm4_p2-tt))**2

                  xnorm = xnorm + f2_t*xi**(2.D0-2.D0*alpha_t)*xwgh2(i2)
     &                    *w_xi

               END DO
            END DO

            xnorm = xnorm*fac
         END IF

         xil = LOG(Xi_min)
         xiu = LOG(Xi_max)

         t1 = -5.D0
         t2 = 0.D0

         tl = x_rad2/3.D0/(1.D0-t1/x_rad2)**3
         tu = x_rad2/3.D0/(1.D0-t2/x_rad2)**3

C  single diffraction diss. cross section

         csdiff = 0.D0

         IF ( xiu.GT.xil ) THEN

            CALL PHO_GAUSET(xil,xiu,ngau1,xpos1,xwgh1)
            CALL PHO_GAUSET(tl,tu,ngau2,xpos2,xwgh2)

            DO i1 = 1 , ngau1

               xi = EXP(xpos1(i1))
               w_xi = xwgh1(i1)*beta0*gpom0*(xi*Ss)**delta

               DO i2 = 1 , ngau2

                  tt = x_rad2 - x_rad2*(x_rad2/(3.D0*xpos2(i2)))
     &                 **(1.D0/3.D0)

                  alpha_t = 1.D0 + delta + alphap*tt
                  f2_t = ((xm4_p2-2.8D0*tt)/(xm4_p2-tt))**2

                  csdiff = csdiff + f2_t*xi**(2.D0-2.D0*alpha_t)
     &                     *xwgh2(i2)*w_xi

               END DO
            END DO

            csdiff = csdiff*fac*GEV2mb/MAX(1.D0,xnorm)

C       WRITE(LO,'(1x,1p,4e14.3)')
C    &    sqrt(SS),Xnorm,2.*CSdiff*MAX(1.d0,Xnorm),2.*CSdiff

            Sig_sd1 = csdiff
            Sig_sd2 = csdiff
         END IF

C  double diffraction dissociation cross section

         csdiff = 0.D0

         xil = LOG(1.5D0/Ss)
         xiu = LOG(Xi_max/1.5D0)

         IF ( xiu.GT.xil ) THEN

            fac = (beta0*gpom0*Ss**delta/(4.D0*SQRT(PI)*MAX(1.D0,xnorm))
     &            )**2/(2.D0*alphap)

            CALL PHO_GAUSET(xil,xiu,ngau1,xpos1,xwgh1)

            DO i1 = 1 , ngau1

               xi = EXP(xpos1(i1))
               xms_1 = xi*Ss

               xiu = LOG(Xi_max/(xi*Ss))

               IF ( xil.LT.xiu ) THEN

                  CALL PHO_GAUSET(xil,xiu,ngau2,xpos2,xwgh2)

                  DO i2 = 1 , ngau2

                     xms_2 = EXP(xpos2(i2))*Ss
                     csdiff = csdiff +
     &                        1.D0/((xms_1*xms_2)**delta*LOG(Ss/
     &                        (xms_1*xms_2)))*xwgh1(i1)*xwgh2(i2)

                  END DO

               END IF

            END DO

            Sig_dd = csdiff*fac*GEV2mb
         END IF

      ELSE

         IF ( LPRi.GT.4 ) WRITE (LO,'(1x,2a,2I8)') 'PHO_CSDIFF: ' ,
     &        'invalid particle combination (Id1/2)' , Id1 , Id2

      END IF

      END SUBROUTINE


!
!     ------------------------------------------------------------------
!              G K
!     ------------------------------------------------------------------
!                             k
!       Returns the value of G (i,j).
!
!
      REAL(KIND(0.0D0)) FUNCTION GK (I, J, K, REL)
!-----------------------------------------------
!   M o d u l e s
!-----------------------------------------------
      USE vast_kind_param, ONLY:  DOUBLE
      USE PARAM_C
!...Translated by Pacific-Sierra Research 77to90  4.3E  21:52:17  11/14/01
!...Switches:
!-----------------------------------------------
!   I n t e r f a c e   B l o c k s
!-----------------------------------------------
      USE ykf_I
      USE quads_I
      USE grad_I
      USE quadr_I
      IMPLICIT NONE
!-----------------------------------------------
!   D u m m y   A r g u m e n t s
!-----------------------------------------------
      INTEGER  :: I
      INTEGER  :: J
      INTEGER  :: K
      LOGICAL  :: REL
!-----------------------------------------------
!   L o c a l   V a r i a b l e s
!-----------------------------------------------
!-----------------------------------------------
      CALL YKF (I, J, K, REL)
      GK = QUADS(I,J,1)
      IF (MASS > 0) THEN
         IF (MASS == 1) THEN
            IF (K == 1) GK = GK + RMASS*GRAD(I,J)**2
         ELSE
            GK = GK*(D1 + RMASS/D2)
            IF (K == 1) GK = GK + Z*RMASS*QUADR(I,J,1)*QUADR(J,I,-2)
         ENDIF
      ENDIF
      RETURN
      END FUNCTION GK


      SUBROUTINE ALAMDA (ARG,Y,BLAMDA)
C
C     SUBROUTINE FOR COMPUTING LAMDA
C
      COMPLEX BLAMDA,AI,C1
C
      COMMON/BLK1/SCRK,SPS,SNS,DSTR,AI,PI,DEL,SIGMA,BETA,RES
C
      SCRK1= ABS(SCRK)
      ARG1=  ABS(ARG)
      S1=(ARG-DEL)*SPS+SIGMA
      IF( SCRK1.GT.ARG1) GO TO 10
      GAM=SQRT(ARG**2-SCRK**2)
      C1=COS(GAM*(SNS-Y))-CEXP(AI*S1)*COS(GAM*Y)
      C2=COS(SNS*GAM)-COS(S1)
      BLAMDA=C1/C2
      RETURN
   10 CONTINUE
      GAM=SQRT(SCRK**2-ARG**2)
      C1=COSH(GAM*(SNS-Y))-CEXP(AI*S1)*COSH(GAM*Y)
      C2=COSH(SNS*GAM)-COS(S1)
      BLAMDA=C1/C2
      RETURN
      END


C NCLFORTSTART
      SUBROUTINE DCOMPUTEPI(PI,PRESSURE,NX,NY,NZ)
      IMPLICIT NONE
      INTEGER NX,NY,NZ
      DOUBLE PRECISION PI(NX,NY,NZ)
      DOUBLE PRECISION PRESSURE(NX,NY,NZ)
C NCLEND

      INTEGER I,J,K
      DOUBLE PRECISION P1000MB,R_D,CP
      PARAMETER (P1000MB=100000.D0,R_D=287.D0,CP=7.D0*R_D/2.D0)

      DO K = 1,NZ
          DO J = 1,NY
              DO I = 1,NX
                  PI(I,J,K) = (PRESSURE(I,J,K)/P1000MB)** (R_D/CP)
              END DO
          END DO
      END DO

      END

C NCLFORTSTART
      SUBROUTINE DCOMPUTETK(TK,PRESSURE,THETA,NX)
      IMPLICIT NONE
      INTEGER NX
      DOUBLE PRECISION PI
      DOUBLE PRECISION PRESSURE(NX)
      DOUBLE PRECISION THETA(NX)
      DOUBLE PRECISION TK(NX)
C NCLEND

      INTEGER I
      DOUBLE PRECISION P1000MB,R_D,CP
      PARAMETER (P1000MB=100000.D0,R_D=287.D0,CP=7.D0*R_D/2.D0)

      DO I = 1,NX
         PI = (PRESSURE(I)/P1000MB)** (R_D/CP)
         TK(I) = PI*THETA(I)
      END DO

      END

C NCLFORTSTART
      SUBROUTINE DINTERP3DZ(V3D,V2D,Z,LOC,NX,NY,NZ,VMSG)
      IMPLICIT NONE
      INTEGER NX,NY,NZ
      DOUBLE PRECISION V3D(NX,NY,NZ),V2D(NX,NY)
      DOUBLE PRECISION Z(NX,NY,NZ)
      DOUBLE PRECISION LOC
      DOUBLE PRECISION VMSG
C NCLEND

      INTEGER I,J,KP,IP,IM
      LOGICAL INTERP
      DOUBLE PRECISION HEIGHT,W1,W2

      HEIGHT = LOC

c does vertical coordinate increase or decrease with increasing k?
c set offset appropriately

      IP = 0
      IM = 1
      IF (Z(1,1,1).GT.Z(1,1,NZ)) THEN
          IP = 1
          IM = 0
      END IF

      DO I = 1,NX
          DO J = 1,NY
C Initialize to missing.  Was initially hard-coded to -999999.
              V2D(I,J) = VMSG
              INTERP = .false.
              KP = NZ

              DO WHILE ((.NOT.INTERP) .AND. (KP.GE.2))

                  IF (((Z(I,J,KP-IM).LE.HEIGHT).AND. (Z(I,J,
     +                KP-IP).GT.HEIGHT))) THEN
                      W2 = (HEIGHT-Z(I,J,KP-IM))/
     +                     (Z(I,J,KP-IP)-Z(I,J,KP-IM))
                      W1 = 1.D0 - W2
                      V2D(I,J) = W1*V3D(I,J,KP-IM) + W2*V3D(I,J,KP-IP)
                      INTERP = .true.
                  END IF
                  KP = KP - 1

              END DO

          END DO
      END DO

      RETURN
      END

C NCLFORTSTART
      SUBROUTINE DZSTAG(ZNEW,NX,NY,NZ,Z,NXZ,NYZ,NZZ,TERRAIN)
      IMPLICIT NONE
      INTEGER NX,NY,NZ,NXZ,NYZ,NZZ
      DOUBLE PRECISION ZNEW(NX,NY,NZ),Z(NXZ,NYZ,NZZ)
      DOUBLE PRECISION TERRAIN(NXZ,NYZ)
C NCLEND

      INTEGER I,J,K,II,IM1,JJ,JM1

c check for u, v, or w (x,y,or z) staggering
c
c for x and y stag, avg z to x, y, point
c
      IF (NX.GT.NXZ) THEN

          DO K = 1,NZ
              DO J = 1,NY
                  DO I = 1,NX
                      II = MIN0(I,NXZ)
                      IM1 = MAX0(I-1,1)
                      ZNEW(I,J,K) = 0.5D0* (Z(II,J,K)+Z(IM1,J,K))
                  END DO
              END DO
          END DO

      ELSE IF (NY.GT.NYZ) THEN

          DO K = 1,NZ
              DO J = 1,NY
                  JJ = MIN0(J,NYZ)
                  JM1 = MAX0(J-1,1)
                  DO I = 1,NX
                      ZNEW(I,J,K) = 0.5D0* (Z(I,JJ,K)+Z(I,JM1,K))
                  END DO
              END DO
          END DO
c
c w (z) staggering
c
      ELSE IF (NZ.GT.NZZ) THEN

          DO J = 1,NY
              DO I = 1,NX
                  ZNEW(I,J,1) = TERRAIN(I,J)
              END DO
          END DO

          DO K = 2,NZ
              DO J = 1,NY
                  DO I = 1,NX
                      ZNEW(I,J,K) = ZNEW(I,J,K-1) +
     +                              2.D0* (Z(I,J,K-1)-ZNEW(I,J,K-1))
                  END DO
              END DO
          END DO

      END IF

      RETURN
      END

C NCLFORTSTART
      SUBROUTINE DINTERP2DXY(V3D,V2D,XY,NX,NY,NZ,NXY)
      IMPLICIT NONE
      INTEGER NX,NY,NZ,NXY
      DOUBLE PRECISION V3D(NX,NY,NZ),V2D(NXY,NZ)
      DOUBLE PRECISION XY(2,NXY)
C NCLEND

      INTEGER I,J,K,IJ
      DOUBLE PRECISION W11,W12,W21,W22,WX,WY

      DO IJ = 1,NXY

          I = MAX0(1,MIN0(NX-1,INT(XY(1,IJ)+1)))
          J = MAX0(1,MIN0(NY-1,INT(XY(2,IJ)+1)))
          WX = DBLE(I+1) - (XY(1,IJ)+1)
          WY = DBLE(J+1) - (XY(2,IJ)+1)
          W11 = WX*WY
          W21 = (1.D0-WX)*WY
          W12 = WX* (1.D0-WY)
          W22 = (1.D0-WX)* (1.D0-WY)
          DO K = 1,NZ
              V2D(IJ,K) = W11*V3D(I,J,K) + W21*V3D(I+1,J,K) +
     +                    W12*V3D(I,J+1,K) + W22*V3D(I+1,J+1,K)
          END DO
      END DO

      RETURN
      END

C NCLFORTSTART
      SUBROUTINE DINTERP1D(V_IN,V_OUT,Z_IN,Z_OUT,NZ_IN,NZ_OUT,VMSG)
      IMPLICIT NONE
      INTEGER NZ_IN,NZ_OUT
      DOUBLE PRECISION V_IN(NZ_IN),Z_IN(NZ_IN)
      DOUBLE PRECISION V_OUT(NZ_OUT),Z_OUT(NZ_OUT)
      DOUBLE PRECISION VMSG
C NCLEND

      INTEGER KP,K,IM,IP
      LOGICAL INTERP
      DOUBLE PRECISION HEIGHT,W1,W2

c does vertical coordinate increase of decrease with increasing k?
c set offset appropriately

      IP = 0
      IM = 1
      IF (Z_IN(1).GT.Z_IN(NZ_IN)) THEN
          IP = 1
          IM = 0
      END IF

      DO K = 1,NZ_OUT
          V_OUT(K) = VMSG

          INTERP = .false.
          KP = NZ_IN
          HEIGHT = Z_OUT(K)

          DO WHILE ((.NOT.INTERP) .AND. (KP.GE.2))

              IF (((Z_IN(KP-IM).LE.HEIGHT).AND.
     +            (Z_IN(KP-IP).GT.HEIGHT))) THEN
                  W2 = (HEIGHT-Z_IN(KP-IM))/ (Z_IN(KP-IP)-Z_IN(KP-IM))
                  W1 = 1.D0 - W2
                  V_OUT(K) = W1*V_IN(KP-IM) + W2*V_IN(KP-IP)
                  INTERP = .true.
              END IF
              KP = KP - 1

          END DO

      END DO

      RETURN
      END

c---------------------------------------------

c Bill,
c This routine assumes
c    index order is (i,j,k)
c    wrf staggering
C
c    units: pressure (Pa), temperature(K), height (m), mixing ratio
c     (kg kg{-1}) availability of 3d p, t, and qv; 2d terrain; 1d
c half-level zeta string
c    output units of SLP are Pa, but you should divide that by 100 for the
c          weather weenies.
c    virtual effects are included
c

C NCLFORTSTART
      SUBROUTINE DCOMPUTESEAPRS(NX,NY,NZ,Z,T,P,Q,SEA_LEVEL_PRESSURE,
     +                          T_SEA_LEVEL,T_SURF,LEVEL)
      IMPLICIT NONE
c     Estimate sea level pressure.
      INTEGER NX,NY,NZ
      DOUBLE PRECISION Z(NX,NY,NZ)
      DOUBLE PRECISION T(NX,NY,NZ),P(NX,NY,NZ),Q(NX,NY,NZ)
c     The output is the 2d sea level pressure.
      DOUBLE PRECISION SEA_LEVEL_PRESSURE(NX,NY)
      INTEGER LEVEL(NX,NY)
      DOUBLE PRECISION T_SURF(NX,NY),T_SEA_LEVEL(NX,NY)
C NCLEND
c     Some required physical constants:

      DOUBLE PRECISION R,G,GAMMA
      PARAMETER (R=287.04D0,G=9.81D0,GAMMA=0.0065D0)

c     Specific constants for assumptions made in this routine:

      DOUBLE PRECISION TC,PCONST
      PARAMETER (TC=273.16D0+17.5D0,PCONST=10000)
      LOGICAL RIDICULOUS_MM5_TEST
      PARAMETER (RIDICULOUS_MM5_TEST=.TRUE.)
c      PARAMETER (ridiculous_mm5_test = .false.)

c     Local variables:

      INTEGER I,J,K
      INTEGER KLO,KHI

      DOUBLE PRECISION PLO,PHI,TLO,THI,ZLO,ZHI
      DOUBLE PRECISION P_AT_PCONST,T_AT_PCONST,Z_AT_PCONST
      DOUBLE PRECISION Z_HALF_LOWEST

      LOGICAL L1,L2,L3,FOUND

C
c  Find least zeta level that is PCONST Pa above the surface.  We
c  later use this level to extrapolate a surface pressure and
c  temperature, which is supposed to reduce the effect of the diurnal
c  heating cycle in the pressure field.

      DO J = 1,NY
          DO I = 1,NX
              LEVEL(I,J) = -1

              K = 1
              FOUND = .false.
              DO WHILE ((.NOT.FOUND) .AND. (K.LE.NZ))
                  IF (P(I,J,K).LT.P(I,J,1)-PCONST) THEN
                      LEVEL(I,J) = K
                      FOUND = .true.
                  END IF
                  K = K + 1
              END DO

              IF (LEVEL(I,J).EQ.-1) THEN
                  PRINT '(A,I4,A)','Troubles finding level ',
     +              NINT(PCONST)/100,' above ground.'
                  PRINT '(A,I4,A,I4,A)','Problems first occur at (',I,
     +              ',',J,')'
                  PRINT '(A,F6.1,A)','Surface pressure = ',P(I,J,1)/100,
     +              ' hPa.'
                  STOP 'Error_in_finding_100_hPa_up'
              END IF

          END DO
      END DO

c     Get temperature PCONST Pa above surface.  Use this to extrapolate
c     the temperature at the surface and down to sea level.

      DO J = 1,NY
          DO I = 1,NX

              KLO = MAX(LEVEL(I,J)-1,1)
              KHI = MIN(KLO+1,NZ-1)

              IF (KLO.EQ.KHI) THEN
                  PRINT '(A)','Trapping levels are weird.'
                  PRINT '(A,I3,A,I3,A)','klo = ',KLO,', khi = ',KHI,
     +              ': and they should not be equal.'
                  STOP 'Error_trapping_levels'
              END IF

              PLO = P(I,J,KLO)
              PHI = P(I,J,KHI)
              TLO = T(I,J,KLO)* (1.D0+0.608D0*Q(I,J,KLO))
              THI = T(I,J,KHI)* (1.D0+0.608D0*Q(I,J,KHI))
c         zlo = zetahalf(klo)/ztop*(ztop-terrain(i,j))+terrain(i,j)
c         zhi = zetahalf(khi)/ztop*(ztop-terrain(i,j))+terrain(i,j)
              ZLO = Z(I,J,KLO)
              ZHI = Z(I,J,KHI)

              P_AT_PCONST = P(I,J,1) - PCONST
              T_AT_PCONST = THI - (THI-TLO)*LOG(P_AT_PCONST/PHI)*
     +                      LOG(PLO/PHI)
              Z_AT_PCONST = ZHI - (ZHI-ZLO)*LOG(P_AT_PCONST/PHI)*
     +                      LOG(PLO/PHI)

              T_SURF(I,J) = T_AT_PCONST* (P(I,J,1)/P_AT_PCONST)**
     +                      (GAMMA*R/G)
              T_SEA_LEVEL(I,J) = T_AT_PCONST + GAMMA*Z_AT_PCONST

          END DO
      END DO

C
c If we follow a traditional computation, there is a correction to the
c sea level temperature if both the surface and sea level
c temperatures are *too* hot.

      IF (RIDICULOUS_MM5_TEST) THEN
          DO J = 1,NY
              DO I = 1,NX
                  L1 = T_SEA_LEVEL(I,J) .LT. TC
                  L2 = T_SURF(I,J) .LE. TC
                  L3 = .NOT. L1
                  IF (L2 .AND. L3) THEN
                      T_SEA_LEVEL(I,J) = TC
                  ELSE
                      T_SEA_LEVEL(I,J) = TC -
     +                                   0.005D0* (T_SURF(I,J)-TC)**2
                  END IF
              END DO
          END DO
      END IF

c     The grand finale: ta da!

      DO J = 1,NY
          DO I = 1,NX
c   z_half_lowest=zetahalf(1)/ztop*(ztop-terrain(i,j))+terrain(i,j)
              Z_HALF_LOWEST = Z(I,J,1)

C Convert to hPa in this step, by multiplying by 0.01. The original
C Fortran routine didn't do this, but the NCL script that called it
C did, so we moved it here.
              SEA_LEVEL_PRESSURE(I,J) = 0.01 * (P(I,J,1)*
     +                                  EXP((2.D0*G*Z_HALF_LOWEST)/
     +                                  (R* (T_SEA_LEVEL(I,J)+T_SURF(I,
     +                                  J)))))
          END DO
      END DO

c     print *,'sea pres input at weird location i=20,j=1,k=1'
c     print *,'t=',t(20,1,1),t(20,2,1),t(20,3,1)
c     print *,'z=',z(20,1,1),z(20,2,1),z(20,3,1)
c     print *,'p=',p(20,1,1),p(20,2,1),p(20,3,1)
c     print *,'slp=',sea_level_pressure(20,1),
c    *         sea_level_pressure(20,2),sea_level_pressure(20,3)

      END

c---------------------------------------------------

C
C Double precision version. If you make a change here, you
C must make the same change below to filter2d.
C
C NCLFORTSTART
      SUBROUTINE DFILTER2D(A,B,NX,NY,IT,MISSING)
      IMPLICIT NONE
c     Estimate sea level pressure.
      INTEGER NX,NY,IT
      DOUBLE PRECISION A(NX,NY),B(NX,NY),MISSING
C NCLEND

      DOUBLE PRECISION COEF
      PARAMETER (COEF=0.25D0)
      INTEGER I,J,ITER

      DO ITER = 1,IT
          DO J = 1,NY
              DO I = 1,NX
                  B(I,J) = A(I,J)
              END DO
          END DO
          DO J = 2,NY - 1
             DO I = 1,NX
                IF ( B(I,J-1).EQ.MISSING .OR. B(I,J).EQ.MISSING .OR.
     +               B(I,J+1).EQ.MISSING ) THEN
                   A(I,J) = A(I,J)
                ELSE
                   A(I,J) = A(I,J) + COEF* (B(I,J-1)-2*B(I,J)+B(I,J+1))
                END IF
             END DO
          END DO
          DO J = 1,NY
             DO I = 2,NX - 1
                IF ( B(I-1,J).EQ.MISSING .OR. B(I,J).EQ.MISSING .OR.
     +               B(I+1,J).EQ.MISSING ) THEN
                   A(I,J) = A(I,J)
                ELSE
                   A(I,J) = A(I,J) + COEF* (B(I-1,J)-2*B(I,J)+B(I+1,J))
                END IF
             END DO
          END DO
c        do j=1,ny
c        do i=1,nx
c          b(i,j) = a(i,j)
c        enddo
c        enddo
c        do j=2,ny-1
c        do i=1,nx
c          a(i,j) = a(i,j) - .99*coef*(b(i,j-1)-2*b(i,j)+b(i,j+1))
c        enddo
c        enddo
c        do j=1,ny
c        do i=2,nx-1
c          a(i,j) = a(i,j) - .99*coef*(b(i-1,j)-2*b(i,j)+b(i+1,j))
c        enddo
c        enddo
      END DO
      RETURN
      END

C
C Single precision version. If you make a change here, you
C must make the same change above to dfilter2d.
C
C NCLFORTSTART
      SUBROUTINE filter2d( a, b, nx , ny , it, missing)
      IMPLICIT NONE
c     Estimate sea level pressure.
      INTEGER nx , ny, it
      REAL    a(nx,ny),b(nx,ny), missing
C NCLEND

      REAL coef
      parameter( coef = 0.25)
      INTEGER i,j,iter

      do iter=1, it
        do j=1,ny
        do i=1,nx
          b(i,j) = a(i,j)
        enddo
        enddo
        do j=2,ny-1
        do i=1,nx
          if ( b(i,j-1).eq.missing .or. b(i,j).eq.missing .or.
     +         b(i,j+1).eq.missing ) then
             a(i,j) = a(i,j)
          else
             a(i,j) = a(i,j) + coef*(b(i,j-1)-2*b(i,j)+b(i,j+1))
          end if
        enddo
        enddo
        do j=1,ny
        do i=2,nx-1
           if ( b(i-1,j).eq.missing .or. b(i,j).eq.missing .or.
     +          b(i+1,j).eq.missing ) then
              a(i,j) = a(i,j)
           else
              a(i,j) = a(i,j) + coef*(b(i-1,j)-2*b(i,j)+b(i+1,j))
           end if
        enddo
        enddo
c        do j=1,ny
c        do i=1,nx
c          b(i,j) = a(i,j)
c        enddo
c        enddo
c        do j=2,ny-1
c        do i=1,nx
c          a(i,j) = a(i,j) - .99*coef*(b(i,j-1)-2*b(i,j)+b(i,j+1))
c        enddo
c        enddo
c        do j=1,ny
c        do i=2,nx-1
c          a(i,j) = a(i,j) - .99*coef*(b(i-1,j)-2*b(i,j)+b(i+1,j))
c        enddo
c        enddo
      enddo
      return
      end
c---------------------------------------------------------

C NCLFORTSTART
      SUBROUTINE DCOMPUTERH(QV,P,T,RH,NX)

      IMPLICIT NONE
      INTEGER NX
      DOUBLE PRECISION QV(NX),P(NX),T(NX),RH(NX)
C NCLEND
      DOUBLE PRECISION SVP1,SVP2,SVP3,SVPT0
      PARAMETER (SVP1=0.6112D0,SVP2=17.67D0,SVP3=29.65D0,SVPT0=273.15D0)
      INTEGER I
      DOUBLE PRECISION QVS,ES,PRESSURE,TEMPERATURE
      DOUBLE PRECISION EP_2,R_D,R_V
      PARAMETER (R_D=287.D0,R_V=461.6D0,EP_2=R_D/R_V)
      DOUBLE PRECISION EP_3
      PARAMETER (EP_3=0.622D0)

      DO I = 1,NX
         PRESSURE = P(I)
         TEMPERATURE = T(I)
c       es  = 1000.*svp1*
         ES = 10.D0*SVP1*EXP(SVP2* (TEMPERATURE-SVPT0)/
     +        (TEMPERATURE-SVP3))
c       qvs = ep_2*es/(pressure-es)
         QVS = EP_3*ES/ (0.01D0*PRESSURE- (1.D0-EP_3)*ES)
c        rh = 100*amax1(1., qv(i)/qvs)
c       rh(i) = 100.*qv(i)/qvs
         RH(I) = 100.D0*DMAX1(DMIN1(QV(I)/QVS,1.0D0),0.0D0)
      END DO

      RETURN
      END

c----------------------------------------------

C NCLFORTSTART
      SUBROUTINE DGETIJLATLONG(LAT_ARRAY,LONG_ARRAY,LAT,LONGITUDE,
     +                         II,JJ,NX,NY,IMSG)
      IMPLICIT NONE
      INTEGER NX,NY,II,JJ,IMSG
      DOUBLE PRECISION LAT_ARRAY(NX,NY),LONG_ARRAY(NX,NY)
      DOUBLE PRECISION LAT,LONGITUDE
C NCLEND
      DOUBLE PRECISION LONGD,LATD
      INTEGER I,J
      DOUBLE PRECISION IR,JR
      DOUBLE PRECISION DIST_MIN,DIST

C Init to missing. Was hard-coded to -999 initially.
      IR = IMSG
      JR = IMSG

      DIST_MIN = 1.D+20
      DO J = 1,NY
          DO I = 1,NX
              LATD = (LAT_ARRAY(I,J)-LAT)**2
              LONGD = (LONG_ARRAY(I,J)-LONGITUDE)**2
C             LONGD = DMIN1((LONG_ARRAY(I,J)-LONGITUDE)**2,
C    +                (LONG_ARRAY(I,J)+LONGITUDE)**2)
              DIST = SQRT(LATD+LONGD)
              IF (DIST_MIN.GT.DIST) THEN
                  DIST_MIN = DIST
                  IR = DBLE(I)
                  JR = DBLE(J)
              END IF
          END DO
      END DO
C
C The original version of this routine returned IR and JR. But, then
C the NCL script that called this routine was converting IR and JR
C to integer, so why not just return II and JJ?
C
C Also, I'm subtracing 1 here, because it will be returned to NCL
C script which has 0-based indexing.
C
      IF(IR.ne.IMSG.and.JR.ne.IMSG) then
        II = NINT(IR)-1
        JJ = NINT(JR)-1
      ELSE
        II = IMSG
        JJ = IMSG
      END IF

c we will just return the nearest point at present

      RETURN
      END

C NCLFORTSTART
      SUBROUTINE DCOMPUTEUVMET(U,V,UVMET,LONGCA,LONGCB,FLONG,FLAT,
     +                         CEN_LONG,CONE,RPD,NX,NY,NXP1,NYP1,
     +                         ISTAG,IS_MSG_VAL,UMSG,VMSG,UVMETMSG)
      IMPLICIT NONE

C ISTAG should be 0 if the U,V grids are not staggered.
C That is, NY = NYP1 and NX = NXP1.

      INTEGER NX,NY,NXP1,NYP1,ISTAG
      LOGICAL IS_MSG_VAL
      DOUBLE PRECISION U(NXP1,NY),V(NX,NYP1)
      DOUBLE PRECISION UVMET(NX,NY,2)
      DOUBLE PRECISION FLONG(NX,NY),FLAT(NX,NY)
      DOUBLE PRECISION LONGCB(NX,NY),LONGCA(NX,NY)
      DOUBLE PRECISION CEN_LONG,CONE,RPD
      DOUBLE PRECISION UMSG,VMSG,UVMETMSG
C NCLEND

      INTEGER I,J
      DOUBLE PRECISION UK,VK

c      WRITE (6,FMT=*) ' in compute_uvmet ',NX,NY,NXP1,NYP1,ISTAG

      DO J = 1,NY
          DO I = 1,NX

              LONGCA(I,J) = FLONG(I,J) - CEN_LONG
              IF (LONGCA(I,J).GT.180.D0) THEN
                  LONGCA(I,J) = LONGCA(I,J) - 360.D0
              END IF
              IF (LONGCA(I,J).LT.-180.D0) THEN
                  LONGCA(I,J) = LONGCA(I,J) + 360.D0
              END IF
              IF (FLAT(I,J).LT.0.D0) THEN
                  LONGCB(I,J) = -LONGCA(I,J)*CONE*RPD
              ELSE
                  LONGCB(I,J) = LONGCA(I,J)*CONE*RPD
              END IF

              LONGCA(I,J) = COS(LONGCB(I,J))
              LONGCB(I,J) = SIN(LONGCB(I,J))

          END DO
      END DO

c      WRITE (6,FMT=*) ' computing velocities '

      DO J = 1,NY
         DO I = 1,NX
            IF (ISTAG.EQ.1) THEN
               IF (IS_MSG_VAL.AND.(U(I,J).EQ.UMSG.OR.
     +                             V(I,J).EQ.VMSG.OR.
     +                             U(I+1,J).EQ.UMSG.OR.
     +                             V(I,J+1).EQ.VMSG)) THEN
                  UVMET(I,J,1) = UVMETMSG
                  UVMET(I,J,2) = UVMETMSG
               ELSE
                  UK = 0.5D0* (U(I,J)+U(I+1,J))
                  VK = 0.5D0* (V(I,J)+V(I,J+1))
                  UVMET(I,J,1) = VK*LONGCB(I,J) + UK*LONGCA(I,J)
                  UVMET(I,J,2) = VK*LONGCA(I,J) - UK*LONGCB(I,J)
               END IF
            ELSE
               IF (IS_MSG_VAL.AND.(U(I,J).EQ.UMSG.OR.
     +                             V(I,J).EQ.VMSG)) THEN
                  UVMET(I,J,1) = UVMETMSG
                  UVMET(I,J,2) = UVMETMSG
               ELSE
                  UK = U(I,J)
                  VK = V(I,J)
                  UVMET(I,J,1) = VK*LONGCB(I,J) + UK*LONGCA(I,J)
                  UVMET(I,J,2) = VK*LONGCA(I,J) - UK*LONGCB(I,J)
               END IF
            END IF
         END DO
      END DO

      RETURN
      END

C NCLFORTSTART
C
C This was originally a routine that took 2D input arrays. Since
C the NCL C wrapper routine can handle multiple dimensions, it's
C not necessary to have anything bigger than 1D here.
C
      SUBROUTINE DCOMPUTETD(TD,PRESSURE,QV_IN,NX)
      IMPLICIT NONE
      INTEGER NX
      DOUBLE PRECISION PRESSURE(NX)
      DOUBLE PRECISION QV_IN(NX)
      DOUBLE PRECISION TD(NX)
C NCLEND
      DOUBLE PRECISION QV,TDC

      INTEGER I

      DO I = 1,NX
          QV = DMAX1(QV_IN(I),0.D0)
c vapor pressure
          TDC = QV*PRESSURE(I)/ (.622D0+QV)

c avoid problems near zero
          TDC = DMAX1(TDC,0.001D0)
          TD(I) = (243.5D0*LOG(TDC)-440.8D0)/ (19.48D0-LOG(TDC))
      END DO

      RETURN
      END

C NCLFORTSTART
      SUBROUTINE DCOMPUTEICLW(ICLW,PRESSURE,QC_IN,NX,NY,NZ)
      IMPLICIT NONE
      INTEGER NX,NY,NZ
      DOUBLE PRECISION PRESSURE(NX,NY,NZ)
      DOUBLE PRECISION QC_IN(NX,NY,NZ)
      DOUBLE PRECISION ICLW(NX,NY)
      DOUBLE PRECISION QCLW,DP,GG
C NCLEND

      INTEGER I,J,K

      GG = 1000.D0/9.8D0

      DO J = 1,NY
          DO I = 1,NX
              ICLW(I,J) = 0.D0
          END DO
      END DO

      DO J = 3,NY - 2
          DO I = 3,NX - 2
              DO K = 1,NZ
                  QCLW = DMAX1(QC_IN(I,J,K),0.D0)
                  IF (K.EQ.1) THEN
                      DP = (PRESSURE(I,J,K-1)-PRESSURE(I,J,K))
                  ELSE IF (K.EQ.NZ) THEN
                      DP = (PRESSURE(I,J,K)-PRESSURE(I,J,K+1))
                  ELSE
                      DP = (PRESSURE(I,J,K-1)-PRESSURE(I,J,K+1))/2.D0
                  END IF
                  ICLW(I,J) = ICLW(I,J) + QCLW*DP*GG
              END DO
          END DO
      END DO

      RETURN
      END


      program fivept
c-----------------------------------------------------------------------
c main program for generating 5 point and 7-point matrices in the
c Harwell-Boeing format.  Creates a file with containing a
c harwell-boeing matrix. typical session:
c user answer are after the colon
c Enter nx, ny, nz  : 10 10 1
c Filename for matrix: test.mat
c output matrix in data file : test.mat
c
c nz = 1 will create a 2-D problem
c
c-----------------------------------------------------------------------
      integer nmx, nxmax
      parameter (nxmax = 50, nmx = nxmax*nxmax)
c      implicit none
      integer ia(nmx),ja(7*nmx),iau(nmx)
      real*8 a(7*nmx),rhs(nmx),al(6)
      character title*72, key*8, type*3, matfile*50, guesol*2
c-----------------------------------------------------------------------
      integer nx, ny, nz, iout, n, ifmt, job
      write (6,*)  '  '
      write(6,'(22hEnter  nx, ny, nz   : ,$)')
      read (5,*) nx, ny, nz
      write(6,'(22hFilename for matrix : ,$)')
      read(5,'(a50)') matfile
      open (unit=7,file=matfile)
c
c     boundary condition is partly specified here
c
c      al(1) = 1.0D0
c      al(2) = 0.0D0
c      al(3) = 2.3D1
c      al(4) = 0.4D0
c      al(5) = 0.0D0
c      al(6) = 8.2D-2
       al(1) = 0.0D0
       al(2) = 0.0D0
       al(3) = 0.0D1
       al(4) = 0.0D0
       al(5) = 0.0D0
       al(6) = 0.0D0
c
      call gen57pt (nx,ny,nz,al,0,n,a,ja,ia,iau,rhs)
      iout = 7
c
c     write out the matrix
c
      guesol='NN'
      title =
     *     ' 5-POINT TEST MATRIX FROM SPARSKIT                    '
c          '123456789012345678901234567890123456789012345678901234567890
      type  = 'RUA'
      key ='SC5POINT'
C           12345678
      ifmt = 15
      job = 2
c   upper part only??
c      call getu (n, a, ja, ia, a, ja, ia)
      call prtmt (n,n,a,ja,ia,rhs,guesol,title,key,type,
     1     ifmt,job,iout)
      write (6,*) ' output matrix in data file : ', matfile
c
      stop
      end


C$Procedure      EL2CGV ( Ellipse to center and generating vectors )

      SUBROUTINE EL2CGV ( ELLIPS, CENTER, SMAJOR, SMINOR )

C$ Abstract
C
C     Convert a SPICELIB ellipse to a center vector and two generating
C     vectors.  The selected generating vectors are semi-axes of the
C     ellipse.
C
C$ Disclaimer
C
C     THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE
C     CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S.
C     GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE
C     ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE
C     PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS"
C     TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY
C     WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A
C     PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC
C     SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE
C     SOFTWARE AND RELATED MATERIALS, HOWEVER USED.
C
C     IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA
C     BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT
C     LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND,
C     INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS,
C     REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE
C     REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY.
C
C     RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF
C     THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY
C     CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE
C     ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE.
C
C$ Required_Reading
C
C     ELLIPSES
C
C$ Keywords
C
C     ELLIPSE
C     GEOMETRY
C
C$ Declarations

      INTEGER               UBEL
      PARAMETER           ( UBEL    =   9 )

      DOUBLE PRECISION      ELLIPS ( UBEL )
      DOUBLE PRECISION      CENTER (    3 )
      DOUBLE PRECISION      SMAJOR (    3 )
      DOUBLE PRECISION      SMINOR (    3 )

C$ Brief_I/O
C
C     Variable  I/O  Description
C     --------  ---  --------------------------------------------------
C     ELLIPS     I   A SPICELIB ellipse.
C     CENTER,
C     SMAJOR,
C     SMINOR     O   Center and semi-axes of ELLIPS.
C
C$ Detailed_Input
C
C     ELLIPS         is a SPICELIB ellipse.
C
C$ Detailed_Output
C
C     CENTER,
C     SMAJOR,
C     SMINOR         are, respectively, a center vector, a semi-major
C                    axis vector, and a semi-minor axis vector that
C                    generate the input ellipse.  This ellipse is the
C                    set of points
C
C                       CENTER + cos(theta) SMAJOR + sin(theta) SMINOR
C
C                    where theta ranges over the interval (-pi, pi].
C
C$ Parameters
C
C     None.
C
C$ Exceptions
C
C     Error free.
C
C$ Files
C
C     None.
C
C$ Particulars
C
C     SPICELIB ellipses serve to simplify calling sequences and reduce
C     the chance for error in declaring and describing argument lists
C     involving ellipses.
C
C     The set of ellipse conversion routines is
C
C        CGV2EL ( Center and generating vectors to ellipse )
C        EL2CGV ( Ellipse to center and generating vectors )
C
C     A word about the output of this routine:   the semi-major axis of
C     an ellipse is a vector of largest possible magnitude in the set
C
C        cos(theta) VEC1  +  sin(theta) VEC2,
C
C     where theta is in the interval (-pi, pi].  There are two such
C     vectors; they are additive inverses of each other. The semi-minor
C     axis is an analogous vector of smallest possible magnitude.  The
C     semi-major and semi-minor axes are orthogonal to each other.  If
C     SMAJOR and SMINOR are choices of semi-major and semi-minor axes,
C     then the input ellipse can also be represented as the set of
C     points
C
C
C        CENTER + cos(theta) SMAJOR + sin(theta) SMINOR
C
C     where theta ranges over the interval (-pi, pi].
C
C$ Examples
C
C     1)  Find the semi-axes of the limb of an ellipsoid.
C
C         C
C         C     Our viewing location is VIEWPT.  The radii of the
C         C     ellipsoid are A, B, and C.
C         C
C               CALL EDLIMB ( A, B, C, VIEWPT, LIMB )
C
C               CALL EL2CGV ( LIMB, CENTER, SMAJOR, SMINOR )
C
C$ Restrictions
C
C     None.
C
C$ Literature_References
C
C     None.
C
C$ Author_and_Institution
C
C     N.J. Bachman   (JPL)
C
C$ Version
C
C-    SPICELIB Version 1.0.1, 10-MAR-1992 (WLT)
C
C        Comment section for permuted index source lines was added
C        following the header.
C
C-    SPICELIB Version 1.0.0, 02-NOV-1990 (NJB)
C
C-&

C$ Index_Entries
C
C     ellipse to center and generating vectors
C
C-&

C
C     Local parameters
C

C
C     SPICELIB ellipses contain a center vector, a semi-major
C     axis vector, and a semi-minor axis vector.  These are
C     located, respectively, in elements
C
C        CTRPOS through CTRPOS + 1
C
C        MAJPOS through MAJPOS + 1
C
C        MINPOS through MINPOS + 1
C
C
      INTEGER               CTRPOS
      PARAMETER           ( CTRPOS = 1 )

      INTEGER               MAJPOS
      PARAMETER           ( MAJPOS = 4 )

      INTEGER               MINPOS
      PARAMETER           ( MINPOS = 7 )

C
C     The center of the ellipse is held in the first three elements.
C     The semi-major and semi-minor axes come next.
C
      CALL VEQU ( ELLIPS(CTRPOS), CENTER )
      CALL VEQU ( ELLIPS(MAJPOS), SMAJOR )
      CALL VEQU ( ELLIPS(MINPOS), SMINOR )

      RETURN
      END


      REAL FUNCTION FMKIEEE(A)
 !$$$ SUBPROGRAM DOCUMENTATION BLOCK
 ! . . . .
 ! SUBPROGRAM: mkieee
 ! PRGMMR: Gilbert ORG: W/NP11 DATE: 2000-05-09
 !
 ! ABSTRACT: This subroutine stores a list of real values in
 ! 32-bit IEEE floating point format.
 !
 ! PROGRAM HISTORY LOG:
 ! 2000-05-09 Gilbert
 !
 ! USAGE: CALL mkieee(a)
 ! INPUT ARGUMENT LIST:
 ! a - Input floating point value.
 !
 ! OUTPUT ARGUMENT LIST: None.
 !
 ! REMARKS: None
 !
 ! ATTRIBUTES:
 ! LANGUAGE: Fortran 90
 ! MACHINE: IBM SP
 !
 !$$$

      PARAMETER (two23=2.**23)
      PARAMETER (two126=2.**126)
C
      EQUIVALENCE(RTEMP,IEEE)
C
      alog2=alog(2.0)

      ieee=0

      if (a.ne.0.) then
 !
 ! Set Sign bit (bit 31 - leftmost bit)
 !
         if (a.lt.0.0) then
           ieee=ibset(ieee,31)
           atemp=abs(a)
         else
           ieee=ibclr(ieee,31)
           atemp=a
         endif
 !
 ! Determine exponent n with base 2
 !
         n=INT(flr(alog(atemp)/alog2))
         iexp=n+127
         if (n.gt.127) iexp=255 ! overflow
         if (n.lt.-127) iexp=0
         ! set exponent bits ( bits 30-23 )
         call mvbits(iexp,0,8,ieee,23)
 !
 ! Determine Mantissa
 !
         if (iexp.ne.255) then
           if (iexp.ne.0) then
             atemp=(atemp/(2.0**n))-1.0
           else
             atemp=atemp*two126
           endif
           imant=nint(atemp*two23)
         else
           imant=0
         endif
         ! set mantissa bits ( bits 22-0 )
         call mvbits(imant,0,23,ieee,0)
      endif
C
      FMKIEEE=RTEMP
      return
      end


      implicit real*8 (a-h,o-z)
      parameter(nmax=100)
      dimension a(nmax,nmax),w(nmax),z(nmax,nmax)
      read(*,*)nn
      do i=1,nn
        read(*,*)(a(i,j),j=1,nn)
      end do
      call diag(a,100,nn,w,z)
      write(*,'(/a,i2)')' The total number of eigenvalues found:', nn
      write(*,'(100f9.5)')(w(i),i=1,nn)
      write(*,'(/a)')' The eigenvectors are:'
      do i=1,nn
        write(*,'(2x,100f9.5)')(z(i,j),j=1,nn)
      end do
      end


      program bathy2d
      use mod_za  ! HYCOM array I/O interface
      implicit none
c
      integer   i,j,ishelf
      real      hmaxa,hmaxb,hmina,hminb,flat,break,shelf
      character preambl(5)*79,cline*80
c
c --- create a 2-D (constant in j) shelf/deep/shelf bathymetry file.
c
      integer, allocatable :: ip(:,:)
      real,    allocatable :: dh(:,:)
c
      call xcspmd  !input idm,jdm
      allocate( ip(idm,jdm) )
      allocate( dh(idm,jdm) )
c
      call zaiost
c
c --- read in the shelf/shelf-break/deep depths
c
      read(5,*) shelf,break,flat
c
c --- header.
c
      preambl(1) =
     +  '2-D (constant in j) shelf/deep/shelf bathymetry'
      write(preambl(2),'(a,3f8.2)')
     +        'shelf,break,flat =',shelf,break,flat
      write(preambl(3),'(a,2i5)')
     +        'i/jdm =',
     +       idm,jdm
      preambl(4) = ' '
      preambl(5) = ' '
c
      write(6, *)
      write(6, *)       'header:'
      write(6, '(A79)') preambl
      call zhflsh(6)
c
      call zhopen(61, 'formatted', 'new', 0)
      write(61,'(A79)') preambl
c
c --- land mask and bathymetry.
c
      ishelf = (idm+6)/6
      ip(:,  1) = 1
      ip(idm,1) = 0
      dh(:,  1) = flat
      dh(idm,1) = 0.0
      do i= 1,ishelf
        dh(i,       1) = shelf + (i-1)*(break-shelf)/real(ishelf)
        dh(i+ishelf,1) = break + (i-1)*(flat -break)/real(ishelf)
        dh(idm-i,       1) = dh(i,       1)
        dh(idm-i-ishelf,1) = dh(i+ishelf,1)
      enddo
*     if     (jdm.le.6) then  !2d domain
        do j= 2,jdm
          ip(:,j) = ip(:,1)
          dh(:,j) = dh(:,1)
        enddo
*     else !closed 3-d domain
*       do j= 2,jdm-1
*         ip(:,j) = ip(:,1)
*         dh(:,j) = dh(:,1)
*       enddo
*       ip(:,jdm) = 0
*       dh(:,jdm) = 0.0
*     endif
c
      write(6,*)
      do i= 1,idm
        write(6,'(a,i4,f8.1)') 'i,dh =',i,dh(i,1)
      enddo
      write(6,*)
c
c --- write out the hycom topography file,
c
      call zaiopn('new', 61)
      call zaiowr(dh, ip,.true., hmina,hmaxa, 61, .false.)
      write(61,6100) hmina,hmaxa
      write(6, 6100) hmina,hmaxa
      write(6, *)
 6100 format('min,max depth = ',2f10.3)
c
      end


module init_fluid_module

      use amrex_fort_module, only: rt => amrex_real
      use iso_c_binding,     only: c_int

contains
!vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv!
!                                                                      !
!  Subroutine: init_fluid                                              !
!                                                                      !
!^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^!
   subroutine init_fluid(slo, shi, lo, hi, &
                         domlo, domhi, p, vel, density, tracer, eta, &
                         dx, dy, dz, xlo, ylo, zlo, probtype) &
      bind(C, name="init_fluid")

      use constant, only: ro_0, mu
      use constant, only: ic_u, ic_v, ic_w, ntrac

      implicit none

! Dummy arguments .....................................................//
      integer(c_int), intent(in   ) ::  lo(3),  hi(3)
      integer(c_int), intent(in   ) :: slo(3), shi(3)
      integer(c_int), intent(in   ) :: domlo(3),domhi(3)

      real(rt), intent(inout) ::       p(slo(1):shi(1), slo(2):shi(2), slo(3):shi(3)  )
      real(rt), intent(inout) ::     vel(slo(1):shi(1), slo(2):shi(2), slo(3):shi(3),3)
      real(rt), intent(inout) :: density(slo(1):shi(1), slo(2):shi(2), slo(3):shi(3))
      real(rt), intent(inout) ::  tracer(slo(1):shi(1), slo(2):shi(2), slo(3):shi(3),ntrac)
      real(rt), intent(inout) ::     eta(slo(1):shi(1), slo(2):shi(2), slo(3):shi(3)  )

      real(rt), intent(in   ) :: dx, dy, dz
      real(rt), intent(in   ) :: xlo,ylo,zlo
      integer,  intent(in   ) :: probtype

      ! Set the initial fluid density and viscosity
      vel(:,:,:,1) = ic_u
      vel(:,:,:,2) = ic_v
      vel(:,:,:,3) = ic_w

      density = ro_0
      tracer  = 0.0
      eta     = mu

      if (probtype ==  5) call tracer_advection(lo, hi, vel, tracer, slo, shi, dx, dy, dz, domlo)

      if (probtype ==  1) call taylor_green(lo, hi, vel, slo, shi, dx, dy, dz, domlo)
      if (probtype ==  2) call double_shear_layer(lo, hi, vel, slo, shi, dx, dy, dz, domlo)
      if (probtype ==  3) call taylor_green3d(lo, hi, vel, slo, shi, dx, dy, dz, domlo)
      if (probtype == 31) call plane_poiseuille(lo, hi, vel, tracer, slo, shi, dx, dy, dz, domlo, domhi, probtype)
      if (probtype == 32) call plane_poiseuille(lo, hi, vel, tracer, slo, shi, dx, dy, dz, domlo, domhi, probtype)
      if (probtype == 33) call plane_poiseuille(lo, hi, vel, tracer, slo, shi, dx, dy, dz, domlo, domhi, probtype)
      if (probtype ==  4) call couette(lo, hi, vel, slo, shi, dx, dy, dz, domlo, domhi)
      if (probtype == 11) call tuscan(lo, hi, vel, density, tracer, slo, shi, dx, dy, dz, domlo, domhi)
      if (probtype == 34) call channel_flow(lo, hi, vel, tracer, slo, shi, dx, dy, dz, domlo, domhi, xlo, ylo, zlo)

   end subroutine init_fluid

   subroutine tracer_advection(lo, hi, vel, tracer, slo, shi, dx, dy, dz, domlo)

      use constant, only: zero, half, one

      implicit none

      ! Array bounds
      integer(c_int), intent(in   ) :: lo(3), hi(3)
      integer(c_int), intent(in   ) :: domlo(3)
      integer(c_int), intent(in   ) :: slo(3), shi(3)

      ! Arrays
      real(rt),       intent(inout) ::    vel(slo(1):shi(1),slo(2):shi(2),slo(3):shi(3),3)
      real(rt),       intent(inout) :: tracer(slo(1):shi(1),slo(2):shi(2),slo(3):shi(3),3)

      real(rt),       intent(in   ) :: dx, dy, dz

      ! Local variables
      integer(c_int)                  :: i, j, k
      real(rt)                        :: x, y
      real(rt)                        :: twopi = 8.0_rt * atan(one)

      ! x-direction
      do j = lo(2), hi(2)
         y =  ( real(j,rt) + half ) * dy
         do i = lo(1), hi(1)
            x =  ( real(i,rt) + half ) * dx
            do k = lo(3), hi(3)
               tracer(i,j,k,:) = 1.d0
               if (i.eq.20 .and. j.eq.20 .and. k.eq.20) tracer(i,j,k,1) = 1.2d0
            end do
         end do
      end do

   end subroutine tracer_advection

   subroutine taylor_green(lo, hi, vel, slo, shi, dx, dy, dz, domlo)

      use constant, only: zero, half, one

      implicit none

      ! Array bounds
      integer(c_int), intent(in   ) :: lo(3), hi(3)
      integer(c_int), intent(in   ) :: domlo(3)
      integer(c_int), intent(in   ) :: slo(3), shi(3)

      ! Arrays
      real(rt),       intent(inout) :: vel(slo(1):shi(1),slo(2):shi(2),slo(3):shi(3),3)

      real(rt),       intent(in   ) :: dx, dy, dz

      ! Local variables
      integer(c_int)                  :: i, j, k
      real(rt)                        :: x, y
      real(rt)                        :: twopi = 8.0_rt * atan(one)

      ! x-direction
      do j = lo(2), hi(2)
         y =  ( real(j,rt) + half ) * dy
         do i = lo(1), hi(1)
            x =  ( real(i,rt) + half ) * dx
            do k = lo(3), hi(3)
               vel(i,j,k,1) =  sin(twopi * x) * cos(twopi * y)
               vel(i,j,k,2) = -cos(twopi * x) * sin(twopi * y)
               vel(i,j,k,3) = zero
            end do
         end do
      end do

   end subroutine taylor_green

    subroutine taylor_green3d(lo, hi, vel, slo, shi, dx, dy, dz, domlo)

       use constant, only: zero, half, one

       implicit none

       ! Array bounds
       integer(c_int), intent(in   ) :: lo(3), hi(3)
       integer(c_int), intent(in   ) :: domlo(3)
       integer(c_int), intent(in   ) :: slo(3), shi(3)

       ! Arrays
       real(rt),       intent(inout) :: vel(slo(1):shi(1),slo(2):shi(2),slo(3):shi(3),3)

       real(rt),       intent(in   ) :: dx, dy, dz

       ! Local variables
       integer(c_int)                  :: i, j, k
       real(rt)                        :: x, y, z
       real(rt)                        :: twopi = 8.0_rt * atan(one)

       do j = lo(2), hi(2)
          y =  ( real(j,rt) + half ) * dy
          do i = lo(1), hi(1)
             x =  ( real(i,rt) + half ) * dx
             do k = lo(3), hi(3)
                z =  ( real(k,rt) + half ) * dz
                vel(i,j,k,1) =  sin(twopi * x) * cos(twopi * y) * cos(twopi * z)
                vel(i,j,k,2) = -cos(twopi * x) * sin(twopi * y) * cos(twopi * z)
                vel(i,j,k,3) = zero
             end do
          end do
       end do

    end subroutine taylor_green3d

   subroutine double_shear_layer(lo, hi, vel, slo, shi, dx, dy, dz, domlo)

      use constant, only: zero, half, one

      implicit none

      ! Array bounds
      integer(c_int), intent(in   ) :: lo(3), hi(3)
      integer(c_int), intent(in   ) :: domlo(3)
      integer(c_int), intent(in   ) :: slo(3), shi(3)

      ! Arrays
      real(rt),       intent(inout) :: vel(slo(1):shi(1),slo(2):shi(2),slo(3):shi(3),3)

      real(rt),       intent(in   ) :: dx, dy, dz

      ! Local variables
      integer(c_int)                :: i, j, k, plane
      real(rt)                      :: x, y, z
      real(rt)                      :: twopi = 8.0_rt * atan(one)

      plane = 1

      select case ( plane )

      case (1)  ! x-y plane

         ! x-direction
         do j = lo(2), hi(2)
            y =  ( real(j,rt) + half ) * dy
            do i = lo(1), hi(1)
               x =  ( real(i,rt) + half ) * dx
               do k = lo(3), hi(3)
                  vel(i,j,k,1) = tanh ( 30.0_rt * (0.25_rt - abs ( y - 0.5_rt ) ) )
                  vel(i,j,k,2) = 0.05_rt * sin ( twopi * x )
                  vel(i,j,k,3) = zero
               end do
            end do
         end do

      case (2)  ! x-z plane

         ! x-direction
         do k = lo(3), hi(3)
            z =  ( real(k,rt) + half ) * dz
            do i = lo(1), hi(1)
               x =  ( real(i,rt) + half ) * dx
               do j = lo(2), hi(2)
                  vel(i,j,k,1) = tanh ( 30.0_rt * (0.25_rt - abs ( z - 0.5_rt ) ) )
                  vel(i,j,k,2) = zero
                  vel(i,j,k,3) = 0.05_rt * sin ( twopi * x )
               end do
            end do
         end do

      case (3)  ! y-z plane

         ! x-direction
         do k = lo(3), hi(3)
            z =  ( real(k,rt) + half ) * dz
            do j = lo(2), hi(2)
               y =  ( real(j,rt) + half ) * dy
               do i = lo(1), hi(1)
                  vel(i,j,k,1) = zero
                  vel(i,j,k,2) = tanh ( 30.0_rt * (0.25_rt - abs ( z - 0.5_rt ) ) )
                  vel(i,j,k,3) = 0.05_rt * sin ( twopi * y )
               end do
            end do
         end do

      end select

   end subroutine double_shear_layer

   subroutine plane_poiseuille(lo, hi, vel, tracer, slo, shi, dx, dy, dz, domlo, domhi, probtype)

      use constant, only: ic_u, ic_v, ic_w, ntrac

      implicit none

      integer(c_int),   intent(in   ) ::    lo(3),    hi(3)
      integer(c_int),   intent(in   ) :: domlo(3), domhi(3)
      integer(c_int),   intent(in   ) ::   slo(3),   shi(3)
      integer(c_int),   intent(in   ) :: probtype

      real(rt),         intent(in   ) :: dx, dy, dz
      real(rt),         intent(inout) ::    vel(slo(1):shi(1), slo(2):shi(2), slo(3):shi(3), 3)
      real(rt),         intent(inout) :: tracer(slo(1):shi(1), slo(2):shi(2), slo(3):shi(3), ntrac)

      ! Local variables
      integer(c_int)                  :: i, j, k
      integer(c_int)                  :: num_cells
      real(rt)                        :: x, y, z

      if (probtype .eq. 31) then

         num_cells = domhi(2) - domlo(2) + 1

!        if (ntrac .ne. 3) then
!           print *,"ntrac here is ", ntrac
!           print *,"probtype = 31 is supposed to have 3 tracers!"
!           stop
!        end if

         do k = lo(3), hi(3)
         do j = lo(2), hi(2)
            do i = lo(1), hi(1)
               y =  (real(j,rt) + 0.5d0) / dble(num_cells)
               x =  (real(i,rt) + 0.5d0) / dble(num_cells)
               vel(i,j,k,1) = 6.0d0 * ic_u * y * (1.0d0 - y)
               vel(i,j,k,2) = 0.0d0
               vel(i,j,k,3) = 0.0d0
               tracer(i,j,k,1:ntrac) = 0.0d0
               if (ntrac .gt. 0 .and. i .le. domhi(1)/8) &
                  tracer(i,j,k,1) = 1.d0
               if (ntrac .gt. 1 .and. i .le. domhi(1)/2) &
                  tracer(i,j,k,2) = 2.d0
               if (ntrac .gt. 2 .and. i .le. 3*domhi(1)/4) &
                  tracer(i,j,k,3) = 3.d0
            end do
         end do
         end do

      else if (probtype .eq. 32) then

         num_cells = domhi(3) - domlo(3) + 1

         do k = lo(3), hi(3)
         do j = lo(2), hi(2)
            do i = lo(1), hi(1)
               z =  (real(k,rt) + 0.5d0) / dble(num_cells)
               vel(i,j,k,1) = 0.0d0
               vel(i,j,k,2) = 6.0d0 * ic_v * z * (1.0d0 - z)
               vel(i,j,k,3) = 0.0d0
               tracer(i,j,k,1:ntrac) = 0.0d0
               if (ntrac .gt. 0 .and. j .le. domhi(2)/8) &
                  tracer(i,j,k,1) = 1.d0
               if (ntrac .gt. 1 .and. j .le. domhi(2)/2) &
                  tracer(i,j,k,2) = 2.d0
               if (ntrac .gt. 2 .and. j .le. 3*domhi(2)/4) &
                  tracer(i,j,k,3) = 3.d0
            end do
         end do
         end do

      else if (probtype .eq. 33) then

         num_cells = domhi(1) - domlo(1) + 1

         do k = lo(3), hi(3)
         do j = lo(2), hi(2)
            do i = lo(1), hi(1)
               x =  (real(i,rt) + 0.5d0) / dble(num_cells)
               vel(i,j,k,1) = 0.0d0
               vel(i,j,k,2) = 0.0d0
               vel(i,j,k,3) = 6.0d0 * ic_w * x * (1.0d0 - x)
               tracer(i,j,k,1:ntrac) = 0.0d0
               if (ntrac .gt. 0 .and. k .le. domhi(3)/8) &
                  tracer(i,j,k,1) = 1.d0
               if (ntrac .gt. 1 .and. k .le. domhi(3)/2) &
                  tracer(i,j,k,2) = 2.d0
               if (ntrac .gt. 2 .and. k .le. 3*domhi(3)/4) &
                  tracer(i,j,k,3) = 3.d0
            end do
         end do
         end do

      else
          print *,'Dont know this probtype in plane_poiseuille: ', probtype
          stop
      end if

   end subroutine plane_poiseuille

   subroutine couette(lo, hi, vel, slo, shi, dx, dy, dz, domlo, domhi)

      use constant,          only: zero, half, one
      use constant,          only: ic_u

      implicit none

      integer(c_int),   intent(in   ) ::    lo(3),    hi(3)
      integer(c_int),   intent(in   ) :: domlo(3), domhi(3)
      integer(c_int),   intent(in   ) ::   slo(3),   shi(3)

      real(rt),         intent(inout) :: vel(slo(1):shi(1), slo(2):shi(2), slo(3):shi(3), 3)

      real(rt),         intent(in   ) :: dx, dy, dz

      ! Local variables
      integer(c_int)                  :: i, j, k
      integer(c_int)                  :: num_cells_y
      real(rt)                        :: y

      num_cells_y = domhi(2) - domlo(2) + 1

      do k = lo(3), hi(3)
         do j = lo(2), hi(2)
            y =  (real(j,rt) + half) / num_cells_y
            do i = lo(1), hi(1)
               vel(i,j,k,1) = ic_u * (y - half)
               vel(i,j,k,2) = zero
               vel(i,j,k,3) = zero
            end do
         end do
      end do

   end subroutine couette

   subroutine tuscan(lo, hi, vel, density, tracer, slo, shi, dx, dy, dz, domlo, domhi)

      use constant,          only: zero, half, one

      implicit none

      integer(c_int),   intent(in   ) ::    lo(3),    hi(3)
      integer(c_int),   intent(in   ) :: domlo(3), domhi(3)
      integer(c_int),   intent(in   ) ::   slo(3),   shi(3)

      real(rt),         intent(inout) ::     vel(slo(1):shi(1), slo(2):shi(2), slo(3):shi(3), 3)
      real(rt),         intent(inout) :: density(slo(1):shi(1), slo(2):shi(2), slo(3):shi(3))
      real(rt),         intent(inout) ::  tracer(slo(1):shi(1), slo(2):shi(2), slo(3):shi(3))

      real(rt),         intent(in   ) :: dx, dy, dz

      ! Local variables
      integer(c_int)                  :: i, j, k
      integer(c_int)                  :: num_cells
      real(rt)                        :: pert

      num_cells = domhi(3) - domlo(3) + 1

      pert = 0.01d0

      ! Start the flow at rest
      vel = zero

      do k = lo(3), hi(3)
         do j = lo(2), hi(2)
            do i = lo(1), hi(1)
               if (k .le. num_cells/2) then
                  density(i,j,k) = one
                  tracer (i,j,k) = zero
               else
                  density(i,j,k) = one
                  tracer (i,j,k) = zero + pert
               endif
            end do
         end do
      end do

   end subroutine tuscan

   subroutine channel_flow(lo, hi, vel, tracer, slo, shi, dx, dy, dz, domlo, domhi, xlo, ylo, zlo)

      use constant, only: ic_u, ic_v, ic_w, ntrac,one

      implicit none

      integer(c_int),   intent(in   ) ::    lo(3),    hi(3)
      integer(c_int),   intent(in   ) :: domlo(3), domhi(3)
      integer(c_int),   intent(in   ) ::   slo(3),   shi(3)

      real(rt),         intent(in   ) :: dx, dy, dz, xlo, ylo, zlo
      real(rt),         intent(inout) ::    vel(slo(1):shi(1), slo(2):shi(2),slo(3):shi(3), 3)
      real(rt),         intent(inout) :: tracer(slo(1):shi(1), slo(2):shi(2),slo(3):shi(3), ntrac)

      ! Local variables
      integer(c_int)                  :: i, j, k
      integer(c_int)                  :: num_cells, num_cells_x, num_cells_y,num_cells_z
      real(rt)                        :: x, y, z, yval, zval, pi

      pi = 4.0_rt * atan(one)

      do k = lo(3), hi(3)
         z = zlo + dz*(real(k,rt) + 0.5d0)
         do j = lo(2), hi(2)
            y = ylo + dy*(real(j,rt) + 0.5d0)
            do i = lo(1), hi(1)
               x = xlo + dx*(real(i,rt) + 0.5d0)

               vel(i,j,k,1) = 8.0d0*(5.0d0*(1.0d0-z**4)/4.0d0 + 0.3d0*cos(5.0d0*pi*y)*exp(0.5-32.4*(1.0d0-abs(z))**2)*(1.0d0-abs(z)))
               vel(i,j,k,2) = 8.0d0*21.6d0*sin(4.0d0*pi*x)*exp(-32.4d0*(1.0d0-abs(z))**2)*(1.0d0-abs(z))
               vel(i,j,k,3) = 0.0d0
               tracer(i,j,k,1:ntrac) = 0.0d0
               if (ntrac .gt. 0 .and. i .le. domhi(1)/4) &
                  tracer(i,j,k,1) = 1.d0
               if (ntrac .gt. 1 .and. i .le. domhi(1)/2) &
                  tracer(i,j,k,2) = 2.d0
               if (ntrac .gt. 2 .and. i .le. 3*domhi(1)/4) &
                  tracer(i,j,k,3) = 3.d0
            end do
         end do
      end do

   end subroutine channel_flow

end module init_fluid_module


      subroutine gauinv(p,xp,ierr)
c-----------------------------------------------------------------------
c
c Computes the inverse of the standard normal cumulative distribution
c function with a numerical approximation from : Statistical Computing,
c by W.J. Kennedy, Jr. and James E. Gentle, 1980, p. 95.
c
c
c
c INPUT/OUTPUT:
c
c   p    = double precision cumulative probability value: dble(psingle)
c   xp   = G^-1 (p) in single precision
c   ierr = 1 - then error situation (p out of range), 0 - OK
c
c
c-----------------------------------------------------------------------
      real*8 p0,p1,p2,p3,p4,q0,q1,q2,q3,q4,y,pp,lim,p
      save   p0,p1,p2,p3,p4,q0,q1,q2,q3,q4,lim
c
c Coefficients of approximation:
c
      data lim/1.0e-10/
      data p0/-0.322232431088/,p1/-1.0/,p2/-0.342242088547/,
     +     p3/-0.0204231210245/,p4/-0.0000453642210148/
      data q0/0.0993484626060/,q1/0.588581570495/,q2/0.531103462366/,
     +     q3/0.103537752850/,q4/0.0038560700634/
c
c Check for an error situation:
c
      ierr = 1
      if(p.lt.lim) then
            xp = -1.0e10
            return
      end if
      if(p.gt.(1.0-lim)) then
            xp =  1.0e10
            return
      end if
      ierr = 0
c
c Get k for an error situation:
c
      pp   = p
      if(p.gt.0.5) pp = 1 - pp
      xp   = 0.0
      if(p.eq.0.5) return
c
c Approximate the function:
c
      y  = dsqrt(dlog(1.0/(pp*pp)))
      xp = real( y + ((((y*p4+p3)*y+p2)*y+p1)*y+p0) /
     +               ((((y*q4+q3)*y+q2)*y+q1)*y+q0) )
      if(real(p).eq.real(pp)) xp = -xp
c
c Return with G^-1(p):
c
      return
      end


! { dg-do run }
! { dg-options "-fdefault-integer-8" }
! PR fortran/32942
! Testcase contributed by Dominique d'Humieres <dominiq@lps.ens.fr>.
integer i
real x
x = 3.0
if (2 /= exponent(x)) call abort
i = exponent (x)
if (i /= 2) call abort
end


! RUN: %flang_fc1 -fdebug-unparse %s 2>&1 | FileCheck %s

! Check the analyzed form of a defined operator or assignment.

! Type-bound defined assignment
module m1
  type :: t
  contains
    procedure :: b1 => s1
    procedure, pass(y) :: b2 => s2
    generic :: assignment(=) => b1, b2
  end type
contains
  subroutine s1(x, y)
    class(t), intent(out) :: x
    integer, intent(in) :: y
  end
  subroutine s2(x, y)
    real, intent(out) :: x
    class(t), intent(in) :: y
  end
  subroutine test1(x)
    type(t) :: x
    real :: a
    !CHECK: CALL s1(x,1_4)
    x = 1
    !CHECK: CALL s2(a,x)
    a = x
  end
  subroutine test2(x)
    class(t) :: x
    real :: a
    !CHECK: CALL x%b1(1_4)
    x = 1
    !CHECK: CALL x%b2(a)
    a = x
  end
end

! Type-bound operator
module m2
  type :: t2
  contains
    procedure, pass(x2) :: b2 => f
    generic :: operator(+) => b2
  end type
contains
  integer pure function f(x1, x2)
    class(t2), intent(in) :: x1
    class(t2), intent(in) :: x2
  end
  subroutine test2(x, y)
    class(t2) :: x
    type(t2) :: y
    !CHECK: i=f(x,y)
    i = x + y
    !CHECK: i=x%b2(y)
    i = y + x
  end
end module

! Non-type-bound assignment and operator
module m3
  type t
  end type
  interface assignment(=)
    subroutine s1(x, y)
      import
      class(t), intent(out) :: x
      integer, intent(in) :: y
    end
  end interface
  interface operator(+)
    integer function f(x, y)
      import
      class(t), intent(in) :: x, y
    end
  end interface
contains
  subroutine test(x, y)
    class(t) :: x, y
    !CHECK: CALL s1(x,2_4)
    x = 2
    !CHECK: i=f(x,y)
    i = x + y
  end
end


PROGRAM WENO5_Weakscaling

USE Advection, only : GetRHSAdvection, InitializeAdvection, FinalizeAdvection
USE OMP_LIB

IMPLICIT NONE

INCLUDE 'mpif.h'

INTEGER, PARAMETER :: Nthreads = 8, Nx_factor = 10, Nx_base = 20

DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:,:,:,:) :: Q, RQ
DOUBLE PRECISION                                  :: dx, dy, dz, T0, T1, runtime, runtime_max
INTEGER                                           :: r, ierr, mpi_thread_provided

INTEGER :: Nx, Ny, Nz, i_end, j_end, i_start, j_start, k_start, k_end, order, ntasks, myrank

CALL MPI_INIT_THREAD(MPI_THREAD_FUNNELED, mpi_thread_provided, ierr)
CALL MPI_COMM_SIZE(MPI_COMM_WORLD, ntasks, ierr)
CALL MPI_COMM_RANK(MPI_COMM_WORLD, myrank, ierr)

i_start = 1
j_start = 1
k_start = 1

order=5

DO r=Nx_factor,Nx_factor

    Nx = r*Nx_base
    Ny = r*Nx_base
    Nz = r*Nx_base
    dx = 1.0/Nx
    dy = 1.0/Ny
    dz = 1.0/Nz

    i_end = i_start+Nx-1
    j_end = j_start+Ny-1
    k_end = k_start+Nz-1

    ALLOCATE(Q( j_start-3:j_end+3,   i_start-3:i_end+3,  k_start-3:k_end+3, 0:0))
    ALLOCATE(RQ(j_start-3:j_end+3,   i_start-3:i_end+3,  k_start-3:k_end+3, 0:0))

    CALL InitializeAdvection(i_start-3, i_end+3, j_start-3, j_end+3, k_start-3, k_end+3, 1, .true.)

    T0 = MPI_WTIME()
    CALL GetRHSAdvection(Q(:,:,:,0), RQ(:,:,:,0), dx, dy, dz, i_start, i_end, j_start, j_end, k_start, k_end, order)
    T1 = MPI_WTIME()

    runtime = T1-T0

    DEALLOCATE(Q)
    DEALLOCATE(RQ)
    CALL FinalizeAdvection()

END DO

CALL MPI_REDUCE(runtime, runtime_max, 1, MPI_DOUBLE_PRECISION, MPI_MAX, 0, MPI_COMM_WORLD)

IF (myrank==0) THEN
    WRITE(*,'(A, F5.3)') 'Runtime in seconds: ', runtime_max
END IF
CALL MPI_FINALIZE(ierr)

END PROGRAM WENO5_Weakscaling