text:
************************************************************************
*                          VARCAL.FOR                                  *
*                                                                      *
*  PROGRAM: SIMRAND I                                                  *
*  MODULE:  1.5.3.3                                                    *
*  DATE:    01/29/85                                                   *
*                                                                      *
*  THIS IS THE SUBROUTINE VARCAL.  IT CALCULATES THE RANDOM VARIABLE   *
*  MATRIX FOR TASK VARIABLES FROM THE RANDOM NUMBER MATRIX USING THE   *
*  CDF COEFFICIENTS GENERATED BY THE SUBROUTINE COEFF.                 *
*                                                                      *
*----------------------------------------------------------------------*
*                     CONFIGURATION CHANGES                            *
*                                                                      *
*    DATE                  CHANGE                                      *
*                                                                      *
*  01/18/85  * ORIGINAL.                                               *
*  01/22/85  * MODULE  8: ID LOOP CHANGED TO IC LOOP FOR CLARITY.      *
*  01/29/85  * MODULE  1: JDIAG .EQ. 2.                                *
*            * MODULE 11: JDIAG .EQ. 2.                                *
*                                                                      *
************************************************************************

$TITLE:'VARCAL.LST'
$DEBUG
$NOFLOATCALLS
$STORAGE:2

************************************************************************

      SUBROUTINE VARCAL

************************************************************************

***** INITIALIZE.  {MODULE 1}

$INCLUDE:'INITIAL.FOR'

      IF (JDIAG .EQ. 2) THEN
         WRITE  (*,100)
100      FORMAT (/1X,4X,'ENTER SUBROUTINE VARCAL')
      ENDIF

***   {END MODULE 1}

***** START (IA,IX) DO LOOPS FOR TASK VARIABLES VARMTX(IA,IX).
***** {MODULE 2}

      NIXX = NIX - 1
      DO 130 IA=1,NIA
         DO 130 IX=1,NIXX

            IDTASK = ITASK(IA,IX)
            RAN    = RANMTX(IA,IX)

*****       TEST WHETHER TASK VARIABLE USED AND MAKE TASK VARIABLE
*****       ASSIGNMENT.  {MODULE 3}

            IF (IDTASK .EQ. 0) THEN

*****          SET UNUSED TASK VARIABLE VARMTX(IA,IX) = 0.0.  {MODULE 4}

               VARMTX(IA,IX) = 0.0

***            {END MODULE 4}

*****       {CONTINUE MODULE 3}

            ELSE

*****          TASK VARIABLE VARMTX(IA,IX) USED.  TEST FOR SUCCESS OF
*****          TASK AND MAKE TASK VARIABLE ASSIGNMENT.  {MODULE 5}

               IF (RAN .GT. TDATA(IDTASK,2)) THEN

*****             TASK FAILED.  SET VARMTX(IA,IX) TO TASK FAILURE VALUE.
*****             {MODULE 6}

                  VARMTX(IA,IX) = TDATA(IDTASK,1)

***               {END MODULE 6}

*****          {CONTINUE MODULE 5}

               ELSE

*****             TASK SUCCESSFUL. CALCULATE CDF CONDITIONAL ON SUCCESS.
*****             {MODULE 7}

                  RAN1 = RAN/TDATA(IDTASK,2)

*                 ADJUST RAN1 IF > 1.0 DUE TO ROUNDOFF.

                  IF (RAN1 .GT. 1.0) RAN1 = 1.0

***               {END MODULE 7}

*****             START DO LOOP TO CALCULATE VARMTX(IA,IX) FOR
*****             SUCCESSFUL TASK.  {MODULE 8}

                  DO 110 IC=1,NIC,2

*****                FIND CORRECT TASK VARIABLE COEFFICIENTS AND
*****                CALCULATE VARMTX(IA,IX).  {MODULE 9}

                     ID = IC + 4

                     IF (RAN1 .LE. TDATA(IDTASK,ID+1)) THEN

*                       CORRECT TASK VARIABLE COEFFICIENTS.  CALCULATE
*                       VARMTX(IA,IX).

                        VARMTX(IA,IX) = TCOEF(IDTASK,IC)*RAN1 +
     *                                  TCOEF(IDTASK,IC+1)

*                       JUMP OUT OF (IC) DO LOOP FOR CALCULATING ONE
*                       SUCCESSFUL TASK VARIABLE VARMTX(IA,IX).

                        GO TO 120

                     ENDIF

***                  {END MODULE 9}

110               CONTINUE

120               CONTINUE

***               END (IC) DO LOOP TO CALCULATE VARMTX(IA,IX) FOR ONE
***               SUCCESSFUL TASK VARIABLE.  {END MODULE 8}

               ENDIF

***            END ONE TASK VARIABLE VARMTX(IA,IX) USED AND TASK
***            VARIABLE ASSIGNMENT.  {END MODULE 5}

            ENDIF

***         END TEST WHETHER ONE TASK VARIABLE USED AND ONE TASK
***         VARIABLE ASSIGNMENT.  {END MODULE 3}

130   CONTINUE

***   END (IA,IX) DO LOOPS FOR TASK VARIABLES VARMTX(IA,IX).
***   {END MODULE 2}

***** WRITE TASK VARIABLES VARMTX(IA,IX).  {MODULE 10}

      IF (JDIAG .EQ. 2) THEN

         NIXX = NIX - 1
         DO 160 IA=1,NIA

            IF (NIXX .LE. 5) THEN
               WRITE  (*,140) IA,(VARMTX(IA,IX),IX=1,NIXX)
            ELSE
               WRITE  (*,140) IA,(VARMTX(IA,IX),IX=1,5)
               WRITE  (*,150)    (VARMTX(IA,IX),IX=6,NIXX)
            ENDIF

140         FORMAT (1X,I5,3X,1P5E14.4)
150         FORMAT (1X,   8X,1P5E14.4)

160      CONTINUE

      ENDIF

***   {END MODULE 10}

***** EXIT FROM SUBROUTINE VARCAL.  {MODULE 11}

      IF (JDIAG .EQ. 2) THEN
         WRITE (*,999)
999      FORMAT (1X,4X,'EXIT  SUBROUTINE VARCAL')
      ENDIF

      RETURN

      END

***   {END MODULE 11}

***************************** VARCAL.FOR *******************************

ext: for


text:
program prog

use f

implicit none

double precision :: x

integer :: argc
type (string_array) argv

integer i
character (len=1024) tmp

print *, 'starting prog...'

! SNIPPET 1
argc = command_argument_count()
call string_array_create(argv, argc)

do i = 1, argc
   call get_command_argument(i, tmp)
   call string_array_set(argv, i, tmp)
end do
! SNIPPET END

call func(argc, argv, x)

if (argc .ne. 0) then
   print *, 'writing to: ', trim(tmp)
   open (unit=1, file=tmp)
   write (1,*) 'x = ', x
   close (1)
endif

print *, 'prog done.'
end program prog

max_stars_repo_name: timarmstrong/swift-t

max_issues_repo_name: timarmstrong/swift-t

max_forks_repo_name: timarmstrong/swift-t


text:
!> @file sparse_matrix.f90
!! @brief Sparse matrix module
!! @author Innocent Souopgui
!! @details
!! The sparse matrix module provide the sparse matrix data structure
!! and some basic operation
!!
!! For a complete sparse matrix toolbox,
!! http://people.sc.fsu.edu/~jburkardt/f_src/sparsekit/sparsekit.html
!! Most subroutines in this module are borrowed from sparsekit
!<

!> @brief Module sparse matrix data structures and some basic subroutines
!!
!<
module sparse_matrix
    use general_constant
    use debug_tools
implicit none

    !> @brief user defined type for compressed sparse row matrix
    !! Let @a A be the matrix to store
    !! The @a val vector stores the values of the nonzero elements of
    !!   the matrix @a A as they are traversed in a row-wise fashion
    !! The @a col_ind vector stores the column indexes of the elements
    !!   in the @a val vector. If @a val[k] = @a A[i,j], then col_ind[k] = j
    !! The @a row_ptr vector stores the locations in the @a val vector that
    !!   start a row. If @a val[k] = @a A[i,j],
    !!   then row_ptr[i] <= k < row_ptr[i+1].
    !!   By convention, row_ptr[nrow+1] = nnz+1, where nnz is the number
    !!   of nonzeros in the matrix @a A
    !!
    !! @details http://web.eecs.utk.edu/~dongarra/etemplates/node373.html
    !<
    type CSR_matrix
        integer :: nrow = 0 !< Number of rows of the matrix
        integer :: ncol = 0 !< Number of columns of the matrix
        integer :: nnz = 0 !< Number of nonzero elements of the matrix
        integer, dimension(:), pointer :: col_ind => null()
        integer, dimension(:), pointer :: row_ptr => null()
        real(dp), dimension(:), pointer :: val => null()
        !> \brief indicates if the structure as been initialized
        logical :: initialized      = .false.
    end type CSR_matrix

contains

    !> @brief create a CSR matrix from a full matrix and a mask
    !! @param [in] A full matrix to compress
    !! @param [in] M mask matrix indicating masked entries of @a A
    !! @param [in, out] B csr matrix
    !! @details
    !!   @a A and @a M must have the same shape
    !<
    subroutine full2csr(A, M, B)
        real(dp), dimension(:,:), intent(in) :: A
        integer, dimension(:,:), intent(in)  :: M
        type(CSR_matrix), intent(inout) :: B
        !local variables
        integer :: nrow, ncol, nnz, i, j, pos

        if( sum( abs( shape(A)-shape(M) ) )/=0 )then
            call debug(shape(A), 'Shape of the input matrix')
            call debug(shape(M), 'Shape of the input mask  ')
            call stop_program('in to_csr, input matrix and mask have different shapes')
        end if
        nrow = size(A,1)
        ncol = size(A,2)
        nnz  = count( M == UNMASKED )
        call set_csr(B, nrow, ncol, nnz)
        if(nnz>0)then
            pos = 1!position in the val vector
            do i = 1, nrow
                B%row_ptr(i) = pos
                do j = 1, ncol
                    if(M(i,j)==UNMASKED)then
                        B%val(pos) = A(i,j)
                        B%col_ind(pos) = j
                        pos = pos+1
                    end if
                end do
            end do
            B%row_ptr(nrow+1) = nnz+1
        end if
    end subroutine full2csr

    !> @brief convert a CSR matrix to a full matrix
    !! @param [in] A csr matrix to expand
    !! @param [out] B full matrix (output)
    !! @param [out] M (optional) mask matrix indicating masked entries of @a B
    !! @details
    !!   @a A and @a M must have the same shape that corresponds
    !!   to the shape of the CSR matrix
    !<
    subroutine csr2full(A,B,M)
        type(CSR_matrix), intent(inout) :: A
        real(dp), dimension(:,:), intent(in out) :: B
        integer, dimension(:,:), optional, intent(in out)  :: M

        !local variables
        integer :: nrow, ncol, nnz, i, j, k

        nrow = A%nrow
        ncol = A%ncol
        if( sum( abs( shape(B)-[nrow,ncol] ) )/=0 )then
            call debug([A%nrow,A%ncol], 'Shape of the CSR matrix')
            call debug(shape(B), 'Shape of the full matrix  ')
            call stop_program('In to_csr, shapes of matrices differ')
        end if

        if( present(M) )then
            if( sum( abs( shape(M)-[nrow,ncol] ) )/=0 )then
                call debug([A%nrow,A%ncol], 'Shape of the CSR matrix')
                call debug(shape(M), 'Shape of the mask matrix  ')
                call stop_program('In to_csr, shapes of matrices differ')
            end if

            M = MASKED !suppose all masked
            do i = 1, A%nrow
                do k = A%row_ptr(i), A%row_ptr(i+1)-1
                    M(i, A%col_ind(k) ) = UNMASKED
                end do
            end do
        end if

        B = 0.0_dp
        do i = 1, A%nrow
            do k = A%row_ptr(i), A%row_ptr(i+1)-1
                B(i, A%col_ind(k) ) = A%val(k)
            end do
        end do
    end subroutine csr2full

    !> @brief create a CSR matrix from a full matrix and a mask
    !! @param [in, out] A sparse matrix data structure
    !! @param [in] nrow number of row of the matrix
    !! @param [in] ncol number of column of the matrix
    !! @param [in] nnz number of nonzero entry of the matrix
    !<
    subroutine new_csr(A, nrow, ncol, nnz)
        type(CSR_matrix), intent(inout) :: A
        integer, intent(in)             :: nrow, ncol, nnz

        call set_csr(A, nrow, ncol, nnz)
    end subroutine new_csr

    !> @brief Allocates state dynamic space for the csr matrix
    !! @param [in, out] A sparse matrix data structure
    !! @param [in] nrow number of row of the matrix
    !! @param [in] ncol number of column of the matrix
    !! @param [in] nnz number of nonzero entry of the matrix
    !! @details
    !! This routine is used to allocate space compressed sparse matrices.
    !<
    subroutine set_csr(A, nrow, ncol, nnz)
        type(CSR_matrix), intent(inout) :: A
        integer, intent(in)             :: nrow, ncol, nnz
        !local variables
        logical :: ll_allocate, ll_reset

        ll_allocate = .false.
        ll_reset = .false.

        if( (nnz/=0).and.( (nrow==0).or.(ncol==0) ) )then
            call debug( (/nrow, ncol, nnz/), "nrow ncol, nnz =", tag=dALLWAYS )
            call stop_program("In set_csr: if nnz is nonzero, nrow and ncol must all be nonzero")
        end if

        if( (nrow==0).eqv.(ncol==0) )then !all zero or nonzero
            if( (nrow==0).and.(ncol==0) )then ! all zero
                ll_reset = .true.
            else !both nonzero
                if(A%initialized)then
                    !if current size different from required size
                    if( (A%nrow /= nrow).or.(A%ncol /= ncol).or.(A%nnz /= nnz) )then
                        ll_reset = .true.
                        ll_allocate = .true.
                    end if
                else !not initialized
                    ll_allocate = .true.
                end if
            end if
        else
            call debug( (/nrow, ncol/), "nrow ncol =", tag=dALLWAYS )
            call stop_program("In set_csr: nrow ncol should all be zero or nonzero")
        end if

        if(ll_reset)call reset_csr(A) !free space if necessary

        if( ll_allocate )then
            A%nrow = nrow
            A%ncol = ncol
            A%nnz  = nnz
            allocate( A%val(A%nnz), A%col_ind(A%nnz), A%row_ptr(A%nrow+1))
        end if

        if( nnz>0 )then !all nonzero
            A%val = 0.0_cp
            A%col_ind = 0
            A%row_ptr = A%nnz+1
            A%initialized = .true.
        end if

        !call debug_state( td_state, tag=dALLWAYS )
    end subroutine set_csr

    !> @brief Reset crs data structure, free dynamically allocated memory
    !! @param [in, out] A sparse matrix data structure
    !<
    subroutine reset_csr(A)
        type(CSR_matrix), intent(inout) :: A

        if(A%initialized) then
            deallocate( A%val, A%col_ind, A%row_ptr )
        end if
        nullify(A%val, A%col_ind, A%row_ptr)

        A%nrow = 0
        A%ncol = 0
        A%nnz  = 0

        A%initialized = .false.
    end subroutine reset_csr

    !> @brief transpose a CSR matrix
    !! @param [in] A sparse matrix data structure to transpose
    !! @param [in] B sparse matrix data structure for the transposed matrix
    !! @details
    !!   this is not an in-place operation.
    !!   Developper notes
    !!   this subroutine exploits some properties of operations on CSR
    !!   matrix to limit the number of variables. For example, the row_ptr
    !!   of the transposed matrix is used for three different purposes:
    !!     - count the number of nonzero of each row of the transposed
    !!     - mark the position in the data array of the next avaible position
    !!        for each row of the transpose
    !!     - its actual role of row_ptr
    !! Something to keep in mind (reason why I implemented this function):
    !! in fortran (pgf90 14.6) the code
    !! y = matmul( transpose(A), x)
    !! and the code
    !! B = transpose(A); y = matmul(B,x)
    !! do not produce the same results.
    !<
    subroutine csr_transpose(A, B)
        type(CSR_matrix), intent(in) :: A
        type(CSR_matrix), intent(inout) :: B
        !local variables
        integer :: i, j, k, q, l

        call new_csr(B, A%ncol, A%nrow, A%nnz)

        ! Step 1
        ! counting the number of nonzeros in each row of the transpose
        B%row_ptr(1:B%nrow) = 0
        do i = 1, A%nrow
            do k = A%row_ptr(i), A%row_ptr(i+1)-1
                j = A%col_ind(k)
                B%row_ptr(j) = B%row_ptr(j) + 1
            end do
        end do
        ! At this point, it is mandatory that sum (B%row_ptr(1:B%nrow))=B%nnz
        if( sum(B%row_ptr(1:B%nrow))/=B%nnz )call stop_program("In csr_transpose, step 1 went wrong")

        ! Step 2
        ! Compute the location in the data vector of the first element
        ! of each row of the transpose
        do i = B%nrow, 1, -1
            B%row_ptr(i) = B%row_ptr(i+1) - B%row_ptr(i)
        end do
        ! At this point, it is mandatory that B%row_ptr(1)=1
        if(B%row_ptr(1)/=1)call stop_program("In csr_transpose, step 2 went wrong")

        ! Step 3
        ! Actual copy
        do i = 1,A%nrow
            do k = A%row_ptr(i), A%row_ptr(i+1)-1
                q = A%col_ind(k)
                l = B%row_ptr(q) ! next index for the q row
                B%col_ind(l) = i ! colums of B are rows of A
                B%val(l) = A%val(k)
                B%row_ptr(q) = B%row_ptr(q) + 1
            end do
        end do
        ! At this point B%row_ptr contains pointer to the begining of the next row

        ! Step 4, re-shift B%row_ptr to actual row pointers
        do i = B%nrow, 1, -1
            B%row_ptr(i+1) = B%row_ptr(i)
        end do
        B%row_ptr(1)=1
        ! At this point, it is mandatory that B%row_ptr(B%nrow+1)=B%nnz+1
        if(B%row_ptr(B%nrow+1)/=B%nnz+1)call stop_program("In csr_transpose, step 4 went wrong")
    end subroutine csr_transpose

    !> @brief multiply a CSR matrix A by a vector.
    !! @param[in] A matrix under the CSR form
    !! @param[in] x input vector, must be of size A%ncol
    !! @param[out] y outut vector, must be of size A%nrow
    !! @param[in] trans logical transpose flag
    !! @details
    !!   There is no check of the dimensions
    !!   if trans flag is present and set to .true. then
    !!   y = A^t x, the transpose is used
    !!   otherwise
    !!   y = Ax
    !<
    subroutine CSR_matvec(A, x, y, trans)
        type(CSR_matrix), intent(in) :: A
        real(dp), dimension(:), intent(in) :: x
        real(dp), dimension(:), intent(in out) :: y
        logical, optional :: trans
        !local variables
        integer :: i, k
        real(dp) :: t
        logical :: ll_trans

        if( present(trans) )then
            ll_trans = trans
        else
            ll_trans = .false.
        end if

        if(ll_trans) then
            !apply the transposed matrix
            y = 0.0_dp
            do i = 1, A%nrow
                do k = A%row_ptr(i), A%row_ptr(i+1)-1
                    y( A%col_ind(k) ) = y( A%col_ind(k) ) + x( i )*A%val(k)
                end do
            end do
        else
            do i = 1, A%nrow
                !
                !  Compute the inner product of row i with vector X.
                !
                t = 0.0_dp
                do k = A%row_ptr(i), A%row_ptr(i+1)-1
                    t = t + A%val(k) * x( A%col_ind(k) )
                end do
                y(i) = t

            end do
        end if
    end subroutine CSR_matvec

end module sparse_matrix

max_stars_repo_name: souopgui/da-toolbox

max_issues_repo_name: souopgui/da-toolbox

max_forks_repo_name: souopgui/da-toolbox


text:
! { dg-do compile }

        SUBROUTINE A25
        INTEGER OMP_GET_THREAD_NUM
        REAL A(20)
        INTEGER MYTHREAD
        !$OMP PARALLEL SHARED(A) PRIVATE(MYTHREAD)
        MYTHREAD = OMP_GET_THREAD_NUM()
        IF (MYTHREAD .EQ. 0) THEN
            CALL SUB(A(1:10)) ! compiler may introduce writes to A(6:10)
        ELSE
            A(6:10) = 12
        ENDIF
        !$OMP END PARALLEL
        END SUBROUTINE A25
        SUBROUTINE SUB(X)
        REAL X(*)
        X(1:5) = 4
        END SUBROUTINE SUB

max_issues_repo_name: sujankh/rose-matlab

max_forks_repo_name: sujankh/rose-matlab


text:
c***********************************************************************
      subroutine qss3dRK1Step(
     &  u_next,
     &  ilo_u_next_gb, ihi_u_next_gb,
     &  jlo_u_next_gb, jhi_u_next_gb,
     &  klo_u_next_gb, khi_u_next_gb,
     &  u_cur,
     &  ilo_u_cur_gb, ihi_u_cur_gb,
     &  jlo_u_cur_gb, jhi_u_cur_gb,
     &  klo_u_cur_gb, khi_u_cur_gb,
     &  rhs,
     &  ilo_rhs_gb, ihi_rhs_gb,
     &  jlo_rhs_gb, jhi_rhs_gb,
     &  klo_rhs_gb, khi_rhs_gb,
     &  ilo_fb, ihi_fb, jlo_fb, jhi_fb, klo_fb, khi_fb,
     &  dt)
c***********************************************************************
c { begin subroutine
      implicit none

      integer ilo_u_next_gb, ihi_u_next_gb
      integer jlo_u_next_gb, jhi_u_next_gb
      integer klo_u_next_gb, khi_u_next_gb
      integer ilo_u_cur_gb, ihi_u_cur_gb
      integer jlo_u_cur_gb, jhi_u_cur_gb
      integer klo_u_cur_gb, khi_u_cur_gb
      integer ilo_rhs_gb, ihi_rhs_gb
      integer jlo_rhs_gb, jhi_rhs_gb
      integer klo_rhs_gb, khi_rhs_gb
      integer ilo_fb, ihi_fb, jlo_fb, jhi_fb, klo_fb, khi_fb
      real u_next(ilo_u_next_gb:ihi_u_next_gb,
     &                        jlo_u_next_gb:jhi_u_next_gb,
     &                        klo_u_next_gb:khi_u_next_gb)
      real u_cur(ilo_u_cur_gb:ihi_u_cur_gb,
     &                       jlo_u_cur_gb:jhi_u_cur_gb,
     &                       klo_u_cur_gb:khi_u_cur_gb)
      real rhs(ilo_rhs_gb:ihi_rhs_gb,
     &                     jlo_rhs_gb:jhi_rhs_gb,
     &                     klo_rhs_gb:khi_rhs_gb)
      integer i, j, k
      real dt

c     { begin loop over grid
      do k=klo_fb,khi_fb
        do j=jlo_fb,jhi_fb
          do i=ilo_fb,ihi_fb

            u_next(i,j,k) = u_cur(i,j,k) + dt*rhs(i,j,k)

          enddo
        enddo
      enddo
c     } end loop over grid

      return
      end
c } end subroutine
c***********************************************************************

ext: f


! { dg-do run }
! Tests the fix for PR36433 in which a check for the array size
! or character length of the actual arguments of foo and bar
! would reject this legal code.
!
! Contributed by Paul Thomas <pault@gcc.gnu.org>
!
module m
contains
  function proc4 (arg, chr)
    integer, dimension(10) :: proc4
    integer, intent(in) :: arg
    character(8), intent(inout) :: chr
    proc4 = arg
    chr = "proc4"
  end function
  function chr_proc ()
    character(8) :: chr_proc
    chr_proc = "chr_proc"
  end function
end module

program procPtrTest
  use m
  character(8) :: chr
  interface
    function proc_ext (arg, chr)
      integer, dimension(10) :: proc_ext
      integer, intent(in) :: arg
      character(8), intent(inout) :: chr
    end function
  end interface
! Check the passing of a module function
  call foo (proc4, chr)
  if (trim (chr) .ne. "proc4") call abort
! Check the passing of an external function
  call foo (proc_ext, chr)
! Check the passing of a character function
  if (trim (chr) .ne. "proc_ext") call abort
  call bar (chr_proc)
contains
  subroutine foo (p, chr)
    character(8), intent(inout) :: chr
    integer :: i(10)
    interface
      function p (arg, chr)
        integer, dimension(10) :: p
        integer, intent(in) :: arg
        character(8), intent(inout) :: chr
      end function
    end interface
    i = p (99, chr)
    if (any(i .ne. 99)) call abort
  end subroutine
  subroutine bar (p)
    interface
      function p ()
        character(8):: p
      end function
    end interface
    if (p () .ne. "chr_proc") call abort
  end subroutine
end program

function proc_ext (arg, chr)
  integer, dimension(10) :: proc_ext
  integer, intent(in) :: arg
  character(8), intent(inout) :: chr
  proc_ext = arg
  chr = "proc_ext"
end function


text:
C    %W% %G%
      subroutine rcinp
C * * *
C * * * THIS SUBROUTINE DECODES THE RC RESISTANCE BRAKE CARD
C * * * AND FORMS INITIAL DATA TABLES.  IT IS CALLED BY INPUT1.
C * * *
      include 'tspinc/params.inc'
      include 'tspinc/pointr.inc'
      include 'tspinc/rbcom.inc'
      include 'tspinc/brakn.inc'
      include 'tspinc/prt.inc'
      include 'tspinc/reread.inc'
      character*8 bus4c,bus5c,bus6c
      character*1 iparc,id6
      character*5 finsc
C     -     begin     begin     begin     begin     begin     begin
      if (irb .eq. 0) return
 1000 read (buffer,1200) bus4c,base4,bus5c,base5,iparc,bus6c,base6,
     1  id6,consa,consb,consc,ttrip2,fdisc,fins,tmax,pbias2
 1200 format (bz,6x,a8,f4.0,1x,a8,f4.0,a1,1x,a8,f4.0,a1,4f4.2,f5.4,f5.3,
     1  f4.1,f4.0)
C * * *
C * * *  DATA CHECKING ON BRAKE RC CARD
C * * *
      if (ttrip2.le.0.0) ttrip2=0.01
      if (tmax.le.0.0) tmax=0.01
      if (consc.eq.0.0) go to 1800
      if (consa.eq.0.0) go to 2000
      if(fins.ne.0.0) go to 1600
C * * *
C * * *   IF FINS IS BLANK SET IT TO A LARGE NUMBER
C * * *
      read (buffer,1400) finsc
 1400 format (bz,62x,a5)
      if (finsc.eq.' ') fins=1.0e10
 1600 if (fins.le.fdisc) go to 2000
      go to 2400
 1800 if (consb.eq.0.0) go to 2000
      go to 2400
 2000 iabort=1
      write (errbuf(1),2200) bus6c,base6,id6
      call prterr ('E',1)
 2200 format (1h0,'  CHECK RC CARD AT ',a8,2x,f5.1,2x,a1,'--M, T2 ',
     1        'MUST BE POSITIVE AND FDISC LESS THAN FINS')
 2400 kb4=nambas(base4)
      kb5=nambas(base5)
      kb6=nambas(base6)
      ibus2=inam(bus4c,kb4)
      jbus2=inam(bus5c,kb5)
      ibusb=inam(bus6c,kb6)
      if (ibus2.eq.0.or.jbus2.eq.0.or.ibusb.eq.0)then
         write (errbuf(1),2600) bus6c,base6,id6
         call prterr ('E',1)
 2600    format (1h0,'RC - BUS6 ',a8,f5.1,1x,a1)
         iabort = 1
         return
      endif
      if(ibkbno(irb) .ne. ibusb .or. ibkid(irb) .ne. id6)then
         write (errbuf(1),2800)
         call prterr ('E',1)
 2800    format (1h0,'THE BUS BRAKE IDENTIFICATION ON THE PREVIOUS ',
     1          'TWO CARDS DO NOT AGREE.')
         iabort = 1
         return
      endif
      irc=irc+1
      if (iparc.eq.'0') iparc = ' '                                      !dem
      ircidc(irb)=iparc
      ircidn(1,irb)=ibus2
      ircidn(2,irb)=jbus2
      ircidn(3,irb)=irb
      ibkib2(irb) = ibus2
      ibkjb2(irb) = jbus2
      bkcona(irb) = consa
      bkconb(irb) = consb
      bkconc(irb) = consc
      bkpbi2(irb) = pbias2
      bktrg2(irb) = fdisc
      bktrp2(irb) = ttrip2
      bkfins(irb) = fins
      bktblk(irb) = tmax
      ibrkc(irb) = 1
      return
      end

max_stars_repo_name: mbheinen/bpa-ipf-tsp

max_issues_repo_name: cuihantao/bpa-ipf-tsp

max_forks_repo_name: mbheinen/bpa-ipf-tsp


text:
      subroutine stop_pause
      logical l1, l2, l3, l4
      x = rand()
      if(x.gt.0.) then
         x=x+5.
         stop "finished"
      elseif(x.lt.-1.) then
         x=x+7.
         stop 3
      elseif(x.ne.-2.) then
         stop
      elseif(x.ge.-3.) then
         pause 10
      elseif(x.le.-4.) then
         pause
      elseif(x.eq.-5.) then
         continue
      elseif(.NOT. l1) then
         x = rand()
      elseif(l2.or.l3) then
 1       continue
      elseif(l3.and.l4) then
         x=x+1.
      endif

      end


text:
!!***************************************************************************************************************************
!! This module is intended to calculate behavior of the plant leaf
!! 10/11/2017 converted from UTF-8 to ANSI
!! Atributes:
!!
!! Object functions:
!!
!! Static functions:
!!
!! Authors
!! @danipilze
!!*********
!
    Module YCA_Control_Leaf

     USE YCA_First_Trans_m
     USE YCA_Node

    contains

    ! true is leaf is active
    logical function isLeafExpanding(node)
        implicit none
        class (Node_type), intent(in) :: node

        isLeafExpanding = node%LAGETT <= LLIFGTT
    end function isLeafExpanding

    ! true is leaf is active
    logical function isLeafActive(node)
        implicit none
        class (Node_type), intent(in) :: node

        isLeafActive = node%LAGETT >= LLIFGTT .AND. node%LAGETT < LLIFGTT+LLIFATT
    end function isLeafActive

    ! true is leaf is senescing
    logical function isLeafSenescing(node)
        implicit none
        class (Node_type), intent(in) :: node

        isLeafSenescing = node%LAGETT >= LLIFGTT+LLIFATT .AND. node%LAGETT < LLIFGTT+LLIFATT+LLIFSTT
    end function isLeafSenescing

    ! true is leaf is alive
    logical function isLeafAlive(node)
        implicit none
        class (Node_type), intent(in) :: node

        isLeafAlive = node%LAGETT < LLIFGTT+LLIFATT+LLIFSTT
    end function isLeafAlive

    ! true is leaf was active today
    logical function didLeafStartActiveToday(node)
        implicit none
        class (Node_type), intent(in) :: node

        didLeafStartActiveToday = node%LAGETT-dailyGrowth()  < LLIFGTT .AND. isLeafActive(node)
    end function didLeafStartActiveToday

    ! true is leaf started senescing today
    logical function didLeafStartSenescingToday(node)
        implicit none
        class (Node_type), intent(in) :: node

        didLeafStartSenescingToday = node%LAGETT-dailyGrowth()  < LLIFGTT+LLIFATT .AND. isLeafSenescing(node)
    end function didLeafStartSenescingToday

    ! true is leaf will start senescing today
    logical function willLeafStillGrowingToday(node)
        implicit none
        class (Node_type), intent(in) :: node

        willLeafStillGrowingToday =  node%LAGETT+dailyGrowth()  <= LLIFGTT+LLIFATT                                                      !EQN 371
    end function willLeafStillGrowingToday

    ! true is leaf fell today
    logical function didLeafFallToday(node)
        implicit none
        class (Node_type), intent(in) :: node

        didLeafFallToday = node%LAGETT-dailyGrowth()  < LLIFGTT+LLIFATT+LLIFSTT .AND. .NOT. isLeafAlive(node)
    end function didLeafFallToday

    ! real value of the leaf area left to senesce
    real function leafAreaLeftToSenesce(node)
        implicit none
        class (Node_type), intent(in) :: node

        leafAreaLeftToSenesce = node%LATL3T - node%LAPS
    end function leafAreaLeftToSenesce

    ! real value of the plant leaf area left to senesce
    real function plantLeafAreaLeftToSenesce()
        implicit none

        plantLeafAreaLeftToSenesce = PLA-SENLA
    end function plantLeafAreaLeftToSenesce

    ! real value of the plant green leaf area
    real function plantGreenLeafArea()
        implicit none

        plantGreenLeafArea = plantLeafAreaLeftToSenesce()-LAPHC
    end function plantGreenLeafArea

    ! set leaf age to active
    subroutine setLeafAsActive(node)
        implicit none
        class (Node_type), intent(inout) :: node

        node%LAGETT = LLIFGTT
    end subroutine setLeafAsActive

    ! set leaf age to senescing
    subroutine setLeafAsSenescing(node)
        implicit none
        class (Node_type), intent(inout) :: node

        node%LAGETT = LLIFGTT+LLIFATT                                             !EQN 359
    end subroutine setLeafAsSenescing

    ! set leaf age to fall
    subroutine setLeafAsFall(node)
        implicit none
        class (Node_type), intent(inout) :: node

        node%LAGETT = LLIFGTT+LLIFATT+LLIFSTT
    end subroutine setLeafAsFall

    ! increase leaf age
    subroutine leafAge(node)
        implicit none
        class (Node_type), intent(inout) :: node

        node%LAGETT = node%LAGETT + dailyGrowth()                                              !EQN 358
    end subroutine leafAge

    ! real value of the daily growth
    real function dailyGrowth()
        implicit none

        dailyGrowth = TTLFLife*EMRGFR
    end function dailyGrowth

    ! real value of leaf total senesced weight
    real function leafTotalSenescedWeight()
        implicit none

        leafTotalSenescedWeight = SENLFG + SENLFGRS
    end function leafTotalSenescedWeight

    END module YCA_Control_Leaf

max_stars_repo_name: vstocca/dssat-csm-os

max_issues_repo_name: vstocca/dssat-csm-os

max_forks_repo_name: vstocca/dssat-csm-os


text:
! fortran api for reading and writing grib2
! 12/2015  Wesley Ebisuzaki   Public Domain
!
! fortran 2003 / fortran 95 + TR 15581  API to read and write grib2 files
!
!   requirements:
!        f2003 or f95 + TR 15581  (allowing subroutines to deallocate and allocate)
!        callable wgrib2
!        fort_wgrib2.c (wgrib2c wrapper for callable wgrib2)
!
! Provides:
!    wgrib2a(list of strings) :: same as $ wgrib2 [list of strings]
!    wgrib2c(argc, argv) :: same as $ wgrib2 [list of strings]
!
!    grb2_mk_inv :: makes inventory file
!        grb2_mk_inv('FILE.grb', 'FILE.inv')  same as wgrib2 FILE.grb -Match_inv >FILE.inv
!        The inventory file can be a temporary file if has the name @tmp:NAME
!        The inventory file can be a memory file if has the name @mem:N  N=0..29
!
!    grb2_filter :: filters a grib file by
!        grb2_filter('IN.grb', 'OUT.grb', ...)
!
!    grb2_free_file :: releases files handles after next call to wgrib2
!        grb2_free_file('FILE.grb')
!
!    grb2_inq :: grib2 inquire
!        grb2_inq('IN.grb', 'IN.inv', ...)
!         uses memory files @mem:19  .. always
!
!    grb2_wrt :: grib2 write
!       grb2_wrt('OUT.grb', 'TEMPLATE.grb', 'ID', ...)
!       TEMPLATE.grb is a grib file that is used as a template for the new grib file
!
!       meta = (string) .. sets metadata
!	order = 'raw' .. fastest data must be in same order as template
!	order = 'we:ns'  .. data must be in we:nw order
!	order = 'we:sn'  .. data must be in we:sn order
!

module wgrib2api
use wgrib2lowapi

	real, parameter ::   grb2_UNDEFINED = 9.999e20
        integer, private :: next_mem
        private :: reserve_mem_buffer_name, all_line
contains

!       character (len=)  reserve_mem_buffer_name(buffer)
!       this function 1) reserves a memory file (@mem:XX)
!                     2) returns the name of the memory file
!                     3) returns the integer value of the memory file
!                     4)

        character (len=7) function reserve_mem_buffer_name(buffer)
            integer :: buffer
            buffer = next_mem
            if (next_mem <  5) then
                 write(*,*) 'ran of memory files in grb2_inq()'
                 write(*,*) ' use fewer options that use memory files'
                 stop 19
            endif
            if (next_mem < 9) then
                write(reserve_mem_buffer_name,'(a,i1)') '@mem:', next_mem
            else
                write(reserve_mem_buffer_name,'(a,i2)') '@mem:', next_mem
            endif
            next_mem = next_mem - 1
        end function reserve_mem_buffer_name

	logical function grb2_DEFINED_VAL(x)
	real, intent(in) :: x
	grb2_DEFINED_VAL = (x < 9.9989e20) .or. (x > 9.9991e20)
	return
	end function grb2_DEFINED_VAL

	logical function grb2_UNDEFINED_VAL(x)
	real, intent(in) :: x
	grb2_UNDEFINED_VAL = (x >= 9.9989e20) .and. (x <= 9.9991e20)
	return
	end function grb2_UNDEFINED_VAL

        integer function grb2_var_args(lines,istart,a1,a2,a3,a4,a5,a6,a7,a8,a9,a10,a11, &
          a12,a13,a14,a15,a16,a17,a18,a19,a20)

        character (len=*), optional, intent(in):: a1,a2,a3,a4,a5,a6,a7,a8,a9,a10
        character (len=*), optional, intent(in):: a11,a12,a13,a14,a15,a16,a17
        character (len=*), optional, intent(in):: a18,a19,a20
        integer, intent(in) :: istart
        character (len=300), intent(inout) :: lines(*)

        integer :: n

        n = istart

        if (.not. present(a1)) goto 100
            n=n+1
            lines(n) = a1

        if (.not. present(a2)) goto 100
            n=n+1
            lines(n) = a2

        if (.not. present(a3)) goto 100
            n=n+1
            lines(n) = a3

        if (.not. present(a4)) goto 100
            n=n+1
            lines(n) = a4

        if (.not. present(a5)) goto 100
            n=n+1
            lines(n) = a5

        if (.not. present(a6)) goto 100
            n=n+1
            lines(n) = a6

        if (.not. present(a7)) goto 100
            n=n+1
            lines(n) = a7

        if (.not. present(a8)) goto 100
            n=n+1
            lines(n) = a8

        if (.not. present(a9)) goto 100
            n=n+1
            lines(n) = a9

        if (.not. present(a10)) goto 100
            n=n+1
            lines(n) = a10

        if (.not. present(a11)) goto 100
            n=n+1
            lines(n) = a11

        if (.not. present(a12)) goto 100
            n=n+1
            lines(n) = a12

        if (.not. present(a13)) goto 100
            n=n+1
            lines(n) = a13

        if (.not. present(a14)) goto 100
            n=n+1
            lines(n) = a14

        if (.not. present(a15)) goto 100
            n=n+1
            lines(n) = a15

        if (.not. present(a16)) goto 100
            n=n+1
            lines(n) = a16

        if (.not. present(a17)) goto 100
            n=n+1
            lines(n) = a17

        if (.not. present(a18)) goto 100
            n=n+1
            lines(n) = a18

        if (.not. present(a19)) goto 100
            n=n+1
            lines(n) = a19

        if (.not. present(a20)) goto 100
            n=n+1
            lines(n) = a20

100        continue

        grb2_var_args = n
        return
        end function

        integer function add_line(lines,n,line)

        character (len=*), intent(inout):: lines(:)
        character (len=*), intent(in):: line
        integer, intent(inout) :: n

        n = n + 1
        lines(n) = line
        add_line = 0

        return
        end function add_line

        integer function wgrib2a(a1,a2,a3,a4,a5,a6,a7,a8,a9,a10,a11, &
          a12,a13,a14,a15,a16,a17,a18,a19,a20)

	use iso_c_binding
	use wgrib2lowapi
        character (len=*), optional, intent(in):: a1,a2,a3,a4,a5,a6,a7,a8,a9,a10
        character (len=*), optional, intent(in):: a11,a12,a13,a14,a15,a16,a17
        character (len=*), optional, intent(in):: a18,a19,a20

        integer n
        character (len=300) :: lines(20)

        n = grb2_var_args(lines,0,a1,a2,a3,a4,a5,a6,a7,a8,a9,a10,a11, &
          a12,a13,a14,a15,a16,a17,a18,a19,a20)

        wgrib2a = wgrib2c(n,lines,300)
        return
        end function wgrib2a

!
!        grb2_mk_inv
!        writes the match inventory to a file
!
        integer function grb2_mk_inv(grbfile, invfile)

	use wgrib2lowapi
        implicit none
        character (len=*), intent(in):: grbfile, invfile
        character (len=300) :: cmd(10)
	integer :: n, i

	n = 0
        i = add_line(cmd,n,grbfile)
        i = add_line(cmd,n,'-rewind_init')
        i = add_line(cmd,n,grbfile)
        i = add_line(cmd,n,'-inv')
        i = add_line(cmd,n,invfile)
        i = add_line(cmd,n,'-Match_inv')

	grb2_mk_inv = wgrib2c(n, cmd, len(cmd(1)))
        return
        end function grb2_mk_inv

!        integer function grb2_filter(ingrbfile, outgrbfile, a1,a2,a3,a4,a5,a6,a7,a8,a9,a10,&
!              a11,a12,a13,a14,a15,a16,a17,a18,a19,a20)
!	use wgrib2lowapi
!        implicit none
!        character (len=*), intent(in):: ingrbfile, outgrbfile
!        character (len=*), optional, intent(in):: a1,a2,a3,a4,a5,a6,a7,a8,a9,a10
!        character (len=*), optional, intent(in):: a11,a12,a13,a14,a15,a16,a17
!        character (len=*), optional, intent(in):: a18,a19,a20
!
!        character (len=300) :: lines(20), cmd(80)
!	integer :: n, m, i, j
!
!        m = grb2_var_args(lines,0,a1,a2,a3,a4,a5,a6,a7,a8,a9,a10,a11, &
!          a12,a13,a14,a15,a16,a17,a18,a19,a20)
!
!	n = 0
!        i = add_line(cmd,n,ingrbfile)
!        i = add_line(cmd,n,'-rewind_init')
!        i = add_line(cmd,n,ingrbfile)
!        i = add_line(cmd,n,'-transient')
!        i = add_line(cmd,n,ingrbfile)
!        i = add_line(cmd,n,'-grib')
!        i = add_line(cmd,n,outgrbfile)
!        i = add_line(cmd,n,'-inv')
!!       ** this is linux/unix
!        i = add_line(cmd,n,'/dev/null')
!       ** this is for windows
!       i = add_line(cmd,n,'NUL')
!
!        do j = 1, m
!            i = add_line(cmd,n,'-match')
!            i = add_line(cmd,n,lines(j))
!        enddo
!
!        do i = 1, n
!           write(*,*) 'grb2_filter>>> i=',i,trim(cmd(i))
!        enddo
!
!        grb2_filter = wgrib2c(n,cmd, len(cmd(1)))
!
!        return
!        end function grb2_filter
!
!       grb2_free_file(name)
!       frees file from wgrib2's list of open files

        integer function grb2_free_file(file)

	use wgrib2lowapi
        implicit none
        character (len=*), intent(in) :: file
        character (len=len_trim(file)+1,kind=C_CHAR) :: cfile
!	convert from fortran string to C string
        cfile = trim(file) // C_NULL_CHAR
	grb2_free_file = wgrib2_free_file(cfile)
	return
        end function grb2_free_file

!
!        grb2_wrt: grib2 wrt
!               write grib message
!
        integer function grb2_wrt(grbfile, template_file,  template_id, &
            data1, data2, packing, order, var, meta, append, level, date, timing, &
	    fhour, fminute, fhour_ave1, fhour_ave2, fhour_acc1, fhour_acc2, &
	    center, subcenter, mb, debug, encode_bits)

	use iso_c_binding
	use wgrib2lowapi
        implicit none

        character (len=*), intent(in):: grbfile, template_file

        real, optional, intent(in) :: data1(:)
        real, optional, allocatable, intent(in) :: data2(:,:)
	integer, intent(in) :: template_id

        character (len=*), optional, intent(in):: var, meta, level, packing, order, timing
        integer (kind=8), optional, intent(in) :: date
        integer, optional, intent(in) :: fhour, fminute, fhour_ave1, fhour_ave2
        integer, optional, intent(in) :: fhour_acc1, fhour_acc2
        integer, optional, intent(in) :: center, subcenter, append, debug, encode_bits

        real, optional, intent(in) :: mb

        character (len=300) :: cmd(80)
        character (len=10) :: pack
        integer :: i,n, yrev
        logical :: present_data1, present_data2

	integer (C_INT) :: ierr
	integer (C_SIZE_T) :: ndata, nx, ny
	real (C_FLOAT), allocatable :: wgrib2_data(:)

!        write(*,*) '>> grb2_wrt'
        present_data1 = present(data1)
        present_data2 = present(data2)

        if (present_data1 .and. present_data2) then
            write(*,*) '*** FATAL ERROR grb2_wrt:  must specify data1 or data2 but not both'
            stop 8
        endif
        if (.not.present_data1 .and. .not.present_data2) then
            write(*,*) '*** FATAL ERROR grb2_wrt:  neither data1 nor data2 specified'
            stop 8
        endif

	if (present_data1) then
	    ndata = size(data1,1,C_SIZE_T)
	    ierr = wgrib2_set_reg(data1, ndata, 9)
	endif

	if (present_data2) then
	    nx = size(data2,1,C_SIZE_T)
	    ny = size(data2,2,C_SIZE_T)
	    ndata = nx*ny
	    ierr = wgrib2_set_reg(data2, ndata, 9)
	endif

        n = 0

        i = add_line(cmd,n,template_file)
        i = add_line(cmd,n,'-rewind_init')
        i = add_line(cmd,n,template_file)

	if (present(order)) then
	    if (order .eq. 'raw') then
                i = add_line(cmd,n,'-order')
                i = add_line(cmd,n,'raw')
	    else if (order .eq. 'we:ns' .or. order .eq. 'ns') then
                i = add_line(cmd,n,'-order')
                i = add_line(cmd,n,'we:ns')
	    else
		write(*,*) 'FATAL ERROR grb2_wrt: unknown order=',order
		stop 9
	    endif
	endif

        i = add_line(cmd,n,'-d')
	n = n + 1
	write(cmd(n), '(i6.6)') template_id

        i = add_line(cmd,n,'-rpn_rcl')
        i = add_line(cmd,n,'9')

	if (present(meta)) then
            i = add_line(cmd,n,'-set_metadata_str')
            n = n + 1
            cmd(n) = '0:0:' // meta
	endif

        pack='c2'
        if (present(packing)) then
            pack=packing
        endif
        i = add_line(cmd,n,'-set_grib_type')
        i = add_line(cmd,n,pack)

	if (present(date)) then
            i = add_line(cmd,n,'-set_date')
            n = n + 1
	    write(cmd(n),'(i14.10)') date
	endif

	if (present(var)) then
            i = add_line(cmd,n,'-set_var')
            n = n + 1
            cmd(n) = var
	endif

	if (present(level)) then
            i = add_line(cmd,n,'-set_lev')
            n = n + 1
            cmd(n) = level
	endif

	if (present(timing)) then
            i = add_line(cmd,n,'-set_ftime2')
            n = n + 1
            cmd(n) = timing
	endif

	if (present(mb)) then
            i = add_line(cmd,n,'-set_lev')
            n = n + 1
	    write(cmd(n),*) mb, 'mb'
	endif

	if (present(fhour)) then
            i = add_line(cmd,n,'-set_ftime')
            n = n + 1
	    write(cmd(n),*) fhour, 'hour fcst'
	endif

	if (present(fminute)) then
            i = add_line(cmd,n,'-set_ftime')
            n = n + 1
	    write(cmd(n),*) fminute, 'min fcst'
	endif

	if (present(fhour_ave1).and.present(fhour_ave2)) then
            i = add_line(cmd,n,'-set_ave')
            n = n + 1
	    write(cmd(n),'(i5,a1,i5,a)')  fhour_ave1, '-', fhour_ave2, ' hour ave fcst'
	endif

	if (present(fhour_acc1).and.present(fhour_acc2)) then
            i = add_line(cmd,n,'-set_ave')
            n = n + 1
	    write(cmd(n),'(i5,a1,i5,a)')  fhour_acc1, '-', fhour_acc2, ' hour ave fcst'
	endif

	if (present(center)) then
            i = add_line(cmd,n,'-set')
            i = add_line(cmd,n,'center')
            n = n + 1
	    write(cmd(n),*) center
	endif

	if (present(subcenter)) then
            i = add_line(cmd,n,'-set')
            i = add_line(cmd,n,'subcenter')
            n = n + 1
	    write(cmd(n),*) subcenter
	endif

	if (present(append)) then
           if (append.ne.0) then
               i = add_line(cmd,n,'-append')
           endif
        endif

!       encode_bits needs to be before -grib_out
        if (present(encode_bits)) then
            if (encode_bits .le. 0) then
                write(*,*) 'encode_bits is .le. 0 .. nothing done'
            else
                if (encode_bits.gt.16) then
                    i = add_line(cmd,n,'-set_grib_max_bits')
                    n = n + 1
                    write(cmd(n),*) min(encode_bits,25)
                endif
                i = add_line(cmd,n,'-set_bin_prec')
                n = n + 1
                write(cmd(n),*) min(encode_bits,25)
            endif
        endif

        i = add_line(cmd,n,'-grib_out')
        i = add_line(cmd,n,grbfile)

!	output from grb2_wrt
        if (present(debug)) then
            i = add_line(cmd,n,'-S')
	else
            i = add_line(cmd,n,'-inv')
            i = add_line(cmd,n,'/dev/null')
	endif

        if (present(debug)) then
            do i = 1, n
                write(*,*) 'grb2_wrt>>> i=',i,trim(cmd(i))
            enddo
        endif

!        write(*,*) '>>> grb2_wrt >> wgrib2c'
        grb2_wrt = wgrib2c(n,cmd, len(cmd(1)))
        if (grb2_wrt .ne. 0) then
             write(*,*) 'ERROR: grb2_wrt err=', grb2_wrt, ' file=',trim(grbfile)
	endif
!        write(*,*) '<<< grb2_wrt << wgrib2c'

        return
        end function

!
!        grb2_inq: grib2 inquire
!               give match strings
!               return number of matches
!               use optional arguments to get more info including grid data
!
!
!        use RPN register MAX    grid
!        use RPN register MAX-1  lat
!        use RPN register MAX-2  lon
!
        integer function grb2_inq(grbfile, invfile, &
            a1,a2,a3,a4,a5,a6,a7,a8,a9,a10,a11, &
            a12,a13,a14,a15,a16,a17,a18,a19,a20, &
            npts,nx,ny,nmatch,msgno,submsg,data1,nread,data2,lat,lon,ref_date,ref_edate, &
            verf_date, verf_edate,start_date,start_edate,end_date,end_edate,order,lastuse,close,&
            desc,grid_desc,debug,copy,sequential,regex,get_ref_edate, get_start_edate, &
            get_end_edate)

	use wgrib2lowapi
        implicit none

        character (len=*), intent(in):: grbfile, invfile
        character (len=*), optional, intent(in):: a1,a2,a3,a4,a5,a6,a7,a8,a9,a10
        character (len=*), optional, intent(in):: a11,a12,a13,a14,a15,a16,a17
        character (len=*), optional, intent(in):: a18,a19,a20
        character (len=*), optional, intent(in):: copy

	integer, optional, intent(in) :: lastuse
        integer, optional, intent(in) :: debug, sequential, regex
        integer, optional, intent(out) :: npts, nx, ny, nmatch, nread, msgno
        integer, optional, intent(out) :: submsg
        integer (kind=8), optional, intent(in) :: ref_date, ref_edate
        integer (kind=8), optional, intent(in) :: verf_date, verf_edate
        integer (kind=8), optional, intent(in) :: start_date, start_edate
        integer (kind=8), optional, intent(in) :: end_date, end_edate
        integer (kind=8), optional, intent(out) :: get_ref_edate, get_start_edate, get_end_edate
	integer (C_SIZE_T) :: buffer_size
        real, optional, intent(out) :: data1(:)
        real, optional, allocatable, intent(inout) :: data2(:,:), lat(:,:), lon(:,:)
        character (len=*), optional, intent(in):: order, close
        character (len=*), optional, intent(out):: desc, grid_desc
        integer, parameter :: string_size = 300

        character (len=string_size) :: lines(20), cmd(80), tmpline
        character (len=71) :: grid_id
        character (len=6) :: grep

        integer i, j, m, n, ierr, desc_file, grid_desc_file, grid_info_file
        integer get_ref_edate_file, get_start_edate_file, get_end_edate_file

	logical rewind_inv
        integer isubmsg
	integer (C_SIZE_T) :: ndata, nnx, nny, imsgno, one, iret

        m = grb2_var_args(lines,0,a1,a2,a3,a4,a5,a6,a7,a8,a9,a10,a11, &
          a12,a13,a14,a15,a16,a17,a18,a19,a20)

        one = 1
        n = 0
        grb2_inq = 0
        next_mem = 29				! next free mem file, work downwards
	rewind_inv = .true.
        grep = '-fgrep'

        if (present(regex)) then
            if (regex.ne.0) grep = '-egrep'
        endif

	if (present(sequential)) then
	    if (sequential.ne.0) rewind_inv = .false.
	endif
!
        i = add_line(cmd,n,grbfile)
        i = add_line(cmd,n,'-i_file')
        i = add_line(cmd,n,invfile)
	if (rewind_inv) then
            i = add_line(cmd,n,'-rewind_init')
            i = add_line(cmd,n,invfile)
	endif

        i = add_line(cmd,n,'-inv')
!       ** this is linux/unix
        i = add_line(cmd,n,'/dev/null')
!       ** this is for windows
!       i = add_line(cmd,n,'NUL')

	if (present(lastuse)) then
	    if (lastuse.ne.0) then
                i = add_line(cmd,n,'-transient')
                i = add_line(cmd,n,grbfile)
                i = add_line(cmd,n,'-transient')
                i = add_line(cmd,n,invfile)
	    endif
	endif
        if (present(close)) then
            i = add_line(cmd,n,'-transient')
            i = add_line(cmd,n,trim(close))
        endif

!	parse the match commands

        do j = 1, m
            i = add_line(cmd,n,grep)
            i = add_line(cmd,n,lines(j))
        enddo

!	ref_date: add to match command
	if (present(ref_date)) then
            i = add_line(cmd,n,'-egrep')
	    write(tmpline,9000) ref_date
9000	    format(':d=',i10.10)
	    i = add_line(cmd,n,tmpline)
	endif

!	ref_edate: add to match command
	if (present(ref_edate)) then
            i = add_line(cmd,n,'-egrep')
	    write(tmpline,9010) ref_edate
9010	    format(':D=',i14.14)
	    i = add_line(cmd,n,tmpline)
	endif

!	verf_date: add to match command
	if (present(verf_date).or.present(start_date)) then
            i = add_line(cmd,n,'-egrep')
	    write(tmpline,9020) verf_date
9020	    format(':end_FT=',i10.10)
	    i = add_line(cmd,n,tmpline)
	endif

!	verf_edate: add to match command
	if (present(verf_edate).or.present(start_edate)) then
            i = add_line(cmd,n,'-egrep')
	    write(tmpline,9030) verf_date
9030	    format(':end_FT=',i14.14)
	    i = add_line(cmd,n,tmpline)
	endif

!	start_date: add to match command
	if (present(start_date)) then
            i = add_line(cmd,n,'-egrep')
	    write(tmpline,9040) verf_date
9040	    format(':start_FT=',i10.10)
	    i = add_line(cmd,n,tmpline)
	endif

!	start_edate: add to match command
	if (present(start_edate)) then
            i = add_line(cmd,n,'-egrep')
	    write(tmpline,9050) verf_date
9050	    format(':start_FT=',i14.14)
	    i = add_line(cmd,n,tmpline)
	endif

!       these options get values
!       use memory files 0..29

!	add call to get grid info

        i = add_line(cmd,n,'-ftn_api_fn0')
        i = add_line(cmd,n,'-last0')
        i = add_line(cmd,n,reserve_mem_buffer_name(grid_info_file))

!	grid_info desc
	if (present(desc)) then
            i = add_line(cmd,n,'-S')
            i = add_line(cmd,n,'-last0')
            i = add_line(cmd,n,reserve_mem_buffer_name(desc_file))
	endif

!	grid_desc
	if (present(grid_desc)) then
            i = add_line(cmd,n,'-grid')
            i = add_line(cmd,n,'-last0')
            i = add_line(cmd,n,reserve_mem_buffer_name(grid_desc_file))
	endif

!	get_ref_edate
	if (present(get_ref_edate)) then
            i = add_line(cmd,n,'-T')
            i = add_line(cmd,n,'-last0')
	    i = add_line(cmd,n,reserve_mem_buffer_name(get_ref_edate_file))
	endif

!	get_start_edate
	if (present(get_start_edate)) then
            i = add_line(cmd,n,'-start_FT')
            i = add_line(cmd,n,'-last0')
	    i = add_line(cmd,n,reserve_mem_buffer_name(get_start_edate_file))
	endif

!	get_end_edate
	if (present(get_end_edate)) then
            i = add_line(cmd,n,'-end_FT')
            i = add_line(cmd,n,'-last0')
	    i = add_line(cmd,n,reserve_mem_buffer_name(get_end_edate_file))
	endif

	if (present(order)) then
	    if (order == 'we:ns') then
                i = add_line(cmd,n,'-order')
                i = add_line(cmd,n,'we:ns')
	    else if (order == 'raw') then
                i = add_line(cmd,n,'-order')
                i = add_line(cmd,n,'raw')
	    else if (order /= 'we:sn') then
		write(*,*) '*** FATAL ERROR: order should be we:ns, we:sn or raw. not', order
		stop 8
	    endif
	endif

        if (present(data1).or.present(data2)) then
            i = add_line(cmd,n,'-rpn_sto')
            i = add_line(cmd,n,'19')
        endif

        if (present(lon)) then
            i = add_line(cmd,n,'-rpn')
            i = add_line(cmd,n,'rcl_lon:sto_17')
        endif

        if (present(lat)) then
            i = add_line(cmd,n,'-rpn')
            i = add_line(cmd,n,'rcl_lat:sto_18')
        endif

	if (present(copy)) then
            i = add_line(cmd,n,'-grib')
            i = add_line(cmd,n,copy)
        endif

	if (present(sequential)) then
            i = add_line(cmd,n,'-end')
	endif

        if (present(debug)) then
            do i = 1, n
                write(*,*) 'grb2_inq>>> ',trim(cmd(i))
            enddo
        endif

        ierr = wgrib2c(n,cmd, len(cmd(1)))
        if (ierr .ne. 0) then
            grb2_inq = -1
            return
        endif

!	get grid_info
        buffer_size = 71
	ierr = wgrib2_get_mem_buffer(grid_id, buffer_size, grid_info_file)
	if (ierr.ne.0) then
!	   no grid info .. no match
           grb2_inq = 0
           return
        endif
!	write(*,*) 'grid_id=',grid_id

        read(grid_id,'(i11,5(1x,i11))',end=100,err=100) grb2_inq, ndata, nnx, nny, imsgno, isubmsg
        goto 110
100     continue
        write(*,*) 'FATAL ERROR: grb2_inq reading grid info'
        grb2_inq = -1
        return
110     continue
!	write(*,*) 'ndata=',ndata, nnx, nny

        if (present(npts)) then
           npts = ndata
        endif
        if (present(nx)) then
           nx = nnx
        endif
        if (present(ny)) then
           ny = nny
        endif
        if (present(nmatch)) then
            nmatch = grb2_inq
        endif
        if (present(msgno)) then
            msgno = imsgno
        endif
        if (present(submsg)) then
            submsg = isubmsg
        endif
	if (present(desc)) then
	    buffer_size = wgrib2_get_mem_buffer_size(desc_file)
	    if (len(desc).ge.buffer_size) then
		desc = ' '
		i = wgrib2_get_mem_buffer(desc, buffer_size, desc_file)
		if (i.ne.0) desc='****'
	    else
		desc = '****'
	    endif
	endif
	if (present(grid_desc)) then
	    buffer_size = wgrib2_get_mem_buffer_size(grid_desc_file)
	    if (len(grid_desc).ge.buffer_size) then
		grid_desc = ' '
		i = wgrib2_get_mem_buffer(grid_desc, buffer_size, grid_desc_file)
		if (i.ne.0) grid_desc='****'
	    else
		grid_desc = '****'
	    endif
	endif
        if (present(get_ref_edate)) then
	    buffer_size = wgrib2_get_mem_buffer_size(get_ref_edate_file)
            get_ref_edate=-1
            if (string_size .ge. buffer_size) then
                tmpline = ' '
		i = wgrib2_get_mem_buffer(tmpline, buffer_size, get_ref_edate_file)
		if (i==0) then
!                   ignore T=
                    read(tmpline(3:buffer_size),*) get_ref_edate
                endif
            endif
        endif
        if (present(get_start_edate)) then
	    buffer_size = wgrib2_get_mem_buffer_size(get_start_edate_file)
            get_start_edate=-1
            if (string_size .ge. buffer_size) then
                tmpline = ' '
		i = wgrib2_get_mem_buffer(tmpline, buffer_size, get_start_edate_file)
		if (i==0) then
!                   ignore start_FT=
                    read(tmpline(10:buffer_size),*) get_start_edate
                endif
            endif
        endif
        if (present(get_end_edate)) then
	    buffer_size = wgrib2_get_mem_buffer_size(get_end_edate_file)
            get_end_edate=-1
            if (string_size .ge. buffer_size) then
                tmpline = ' '
		i = wgrib2_get_mem_buffer(tmpline, buffer_size, get_end_edate_file)
		if (i==0) then
!                   ignore end_FT=
                    read(tmpline(8:buffer_size),*) get_end_edate
                endif
            endif
        endif

        if (present(data1)) then
            if (ndata.le.size(data1)) then
                data1 = -1
                i = wgrib2_get_reg_data(data1, ndata, 19)
                if (i.ne.0) then
                    write(*,*) 'FATAL ERROR: get_reg 19 ',i
        	    grb2_inq = -1
        	    return
                endif
            endif
            if (present(nread)) then
                nread = ndata
            endif
        endif
!
!       does not work for staggered grids
!
        if (present(data2)) then
            if (max0(nnx,one)*max0(nny,one) .ne. ndata) then
                write(*,*) '*** FATAL ERROR: ndata != nx*ny ', ndata, nnx, nny
                grb2_inq = -1
                return
            endif
            if (.not.allocated(data2)) then
                allocate(data2(max0(nnx,one),max0(nny,one)))
            else
                if (size(data2,1).ne.max0(nnx,one) .or. size(data2,2).ne.max0(nny,one)) then
                    deallocate(data2)
                    allocate(data2(max0(nnx,one),max0(nny,one)))
                endif
            endif
            i = wgrib2_get_reg_data(data2, ndata, 19)
            if (i.ne.0) then
                write(*,*) 'FATAL ERROR: get_reg 19 ',i
                grb2_inq = -1
                return
            endif
            if (present(nread)) then
                nread = ndata
            endif
        endif

	if (present(lon)) then
            if (max0(nnx,one)*max0(nny,one) .ne. ndata) then
                write(*,*) '*** FATAL ERROR: ndata != nx*ny ', ndata, nnx, nny
                grb2_inq = -1
                return
            endif
            if (.not.allocated(lon)) then
                allocate(lon(max0(nnx,one),max0(nny,one)))
            else
                if (size(lon,1).ne.max0(nnx,one) .or. size(lon,2).ne.max0(nny,one)) then
                    deallocate(lon)
                    allocate(lon(max0(nnx,one),max0(nny,one)))
                endif
            endif
            i = wgrib2_get_reg_data(lon, ndata, 17)
            if (i.ne.0) then
                write(*,*) 'FATAL ERROR: get_reg 17 ',i
                grb2_inq = -1
                return
            endif
        endif

        if (present(lat)) then
            if (max0(nnx,one)*max0(nny,one) .ne. ndata) then
                write(*,*) '*** FATAL ERROR: ndata != nx*ny ', ndata, nnx, nny
                grb2_inq = -1
                return
            endif
            if (.not.allocated(lat)) then
                allocate(lat(max0(nnx,one),max0(nny,one)))
            else
                if (size(lat,1).ne.max0(nnx,one) .or. size(lat,2).ne.max0(nny,one)) then
                    deallocate(lat)
                    allocate(lat(max0(nnx,one),max0(nny,one)))
                endif
            endif
            i = wgrib2_get_reg_data(lat, ndata, 18)
            if (i.ne.0) then
                write(*,*) 'FATAL ERROR: get_reg 18 ',i
                grb2_inq = -1
                return
            endif
	endif

        return
        end function

!	grb2_rewind(file)
!	     rewinds internal wgrib2 file  .. grid is from N to S, default is from S to N
!
        integer function grb2_rewind(infile)
	use wgrib2lowapi

        character (len=*), optional, intent(in):: infile
        character (len=300) :: lines(2)

        lines(1) = '-rewind_init'
        lines(2) = infile
	grb2_rewind = wgrib2c(2,lines,100)
	return
	end function grb2_rewind
!
!        grb2_ncep_uv: run wgrib2 infile -ncep_uv outfile
!               combines u and v together
!

!	grb2_set_substring(string,substring,position)
!               returns 0 if ok
!               returns 8 if error

	integer function grb2_set_substring(string, substring, position)

	character (len=*), intent(inout) :: string
	character (len=*), intent(in) :: substring
	integer, intent(in) :: position
	integer :: i, k, ilen, start

	grb2_set_substring = 8
	if (position.lt.1) return
	if (position.eq.1) then
	    i = index(string,':')
	    if (i.eq.0) return
	    string = trim(substring) // string(i:)
	    grb2_set_substring = 0
	    return
	endif

	ilen = len(string)
	k = 0
	do i = 1, ilen
	    if (ichar(string(i:i)) .eq. ichar(':')) then
		k = k + 1
		if (k.eq.position-1) start = i
	        if (k.eq.position) then
		    string = string(1:start) // trim(substring) // string(i:)
	            grb2_set_substring = 0
		    return
		endif
	    endif
	enddo
	return
	end function grb2_set_substring

!	grb2_get_substring(string,position)

	character (len=200) function grb2_get_substring(string, position)

        character (len=*), intent(in) :: string
        integer, intent(in) :: position
        integer :: i, ilen, k, start

        if (position.lt.1) then
            grb2_get_substring = ''
            return
        endif
        if (position .eq. 1) then
            i = index(string,':')
            grb2_get_substring = string(1:i-1)
            return
        endif
        ilen = len(string)
        k = 0
        do i = 1, ilen
	    if (ichar(string(i:i)) .eq. ichar(':')) then
		k = k + 1
		if (k.eq.position-1) start = i
	        if (k.eq.position) then
                    grb2_get_substring = string(start+1:i-1)
                    return
		endif
	    endif
	enddo
        grb2_get_substring = ''
	return
	end function grb2_get_substring

end module

max_forks_repo_name: AerodyneLabs/Stratocast


text:
MODULE MF_UtilitiesModule

  ! --- AMReX Modules ---
  USE amrex_fort_module,     ONLY: &
    AR => amrex_real
  USE amrex_box_module,      ONLY: &
    amrex_box
  USE amrex_parallel_module,             ONLY: &
    amrex_parallel_ioprocessor, &
    amrex_parallel_reduce_sum
  USE amrex_multifab_module, ONLY: &
    amrex_multifab, &
    amrex_mfiter, &
    amrex_mfiter_build, &
    amrex_mfiter_destroy
  USE amrex_geometry_module,             ONLY: &
    amrex_geometry
  ! --- thornado Modules ---
  USE ProgramHeaderModule, ONLY: &
    nDOFZ,                 &
    nDOFX,                 &
    nNodesX,               &
    nX,                     &
    nE,                     &
    swX,                    &
    nNodesX,                &
    nDOFE,                  &
    swE,                    &
    nNodesE,                &
    iE_E0,                  &
    iE_B0,                  &
    iE_E1,                  &
    iE_B1
  USE RadiationFieldsModule,       ONLY: &
    nCR,    &
    nPR,    &
    iPR_D,  &
    iPR_I1, &
    iPR_I2, &
    iPR_I3, &
    iCR_N,  &
    iCR_G1, &
    iCR_G2, &
    iCR_G3
  USE MeshModule,                        ONLY: &
    MeshX, &
    NodeCoordinate
  USE GeometryFieldsModule,              ONLY: &
    nGF,          &
    iGF_Gm_dd_11, &
    iGF_Gm_dd_22, &
    iGF_Gm_dd_33, &
    iGF_Beta_1, &
    iGF_Beta_2, &
    iGF_Beta_3, &
    iGF_Alpha
  USE FluidFieldsModule,       ONLY: &
    nCF,    &
    iCF_D,  &
    iCF_S1, &
    iCF_S2, &
    iCF_S3, &
    iCF_E,  &
    iPF_Ne, &
    nPF,    &
    iPF_D,  &
    iPF_V1, &
    iPF_V2, &
    iPF_V3, &
    iPF_E,  &
    iCF_Ne, &
    nAF,    &
    iAF_P, &
    iAF_T, &
    iAF_Ye, &
    iAF_S, &
    iAF_E, &
    iAF_Gm, &
    iAF_Cs, &
    iAF_Me, &
    iAF_Mp, &
    iAF_Mn, &
    iAF_Xp, &
    iAF_Xn, &
    iAF_Xa, &
    iAF_Xh, &
    unitsPF, &
    unitsAF
  USE TwoMoment_UtilitiesModule_Relativistic, ONLY: &
    ComputePrimitive_TwoMoment
  USE Euler_UtilitiesModule_Relativistic, ONLY: &
    ComputePrimitive_Euler_Relativistic
  USE GeometryFieldsModuleE,     ONLY: &
    nGE, uGE
  USE EquationOfStateModule_TABLE, ONLY: &
    ComputeThermodynamicStates_Primitive_TABLE, &
    ComputeThermodynamicStates_Auxiliary_TABLE, &
    ComputeAuxiliary_Fluid_TABLE, &
    ApplyEquationOfState_TABLE
  USE UnitsModule, ONLY: &
    MeV
  ! --- Local Modules ---
  USE MyAmrModule, ONLY: &
    nLevels, &
    nSpecies

  USE MF_TwoMoment_BoundaryConditionsModule, ONLY: &
    EdgeMap,          &
    ConstructEdgeMap, &
    MF_ApplyBoundaryConditions_TwoMoment

  IMPLICIT NONE
  PRIVATE

  PUBLIC :: amrex2thornado_Z
  PUBLIC :: thornado2amrex_Z
  PUBLIC :: amrex2thornado_X
  PUBLIC :: thornado2amrex_X
  PUBLIC :: WriteNodalDataToFile
  PUBLIC :: WriteEulertoFile

  CONTAINS

  SUBROUTINE amrex2thornado_Z &
    ( nVars, nS, nE, iE_B0, iE_E0, iZ_B1, iZ_E1, iLo_MF, &
      iZ_B, iZ_E, Data_amrex, Data_thornado )

    INTEGER,  INTENT(in)  :: nVars, nS, nE
    INTEGER,  INTENT(in)  :: iE_B0, iE_E0, iZ_B1(4), iZ_E1(4), iLo_MF(4), &
                             iZ_B(4), iZ_E(4)
    REAL(AR), INTENT(in)  :: &
      Data_amrex   (   iLo_MF(1):,iLo_MF(2):,iLo_MF(3):,iLo_MF(4):)
    REAL(AR), INTENT(out) :: &
      Data_thornado(1:,iZ_B1(1):,iZ_B1(2):,iZ_B1(3):,iZ_B1(4):,1:,1:)

    INTEGER :: iZ1, iZ2, iZ3, iZ4, iS, iVar, iD, iNodeZ

    DO iS = 1, nS
    DO iVar = 1, nVars
    DO iZ4 = iZ_B(4), iZ_E(4)
    DO iZ3 = iZ_B(3), iZ_E(3)
    DO iZ2 = iZ_B(2), iZ_E(2)

      DO iZ1 = iE_B0, iE_E0 ! always want iZ1 to not include ghost cells
      DO iNodeZ = 1, nDOFZ

        iD = ( iS - 1 ) * nVars * ( iE_E0 - iE_B0 + 1 ) * nDOFZ &
                + ( iVar - 1 ) * ( iE_E0 - iE_B0 + 1 ) * nDOFZ &
                + ( iZ1 - 1 ) * nDOFZ + iNodeZ

        Data_thornado(iNodeZ,iZ1,iZ2,iZ3,iZ4,iVar,iS) &
          = Data_amrex(iZ2,iZ3,iZ4,iD)

      END DO
      END DO

    END DO
    END DO
    END DO
    END DO
    END DO

  END SUBROUTINE amrex2thornado_Z

  SUBROUTINE thornado2amrex_Z &
    ( nVars, nS, nE, iE_B0, iE_E0, iZ_B1, iZ_E1, iLo_MF, &
      iZ_B, iZ_E, Data_amrex, Data_thornado )

    INTEGER,  INTENT(in)  :: nVars, nS, nE
    INTEGER,  INTENT(in)  :: iE_B0, iE_E0, iZ_B1(4), iZ_E1(4), iLo_MF(4), &
                             iZ_B(4), iZ_E(4)
    REAL(AR), INTENT(out) :: &
      Data_amrex   (   iLo_MF(1):,iLo_MF(2):,iLo_MF(3):,iLo_MF(4):)
    REAL(AR), INTENT(in)  :: &
      Data_thornado(1:,iZ_B1(1):,iZ_B1(2):,iZ_B1(3):,iZ_B1(4):,1:,1:)

    INTEGER :: iZ1, iZ2, iZ3, iZ4, iS, iVar, iNodeZ, iD

    DO iS = 1, nS
    DO iVar = 1, nVars
    DO iZ4 = iZ_B(4), iZ_E(4)
    DO iZ3 = iZ_B(3), iZ_E(3)
    DO iZ2 = iZ_B(2), iZ_E(2)

      DO iZ1 = iE_B0, iE_E0
      DO iNodeZ = 1, nDOFZ

        iD = ( iS - 1 ) * nVars * ( iE_E0 - iE_B0 + 1 ) * nDOFZ &
               + ( iVar - 1 ) * ( iE_E0 - iE_B0 + 1 ) * nDOFZ &
               + ( iZ1 - 1 ) * nDOFZ + iNodeZ

        Data_amrex(iZ2,iZ3,iZ4,iD) &
          = Data_thornado(iNodeZ,iZ1,iZ2,iZ3,iZ4,iVar,iS)

      END DO
      END DO

    END DO
    END DO
    END DO
    END DO
    END DO

  END SUBROUTINE thornado2amrex_Z

  SUBROUTINE amrex2thornado_X &
    ( nFields, iX_B1, iX_E1, iLo_MF, iX_B, iX_E, Data_amrex, Data_thornado )

    INTEGER,  INTENT(in)  :: nFields
    INTEGER,  INTENT(in)  :: iX_B1(3), iX_E1(3), iLo_MF(4), iX_B(3), iX_E(3)
    REAL(AR), INTENT(in)  :: &
      Data_amrex   (   iLo_MF(1):,iLo_MF(2):,iLo_MF(3):,iLo_MF(4):)
    REAL(AR), INTENT(out) :: &
      Data_thornado(1:,iX_B1(1):,iX_B1(2):,iX_B1(3):,1:)

    INTEGER :: iX1, iX2, iX3, iFd

    DO iFd = 1, nFields
    DO iX3 = iX_B(3), iX_E(3)
    DO iX2 = iX_B(2), iX_E(2)
    DO iX1 = iX_B(1), iX_E(1)

      Data_thornado(1:nDOFX,iX1,iX2,iX3,iFd) &
        = Data_amrex(iX1,iX2,iX3,nDOFX*(iFd-1)+1:nDOFX*iFd)

    END DO
    END DO
    END DO
    END DO

  END SUBROUTINE amrex2thornado_X

  SUBROUTINE thornado2amrex_X &
    ( nFields, iX_B1, iX_E1, iLo_MF, iX_B, iX_E, Data_amrex, Data_thornado )

    INTEGER,  INTENT(in)  :: nFields
    INTEGER,  INTENT(in)  :: iX_B1(3), iX_E1(3), iLo_MF(4), iX_B(3), iX_E(3)
    REAL(AR), INTENT(out) :: &
      Data_amrex   (   iLo_MF(1):,iLo_MF(2):,iLo_MF(3):,iLo_MF(4):)
    REAL(AR), INTENT(in)  :: &
      Data_thornado(1:,iX_B1(1):,iX_B1(2):,iX_B1(3):,1:)

    INTEGER :: iX1, iX2, iX3, iFd

    DO iFd = 1, nFields
    DO iX3 = iX_B(3), iX_E(3)
    DO iX2 = iX_B(2), iX_E(2)
    DO iX1 = iX_B(1), iX_E(1)

      Data_amrex(iX1,iX2,iX3,nDOFX*(iFd-1)+1:nDOFX*iFd) &
        = Data_thornado(1:nDOFX,iX1,iX2,iX3,iFd)

    END DO
    END DO
    END DO
    END DO

  END SUBROUTINE thornado2amrex_X

  SUBROUTINE WriteNodalDataToFile( GEOM, MF_uGF, MF_uCF, MF_uCR, FileNameBase )

    TYPE(amrex_geometry), INTENT(in) :: GEOM  (0:nLevels-1)
    TYPE(amrex_multifab), INTENT(in) :: MF_uGF(0:nLevels-1)
    TYPE(amrex_multifab), INTENT(in) :: MF_uCF(0:nLevels-1)
    TYPE(amrex_multifab), INTENT(in) :: MF_uCR(0:nLevels-1)
    CHARACTER(LEN=*)    , INTENT(in) :: FileNameBase

    INTEGER            :: iX_B0(3), iX_E0(3), iX_B1(3), iX_E1(3),     &
                          iZ_B0(4), iZ_E0(4), iZ_B1(4), iZ_E1(4),     &
                          iZ_B (4), iZ_E (4), iE_B, iE_E,             &
                          iX_B (3), iX_E (3), iEL, iER, iLo_MF(4),    &
                          iLevel, nCompGF, nCompCF, nCompCR,          &
                          iX1, iX2, iX3, iCF, iGF, iCR, i,            &
                          iZ1, iZ2, iZ3, iZ4, iS, iE,                 &
                          iNodeZ,                                     &
                          iNodeX, iNodeX1, iNodeX2, iNodeX3, iNodeE
    TYPE(amrex_box)    :: BX
    TYPE(amrex_mfiter) :: MFI
    TYPE(EdgeMap)      :: Edge_Map

    REAL(AR), CONTIGUOUS, POINTER :: uGF (:,:,:,:)
    REAL(AR), CONTIGUOUS, POINTER :: uCF (:,:,:,:)
    REAL(AR), CONTIGUOUS, POINTER :: uCR (:,:,:,:)

    REAL(AR), ALLOCATABLE :: G (:,:,:,:,:)
    REAL(AR), ALLOCATABLE :: CF (:,:,:,:,:)
    REAL(AR), ALLOCATABLE :: PF (:,:,:,:,:)
    REAL(AR), ALLOCATABLE :: CR (:,:,:,:,:,:,:)
    REAL(AR), ALLOCATABLE :: PR (:,:,:,:,:,:,:)

    REAL(AR) :: D, I1, I2, I3, N, G1, G2, G3

    ALLOCATE( G(1:nDOFX,1-swX(1):nX(1)+swX(1), &
                        1-swX(2):nX(2)+swX(2), &
                        1-swX(3):nX(3)+swX(3),1:nGF) )

    ALLOCATE( CF(1:nDOFX,1-swX(1):nX(1)+swX(1), &
                        1-swX(2):nX(2)+swX(2), &
                        1-swX(3):nX(3)+swX(3),1:nCF) )

    ALLOCATE( PF(1:nDOFX,1-swX(1):nX(1)+swX(1), &
                        1-swX(2):nX(2)+swX(2), &
                        1-swX(3):nX(3)+swX(3),1:nPF) )
    ALLOCATE( CR(1:nDOFZ,1-swE:nE+swE, &
                        1-swX(1):nX(1)+swX(1), &
                        1-swX(2):nX(2)+swX(2), &
                        1-swX(3):nX(3)+swX(3),1:nCR,1:nSpecies) )
    ALLOCATE( PR(1:nDOFZ,1-swE:nE+swE, &
                        1-swX(1):nX(1)+swX(1), &
                        1-swX(2):nX(2)+swX(2), &
                        1-swX(3):nX(3)+swX(3),1:nPR,1:nSpecies) )
    G = 0.0_AR
    CF = 0.0_AR
    PF = 0.0_AR
    CR = 0.0_AR
    PR = 0.0_AR

    ! --- Convert AMReX MultiFabs to thornado arrays ---

    DO iLevel = 0, nLevels-1

      ! --- Apply boundary conditions to interior domains ---

      CALL MF_uGF(iLevel) % Fill_Boundary( GEOM(iLevel) )

      CALL MF_uCF(iLevel) % Fill_Boundary( GEOM(iLevel) )

      CALL MF_uCR(iLevel) % Fill_Boundary( GEOM(iLevel) )

      CALL amrex_mfiter_build( MFI, MF_uGF(iLevel), tiling = .TRUE. )

      DO WHILE( MFI % next() )

        uGF     => MF_uGF(iLevel) % DataPtr( MFI )
        nCompGF =  MF_uGF(iLevel) % nComp()

        uCF     => MF_uCF(iLevel) % DataPtr( MFI )
        nCompCF =  MF_uCF(iLevel) % nComp()

        uCR     => MF_uCR(iLevel) % DataPtr( MFI )
        nCompCR =  MF_uCr(iLevel) % nComp()

        iLo_MF = LBOUND( uGF )

        BX = MFI % tilebox()

        iX_B0 = BX % lo
        iX_E0 = BX % hi
        iX_B1 = BX % lo - swX
        iX_E1 = BX % hi + swX

        iX_B = iX_B0
        iX_E = iX_E0

        i=1

        DO WHILE (i<=4)

          IF (i==1) THEN

            iZ_B0(i)=iE_B0
            iZ_E0(i)=iE_E0
          ELSE

            iZ_B0(i)=iX_B0(i-1)
            iZ_E0(i)=iX_E0(i-1)
          END IF
          i = i + 1
        END DO

        IF( iX_B0(1) .EQ. 1     ) iX_B(1) = 1     - swX(1)
        IF( iX_B0(2) .EQ. 1     ) iX_B(2) = 1     - swX(2)
        IF( iX_B0(3) .EQ. 1     ) iX_B(3) = 1     - swX(3)
        IF( iX_E0(1) .EQ. nX(1) ) iX_E(1) = nX(1) + swX(1)
        IF( iX_E0(2) .EQ. nX(2) ) iX_E(2) = nX(2) + swX(2)
        IF( iX_E0(3) .EQ. nX(3) ) iX_E(3) = nX(3) + swX(3)
        IF( iE_B0 .EQ. 1     ) iE_B = 1     - swE
        IF( iE_E0 .EQ. nE ) iE_E = nE + swE

        i=1

        DO WHILE (i<=4)

          IF (i==1) THEN

            iZ_B(i)=iE_B
            iZ_E(i)=iE_E
            iZ_B1(i)=iE_B1
            iZ_E1(i)=iE_E1
          ELSE

            iZ_B(i)=iX_B(i-1)
            iZ_E(i)=iX_E(i-1)
            iZ_B1(i)=iX_B1(i-1)
            iZ_E1(i)=iX_E1(i-1)
          END IF
          i = i + 1
        END DO

        CALL amrex2thornado_X( nGF, iX_B, iX_E, iLo_MF, iX_B, iX_E, uGF, &
                               G(1:nDOFX,iX_B(1):iX_E(1), &
                                         iX_B(2):iX_E(2), &
                                         iX_B(3):iX_E(3),1:nGF) )

        CALL amrex2thornado_X( nCF, iX_B, iX_E, iLo_MF, iX_B, iX_E, uCF, &
                               CF(1:nDOFX,iX_B(1):iX_E(1), &
                                          iX_B(2):iX_E(2), &
                                          iX_B(3):iX_E(3),1:nCF) )

        CALL amrex2thornado_Z &
               ( nCR, nSpecies, nE, iE_B0, iE_E0, &
                 iZ_B1, iZ_E1, iLo_MF, iZ_B1, iZ_E1, uCR, &
                 CR(1:nDOFZ,iZ_B1(1):iZ_E1(1), &
                            iZ_B1(2):iZ_E1(2), &
                            iZ_B1(3):iZ_E1(3), &
                            iZ_B1(4):iZ_E1(4),1:nCR,1:nSpecies) )

        CALL ConstructEdgeMap( GEOM(iLevel), BX, Edge_Map )

        CALL MF_ApplyBoundaryConditions_TwoMoment &
               ( iZ_B0, iZ_E0, iZ_B1, iZ_E1, CR, Edge_Map )

      END DO

    END DO

    DO iX3    = 1-swX(3), nX(3)+swX(3)
    DO iX2    = 1-swX(2), nX(2)+swX(2)
    DO iX1    = 1-swX(1), nX(1)+swX(1)
    DO iNodeX = 1       , nDOFX

      DO iGF = 1, nGF

        CALL amrex_parallel_reduce_sum( G(iNodeX,iX1,iX2,iX3,iGF) )

      END DO

      DO iCF = 1, nCF

        CALL amrex_parallel_reduce_sum( CF(iNodeX,iX1,iX2,iX3,iCF) )

      END DO

    END DO
    END DO
    END DO
    END DO

    DO iS     = 1, nSpecies
    DO iZ4    = 1-swX(3), nX(3)+swX(3)
    DO iZ3    = 1-swX(2), nX(2)+swX(2)
    DO iZ2    = 1-swX(1), nX(1)+swX(1)
    DO iZ1    = 1-swE, nE+swE
    DO iNodeZ = 1       , nDOFZ

      DO iCR = 1, nCR

        CALL amrex_parallel_reduce_sum( CR(iNodeZ,iZ1,iZ2,iZ3,iZ4,iCR,iS) )

      END DO

    END DO
    END DO
    END DO
    END DO
    END DO
    END DO

    IF( amrex_parallel_ioprocessor() )THEN

      DO iX3 = 1, nX(3)
      DO iX2 = 1, nX(2)
      DO iX1 = 1, nX(1)

        CALL ComputePrimitive_Euler_Relativistic &
               ( CF(:,iX1,iX2,iX3,iCF_D ),       &
                 CF(:,iX1,iX2,iX3,iCF_S1),       &
                 CF(:,iX1,iX2,iX3,iCF_S2),       &
                 CF(:,iX1,iX2,iX3,iCF_S3),       &
                 CF(:,iX1,iX2,iX3,iCF_E ),       &
                 CF(:,iX1,iX2,iX3,iCF_Ne),       &
                 PF(:,iX1,iX2,iX3,iPF_D ),       &
                 PF(:,iX1,iX2,iX3,iPF_V1),       &
                 PF(:,iX1,iX2,iX3,iPF_V2),       &
                 PF(:,iX1,iX2,iX3,iPF_V3),       &
                 PF(:,iX1,iX2,iX3,iPF_E ),       &
                 PF(:,iX1,iX2,iX3,iPF_Ne),       &
                 G(:,iX1,iX2,iX3,iGF_Gm_dd_11), &
                 G(:,iX1,iX2,iX3,iGF_Gm_dd_22), &
                 G(:,iX1,iX2,iX3,iGF_Gm_dd_33) )

      END DO
      END DO
      END DO

    END IF

    IF( amrex_parallel_ioprocessor() )THEN

      DO iS = 1, nSpecies
      DO iZ4 = 1, nX(3)
      DO iZ3 = 1, nX(2)
      DO iZ2 = 1, nX(1)
      DO iZ1 = 1, nE

        DO iNodeX = 1, nDOFX
        DO iNodeE = 1, nDOFE

          iNodeZ = (iNodeX-1) * nDOFE + iNodeE
          CALL ComputePrimitive_TwoMoment &
               ( CR(iNodeZ,iZ1,iZ2,iZ3,iZ4, iCR_N, iS), &
                 CR(iNodeZ,iZ1,iZ2,iZ3,iZ4, iCR_G1, iS), &
                 CR(iNodeZ,iZ1,iZ2,iZ3,iZ4, iCR_G2, iS), &
                 CR(iNodeZ,iZ1,iZ2,iZ3,iZ4, iCR_G3, iS), &
                 PR(iNodeZ,iZ1,iZ2,iZ3,iZ4, iPR_D, iS), &
                 PR(iNodeZ,iZ1,iZ2,iZ3,iZ4, iPR_I1, iS), &
                 PR(iNodeZ,iZ1,iZ2,iZ3,iZ4, iPR_I2, iS), &
                 PR(iNodeZ,iZ1,iZ2,iZ3,iZ4, iPR_I3, iS), &
                 PF(iNodeX,iZ2,iZ3,iZ4, iPF_V1), &
                 PF(iNodeX,iZ2,iZ3,iZ4,iPF_V2), &
                 PF(iNodeX,iZ2,iZ3,iZ4, iPF_V3), &
                 G (iNodeX,iZ2,iZ3,iZ4,iGF_Gm_dd_11), &
                 G (iNodeX,iZ2,iZ3,iZ4,iGF_Gm_dd_22), &
                 G (iNodeX,iZ2,iZ3,iZ4,iGF_Gm_dd_33), &
                 0.0_AR, 0.0_AR, 0.0_AR,                &
                 G(iNodeX ,iZ2,iZ3,iZ4,iGF_Alpha  ), &
                 G(iNodeX  ,iZ2,iZ3,iZ4,iGF_Beta_1  ), &
                 G(iNodeX  ,iZ2,iZ3,iZ4,iGF_Beta_2  ), &
                 G(iNodeX  ,iZ2,iZ3,iZ4,iGF_Beta_3  ) )

        END DO
        END DO

      END DO
      END DO
      END DO
      END DO
      END DO

      OPEN( UNIT = 100, FILE = TRIM( FileNameBase ) // 'r.dat'      )
      OPEN( UNIT = 101, FILE = TRIM( FileNameBase ) // 'D.dat'      )
      OPEN( UNIT = 102, FILE = TRIM( FileNameBase ) // 'I1.dat'  )
      OPEN( UNIT = 103, FILE = TRIM( FileNameBase ) // 'I2.dat'    )
      OPEN( UNIT = 104, FILE = TRIM( FileNameBase ) // 'I3.dat' )
      OPEN( UNIT = 105, FILE = TRIM( FileNameBase ) // 'N.dat'      )
      OPEN( UNIT = 106, FILE = TRIM( FileNameBase ) // 'G1.dat'      )
      OPEN( UNIT = 107, FILE = TRIM( FileNameBase ) // 'G2.dat'      )
      OPEN( UNIT = 108, FILE = TRIM( FileNameBase ) // 'G3.dat'      )
      OPEN( UNIT = 109, FILE = TRIM( FileNameBase ) // 'D_middle.dat'      )
      OPEN( UNIT = 110, FILE = TRIM( FileNameBase ) // 'D_spatial.dat'      )

      ! --- Hacked to work only for 1D and 2D problems ---
      DO iS = 1, nSpecies
      DO iX3     = 1, nX(3)
      DO iNodeX3 = 1, nNodesX(3)

        DO iX2     = 1, nX(2)
        DO iNodeX2 = 1, nNodesX(2)

        DO iX1     = 1, nX(1)
        DO iNodeX1 = 1, nNodesX(1)
          IF     ( iNodeX1 .EQ. 1 )THEN

            iEL = 1
            iER = nNodesE

          ELSE IF( iNodeX1 .EQ. 2 )THEN

            iEL = nNodesE + 1
            iER = 2 * nNodesE

          ELSE IF( iNodeX1 .EQ. 3 )THEN

            iEL = 2 * nNodesE + 1
            iER = 3 * nNodesE

          END IF

          DO iE = 1, nE
          DO iNodeE = iEL, iER
            D = PR(iNodeE,iE,iX1,iX2,iX3,iPR_D,iS)
            I1 = PR(iNodeE,iE,iX1,iX2,iX3,iPR_I1,iS)
            I2 = PR(iNodeE,iE,iX1,iX2,iX3,iPR_I2,iS)
            I3 = PR(iNodeE,iE,iX1,iX2,iX3,iPR_I3,iS)
            N = CR(iNodeE,iE,iX1,iX2,iX3,iCR_N,iS)
            G1 = CR(iNodeE,iE,iX1,iX2,iX3,iCR_G1,iS)
            G2 = CR(iNodeE,iE,iX1,iX2,iX3,iCR_G2,iS)
            G3 = CR(iNodeE,iE,iX1,iX2,iX3,iCR_G3,iS)

            WRITE(101,'(ES24.16E3,1x)',ADVANCE='NO') &
              D
            WRITE(102,'(ES24.16E3,1x)',ADVANCE='NO') &
              I1
            WRITE(103,'(ES24.16E3,1x)',ADVANCE='NO') &
              I2
            WRITE(104,'(ES24.16E3,1x)',ADVANCE='NO') &
              I3
            WRITE(105,'(ES24.16E3,1x)',ADVANCE='NO') &
              N
            WRITE(106,'(ES24.16E3,1x)',ADVANCE='NO') &
              G1
            WRITE(107,'(ES24.16E3,1x)',ADVANCE='NO') &
              G2
            WRITE(108,'(ES24.16E3,1x)',ADVANCE='NO') &
              G3
            IF (iX1 .EQ. nX(1)/2 .AND. iNodeX1 .EQ. 1) THEN
              WRITE(109,'(ES24.16E3,1x)',ADVANCE='NO') &
                D
            END IF
            IF (iE .EQ. 1 .AND. iNodeE .EQ. 1) THEN
              WRITE(110,'(ES24.16E3,1x)',ADVANCE='NO') &
                D
            END IF
          END DO
          END DO
        WRITE(101,*)
        WRITE(102,*)
        WRITE(103,*)
        WRITE(104,*)
        WRITE(105,*)
        WRITE(106,*)
        WRITE(107,*)
        WRITE(108,*)
        END DO
        END DO
        END DO
        END DO

      END DO
      END DO
      END DO

      CLOSE( 110 )
      CLOSE( 109 )
      CLOSE( 108 )
      CLOSE( 107 )
      CLOSE( 106 )
      CLOSE( 105 )
      CLOSE( 104 )
      CLOSE( 103 )
      CLOSE( 102 )
      CLOSE( 101 )
      CLOSE( 100 )

    END IF
    DEALLOCATE( CF )
    DEALLOCATE( PF )
    DEALLOCATE( CR )
    DEALLOCATE( PR )
    DEALLOCATE( G )

    print*, "Writing Nodal Values"
  END SUBROUTINE WriteNodalDataToFile

  SUBROUTINE WriteEulertoFile( MF_uCF, MF_uGF, n )

    TYPE(amrex_multifab), INTENT(in) :: MF_uGF(0:nLevels-1)
    TYPE(amrex_multifab), INTENT(in) :: MF_uCF(0:nLevels-1)
    INTEGER, INTENT(in) :: n

    TYPE(amrex_mfiter) :: MFI
    TYPE(amrex_box)    :: BX

    REAL(AR), CONTIGUOUS, POINTER :: uGF(:,:,:,:)
    REAL(AR), CONTIGUOUS, POINTER :: uCF(:,:,:,:)

    REAL(AR), ALLOCATABLE :: G(:,:,:,:,:)
    REAL(AR), ALLOCATABLE :: U(:,:,:,:,:)
    REAL(AR), ALLOCATABLE :: AF(:,:,:,:,:)
    REAL(AR), ALLOCATABLE :: PF(:,:,:,:,:)

    REAL(AR) :: Mu(1:nDOFX), num

    INTEGER :: iLevel, iX_B0(3), iX_E0(3), iX_B1(3), iX_E1(3), iLo_MF(4)
    INTEGER :: iX1, iX2, iX3, l

    character(len=64) :: nm
    CHARACTER(LEN=16) :: FMT

    WRITE(FMT,'(A3,I3.3,A10)') '(SP', nDOFX, 'ES25.16E3)'
    DO iLevel = 0, nLevels-1

      CALL amrex_mfiter_build( MFI, MF_uGF(iLevel), tiling = .TRUE. )

      DO WHILE( MFI % next() )

        uGF => MF_uGF(iLevel) % DataPtr( MFI )
        uCF => MF_uCF(iLevel) % DataPtr( MFI )

        iLo_MF = LBOUND( uGF )

        BX = MFI % tilebox()

        iX_B0 = BX % lo
        iX_E0 = BX % hi
        iX_B1 = BX % lo - swX
        iX_E1 = BX % hi + swX

        ALLOCATE( G(1:nDOFX,iX_B1(1):iX_E1(1), &
                            iX_B1(2):iX_E1(2), &
                            iX_B1(3):iX_E1(3),1:nGF) )

        ALLOCATE( U(1:nDOFX,iX_B1(1):iX_E1(1), &
                            iX_B1(2):iX_E1(2), &
                            iX_B1(3):iX_E1(3),1:nCF) )

        ALLOCATE( PF(1:nDOFX,iX_B1(1):iX_E1(1), &
                             iX_B1(2):iX_E1(2), &
                             iX_B1(3):iX_E1(3),1:nPF) )

        ALLOCATE( AF(1:nDOFX,iX_B1(1):iX_E1(1), &
                              iX_B1(2):iX_E1(2), &
                              iX_B1(3):iX_E1(3),1:nAF) )

        CALL amrex2thornado_X( nGF, iX_B1, iX_E1, iLo_MF, iX_B0, iX_E0, uGF, G )

        CALL amrex2thornado_X( nCF, iX_B1, iX_E1, iLo_MF, iX_B0, iX_E0, uCF, U )

        DO iX3 = 1, nX(3)
        DO iX2 = 1, nX(2)
        DO iX1 = 1, nX(1)
          CALL ComputePrimitive_Euler_Relativistic &
               ( U(:,iX1,iX2,iX3,iCF_D ),       &
                 U(:,iX1,iX2,iX3,iCF_S1),       &
                 U(:,iX1,iX2,iX3,iCF_S2),       &
                 U(:,iX1,iX2,iX3,iCF_S3),       &
                 U(:,iX1,iX2,iX3,iCF_E ),       &
                 U(:,iX1,iX2,iX3,iCF_Ne),       &
                 PF(:,iX1,iX2,iX3,iPF_D ),       &
                 PF(:,iX1,iX2,iX3,iPF_V1),       &
                 PF(:,iX1,iX2,iX3,iPF_V2),       &
                 PF(:,iX1,iX2,iX3,iPF_V3),       &
                 PF(:,iX1,iX2,iX3,iPF_E ),       &
                 PF(:,iX1,iX2,iX3,iPF_Ne),       &
                 G(:,iX1,iX2,iX3,iGF_Gm_dd_11), &
                 G(:,iX1,iX2,iX3,iGF_Gm_dd_22), &
                 G(:,iX1,iX2,iX3,iGF_Gm_dd_33) )

           CALL ComputeAuxiliary_Fluid_TABLE &
               ( PF(:,iX1,iX2,iX3,iPF_D ), &
                 PF(:,iX1,iX2,iX3,iPF_E ), &
                 PF(:,iX1,iX2,iX3,iPF_Ne), &
                 AF(:,iX1,iX2,iX3,iAF_P ), &
                 AF(:,iX1,iX2,iX3,iAF_T ), &
                 AF(:,iX1,iX2,iX3,iAF_Ye), &
                 AF(:,iX1,iX2,iX3,iAF_S ), &
                 AF(:,iX1,iX2,iX3,iAF_E ), &
                 AF(:,iX1,iX2,iX3,iAF_Gm), &
                 AF(:,iX1,iX2,iX3,iAF_Cs) )

          CALL ApplyEquationOfState_TABLE &
               ( PF(:,iX1,iX2,iX3,iPF_D ), &
                 AF(:,iX1,iX2,iX3,iAF_T ), &
                 AF(:,iX1,iX2,iX3,iAF_Ye), &
                 AF(:,iX1,iX2,iX3,iAF_P ), &
                 AF(:,iX1,iX2,iX3,iAF_S ), &
                 AF(:,iX1,iX2,iX3,iAF_E ), &
                 AF(:,iX1,iX2,iX3,iAF_Me), &
                 AF(:,iX1,iX2,iX3,iAF_Mp), &
                 AF(:,iX1,iX2,iX3,iAF_Mn), &
                 AF(:,iX1,iX2,iX3,iAF_Xp), &
                 AF(:,iX1,iX2,iX3,iAF_Xn), &
                 AF(:,iX1,iX2,iX3,iAF_Xa), &
                 AF(:,iX1,iX2,iX3,iAF_Xh), &
                 AF(:,iX1,iX2,iX3,iAF_Gm) )

        END DO
        END DO
        END DO
        WRITE(nm,*) n

        nm = ADJUSTL(nm)

        OPEN( UNIT = 101, FILE = 'DF.dat'      )
        OPEN( UNIT = 102, FILE = 'V1.dat'      )
        OPEN( UNIT = 103, FILE = 'V2.dat'      )
        OPEN( UNIT = 104, FILE = 'V3.dat'      )
        OPEN( UNIT = 105, FILE = 'Ye.dat'      )
        OPEN( UNIT = 106, FILE = 'Mu'//trim(nm) //'.dat'      )
        OPEN( UNIT = 107, FILE = 'E.dat'      )
        OPEN( UNIT = 108, FILE = 'T'//trim(nm) //'.dat'      )

        DO iX3 = 1, nX(3)
        DO iX2 = 1, nX(2)
        DO iX1 = 1, nX(1)

          Mu(:) = AF(:,iX1,iX2,iX3,iAF_Me) + AF(:,iX1,iX2,iX3,iAF_Mp) - AF(:,iX1,iX2,iX3,iAF_Mn)

          WRITE(101,FMT) &
            PF(:,iX1,iX2,iX3,iPF_D) &
              / unitsPF(iPF_D)

          WRITE(102,FMT) &
            PF(:,iX1,iX2,iX3,iPF_V1) &
              / unitsPF(iPF_V1)

          WRITE(103,FMT) &
            PF(:,iX1,iX2,iX3,iPF_V2) &
              / unitsPF(iPF_V2)

          WRITE(104,FMT) &
            PF(:,iX1,iX2,iX3,iPF_V3) &
              / unitsPF(iPF_V3)

          WRITE(105,FMT) &
            AF(:,iX1,iX2,iX3,iAF_Ye) &
              / unitsAF(iAF_Ye)

          WRITE(106,FMT) &
            Mu(:) &
              / unitsAF(iAF_Me)

          WRITE(107,FMT) &
            PF(:,iX1,iX2,iX3,iPF_E) &
              / unitsPF(iPF_E)

          WRITE(108,FMT) &
            AF(:,iX1,iX2,iX3,iAF_T) &
              / MeV
        END DO
        END DO
        END DO
        DEALLOCATE( U )
        DEALLOCATE( G )
        DEALLOCATE( PF )
        DEALLOCATE( AF )

      END DO

      CALL amrex_mfiter_destroy( MFI )

    END DO

  END SUBROUTINE WriteEulertoFile

END MODULE MF_UtilitiesModule

max_stars_repo_name: dunhamsj/thornado

max_issues_repo_name: dunhamsj/thornado

max_forks_repo_name: dunhamsj/thornado


text:
c
c
c1
      program prog!c2
c3
      dimension! c4
c5
     &nums(2)!c6
c7
      do i=1,2! c8
c9
        nums(i)!c10

c12
c
c
     &! c13
     &=!c14
c
c
c
     &i+47! c15
c16
      enddo!c17
c
c
c
      write(6, *, err=10) nums! c18
c19
      goto 20 !c20
c21
   10 stop 'write error' ! c22
c23
   20 continue!c24
c25
      end  !  c26
c27
c
c
c


          program demo_system_getegid
          use M_system, only : system_getegid
          implicit none
             write(*,*)'GID=',system_getegid()
          end program demo_system_getegid


text:
************************************************************************
* This file contains routines for the transformation and
* back-transformation of points between a reference triangle
* and the "real" element.
************************************************************************

************************************************************************
* Explaination of the transformation:
*
* In contrast to quadrilaterals the linear transformation on triangles
* is rather easy when using barycentric coordinates. Each point
* (X,Y) in a triangle is identified by a 3-tuple of coordinates
* (X1,X2,X3) giving the "relative" position of the point inside the
* triangle:
*
*        P3                      (0,1)
*       /  \         Phi           |  \
*      /    \        <--           |    \
*     /  p   \                     | R    \
*    P1------P2                  (0,0)---(1,0)
*
* here:    p = X1*P1 + X2*P2 + X3*P3
*
* The barycentric coordinates are "independent" of the triangle:
* When a 3-tuple of barycentric coordinates for a point p is obtained,
* this holds for both, the "real" triangle as well as the reference one.
* Therefore the corresponting point R of p on the reference triangle
* can be obtained by setting:
*
*          R = Phi^{-1}(p) = X1*(0,0) + X2*(1,0) + X3*(0,1)
*
* So when the barycentric coordinates are known, the transformation
* is trivial and can be included in the code directly. The only crucial
* point is to calculate the barycentric coordinates from a set of
* corners of a triangle. Routines for this purpose can be found in the
* following.
************************************************************************

************************************************************************
* Triangular back-transformation
*
* This subroutine is to find the barycentric coordinates for a given
* point (x,y) in real coordinates.
*
* In:
*  DCOORD - array [1..2,1..3] of double
*           Coordinates of the three corners of the real triangle.
*           DCOORD(1,.) saves the X-, DCOORD(2,.) the Y-coordinates.
*  (DXREAL,DYREAL) - coordinates of a point in the real quadrilateral
*
* Out:
*  (X1,X2,X3)   - Barycentric coordinates of the point
*  DET          - Determinant of the transformation
*
* There is no check whether the point is really inside the triangle or
* not. This can easily be checked as the point is inside
* the triangle if 0 <= X1,X2,X3 <= 1.
************************************************************************

      SUBROUTINE TBTRAF (DCOORD, X1, X2, X3, DET, DXREAL, DYREAL)

      IMPLICIT NONE

C parameters

C coordinates of the evaluation point
      DOUBLE PRECISION DXREAL,DYREAL

C coordinates of the element vertices
      DOUBLE PRECISION DCOORD (2,3)

C barycentric coordinates values of (x,y)
      DOUBLE PRECISION X1, X2, X3, DET

C local variables
      DOUBLE PRECISION DAX, DAY, DBX, DBY, DCX, DCY, DDET

	DAX = DCOORD(1, 1)
	DAY = DCOORD(2, 1)
	DBX = DCOORD(1, 2)
	DBY = DCOORD(2, 2)
	DCX = DCOORD(1, 3)
	DCY = DCOORD(2, 3)

C Example where to find this formula here:
C http://home.t-online.de/home/nagel.klaus/matdir/bary.htm

	DET = DAX*(DBY-DCY) + DBX*(DCY-DAY) + DCX*(DAY-DBY)
	DDET = 1D0 / DET
	X1 = (DXREAL*(DBY-DCY)+DBX*(DCY-DYREAL)+DCX*(DYREAL-DBY)) * DDET
	X2 = (DAX*(DYREAL-DCY)+DXREAL*(DCY-DAY)+DCX*(DAY-DYREAL)) * DDET
	X3 = (DAX*(DBY-DYREAL)+DBX*(DYREAL-DAY)+DXREAL*(DAY-DBY)) * DDET

      END

max_stars_repo_licenses: Intel Unlicense

max_issues_repo_licenses: Intel Unlicense

max_forks_repo_licenses: Intel Unlicense


text:
	SUBROUTINE AF_RICG  ( report, lenr, irptr, iret )
C************************************************************************
C* AF_RICG								*
C*									*
C* This subroutine decodes and stores the icing data from within	*
C* a RECCO report.							*
C*									*
C* AF_RICG  ( REPORT, LENR, IRPTR, IRET )				*
C*									*
C* Input parameters:							*
C*	REPORT		CHAR*		RECCO report 			*
C*	LENR		INTEGER		Length of REPORT 		*
C*									*
C* Input and output parameters:						*
C*	IRPTR		INTEGER		Pointer within REPORT 		*
C*									*
C* Output parameters:							*
C*	RIVALS (IRNICG)	REAL		Number of icing levels		*
C*	RIVALS (IRAFIC)	REAL		Airframe icing			*
C*	RIVALS (IRHBOI)	REAL		Base of icing in feet  		*
C*	RIVALS (IRHTOI)	REAL		Top of icing in feet  		*
C*	RIVALS (IRTPOI)	REAL		Type of icing                   *
C*	IRET		INTEGER		Return code 			*
C*					  0 = normal return 		*
C*					 -1 = critical error in report	*
C*									*
C**									*
C* Log:									*
C* J. Ator/NP12		01/97						*
C* J. Ator/NP12		08/97	New interface format, style changes	*
C* D. Kidwell/NCEP	 6/99	Added type, change afic codes           *
C* D. Kidwell/NCEP	 7/99	Changed meters to feet in prologue      *
C* J. Ator/NCEP		11/99	Declare field variable locally		*
C* J. Ator/NCEP		01/02	Use PR_HCDM				*
C************************************************************************
	INCLUDE		'GEMPRM.PRM'
	INCLUDE		'afcmn.cmn'
C*
	CHARACTER*(*)	report
C*
	CHARACTER	field*(MXLENF)
C*
	INCLUDE		'ERMISS.FNC'
C-----------------------------------------------------------------------
C
C*	Initialize variables.
C
	iret = -1
	afic = RMISSD
	hboi = RMISSD
	htoi = RMISSD
	tpoi = RMISSD
C
C*	The next group should contain information on the rate of icing
C*	and the type of icing that occurred.
C
	CALL AF_GFLD  ( report, lenr, irptr, field, lenf, ier )
	IF  (  ( ier .ne. 0 ) .or. ( lenf .ne. 5 ) .or.
     +		( field (1:1) .ne. '7' )  )  THEN
	    RETURN
	END IF
	CALL ST_INTG  ( field (2:2), iir, ier )
	CALL ST_INTG  ( field (3:3), iit, ier )
	IF  ( iit .eq. 0 )  THEN
	    afic = 0.0
	  ELSE IF  ( ( iir .ge. 7 ) .and. ( iir .le. 9 ) )  THEN
	    afic = FLOAT ( iir * 2 - 11 )
	    IF ( afic .gt. 6. ) afic = 8.
	    IF  ( ( iit .ge. 1 ) .and. ( iit .le. 9 ) )  THEN
		tpoi = FLOAT ( iit + 3 )
	    END IF
	END IF
C
C*	The next group should contain information on the altitude of
C*	the layer in which the icing occurred.
C
	CALL AF_GFLD  ( report, lenr, irptr, field, lenf, ier )
	IF  ( ( ier .eq. 0 ) .and. ( lenf .eq. 5 ) .and.
     +		( field (1:1) .eq. '7' )  )  THEN
	    iret = 0
	    hboi = PR_HGMF ( PR_HCDM ( field (2:3) ) )
	    htoi = PR_HGMF ( PR_HCDM ( field (4:5) ) )
	END IF
C
	IF  ( .not. ERMISS ( afic ) )  THEN
C
C*	    Store the icing data.
C
C*	    Airframe icing values are stored in the interface format
C*	    using the following code figures -
C*		NONE     = 0
C*		LIGHT    = 3
C*		MODERATE = 5
C*		SEVERE   = 8
C*	    Type of icing is from WMO RECCO Code Table 4-7, plus 3.
C*	    (Icing types 1, 2 and 3 are reserved for rime, clear and
C*	    mixed, respectively.)
C
	    rivals ( irnicg ) = 1
	    rivals ( irafic (1) ) = afic
	    rivals ( irhboi (1) ) = hboi
	    rivals ( irhtoi (1) ) = htoi
	    rivals ( irtpoi (1) ) = tpoi
	END IF
C*
	RETURN
	END

max_stars_repo_name: oxelson/gempak

max_issues_repo_name: oxelson/gempak

max_forks_repo_name: oxelson/gempak


text:
      double complex function zhoge()

      zhoge = (0.0d0,0.0d0)

      return
      end