text:
Which genre is Andromeda's genre
Show artists who have music in two genres
Who's songs are Ameno and Dark Wave
Which songs did Andromeda released in 0
What songs came out the same year as Ameno or after
How many songs are there
What genres have fewer than two artists
Which musicians are doing electronica and release electronica music
Which artists songs came out in 0
What are some songs sung by Andromeda from 0
Which songs are of genre electronica
Which Andromeda songs came out in 0
Show artists with a genre in common with Andromeda
What songs were sung by Andromeda
Which artists have the biggest amount of songs
Show the artist with the smallest number of songs
Which songs came out in 0
Name the genres of electronica artists
Who is the singer of ameno and has a song called Ameno
Which artist sings Ameno and is of electronica genre
What is an artist with genre dark wave and song Ameno
Name songs by the artist of Ameno
Which songs came out in 0 and 0
What are the songs which genre is electronica
Which songs came out in the same year as Ameno
What are genres of electronica artists
List all the artists of dark wave and electronica
Which songs were sung by electronica artists
What are the musicians who sing in more than two genres
Name the song with the most number of artists.
Which artists are dark wave
Show the artists with two genres
Which music bands have 0 songs
What music did Andromeda put out in 0
Name artists who did not sing Ameno
Which songs did Andromeda make in 0
Who sang Andromeda's songs
Which genre are dark wave artists
Which songs were released after Ameno or at the same time with it
List all the electronica artists
Name songs by andromeda and andromeda.
What's the genre of the artist whose song is Ameno
Which artist made songs in 0
Give names of music bands that have the smallest number of songs
Show artists who are not dark wave.
Show the genres of artists with dark wave music
What artist sings the songs Ameno and Ameno
Which songs came out in year 0
Give me dark wave songs
Who sings dark wave
Which songs were released before ameno
Show the earliest songs
Which artists are of genres electronica and electronica
List the songs that came out in 0 and whose author is Andromeda
Name an artist of genres dark wave and electronica
Who is the singer of electronica genre and has a song titled ameno
Which artist sang Ameno or Middleclass Love
Show electronica musicician who sang ameno
What songs were made by Andromeda and came out in 0
Which genre has more than two artists
Name songs that released in 0, 2006 or after.
Name a song by a electronica artist.
Show the genre of electronica music bands
What songs by Andromeda came out in 0
What genres have artists which are not Andromeda
Who is the artist of Ameno
Which artist sang Ameno and makes dark wave music
Name all songs that are sung by two or less artists
What is the genre of Ameno's artist
Name the genre with the greatest number of artists
What are artists that have more than two genres
What is the genre of Andromeda songs
Name songs by electronica artists.
List artists who have at least two genres
Which artist sings songs that Andromeda sings
In which genre did Andromeda sing
What songs are music by Andromeda and Andromeda
What are the names of artists with more than two songs
Which artists had a song in 0
Show songs by Andromeda from 0
Name the genres which have no less than two artists
Name the bands that do not play electronica
What Andromeda songs did Andromeda make
What genres are Andromeda or Sleazy Romance making music in
What song has two artists
What genre had fewer than two artists
Who's song is Dark Wave
Which artist has the fewest genres
Which artists have genres dark wave and electronica
Which songs are not by Andromeda
What are all of the songs that were sung by andromeda in 0
Who are artists with greater than two genres
What is the smallest genre in terms of artists
Which genres have exactly two artists
Which artists do not make electronica music
Show songs whose artist is not Andromeda
Name songs that were made by Andromeda and Andromeda
What are genres of dark wave artists
Which artists has made the fewest songs
Which genres have electronica artists
Songs Ameno or Middleclass Love
What songs have less than two artists
What are some songs by the artist of Ameno
Which songs came out after the song Ameno
Name the electronoca artist who sang ameno
Which songs did the artist who sang ameno sing
What's the genre of the artist who sang Ameno
Which artists have the same genre as Andromeda
What is the genre of artists of electronica genre
What songs did not come out in 0
Which artist belongs to the most genres
Year 0 or 2006
Which songs were released in 0 by Andromeda
Show me songs that are sung by Andromeda and which artist is Andromeda
Which songs were released in 0
Which genre do dark wave musicians have
Name the artist which has the highest number of genres
Name a song by Andromeda made in 0
Which artists are electronica
Which artists did not make the song Ameno
Which artist has genre dark wave
Which songs were released in 0
Which artist makes songs that Andromeda makes
Which songs did Andromeda released in 0
Who is the artist of Ameno or Middleclass Love
What songs were sung by andromeda
List artists that have no more than two songs
Show me the songs that came after 0 or 2006
What are Andromeda's songs from 0
What genre has the greatest number of artists
Who is the artist of Ameno
What artists have two songs
Name the genre which has at most two artists.
Who is the artist of Ameno
Which artists have no more than two genres
Show me other songs by the singer of Ameno
Show me all songs by Andromeda
Which artists have at least two songs
Which songs came out in 0
Who is the artist of Andromeda's songs
Which andromeda songs came out in 0
Show the genres of artists which are dark wave
Which artists have fewer than two songs
Which songs have two or more artists
Name a genre that has exactly two artists
Are there songs sung by two different artists
Name songs by Andromeda and Andromeda
Which songs are from 0 and were released in 0
What songs weren't sung by andromeda
What songs by Andromeda came out in 0
Show me the artists that have at most 2 genres
Who sung Dark Wave
What songs by Andromeda are by Andromeda
What kind of artist is the artist of ameno
Which artist's song is Ameno
Name the artist of genres both dark wave and electronica
What genre is Andromeda's music
What artists released songs in 0
Which dark wave artist is the artist of Ameno
Which artists are not dark wave
What songs came out in 0 or 2006
List all of the songs written by electronica artists
Which artists sing in 2 or more genres
Which artists had songs in 0
Name the genre of artists of electronics genre
Which artists made songs in 0
Which songs are sang by andromeda and made by andromeda
What is the genre of electronica artists
List all the songs by Andromeda and whose artist is Andromeda
Name a song that came out in the year that Ameno came out in
What songs did Andromeda make in 0
What are some songs made by electronica artists
Which artists' genre is both electronica and dark wave
Name a song by Andromeda or Sleazy Romance.
What artists had songs that were released in 0
Which artist sang songs by Andromeda
What songs are from 0
What genre has Andromeda and Andromeda
Which artists do both dark wave and electronica
Which artists didn't sing Ameno
Which songs are made by Andromeda
What are Andromeda's songs from 0
Name songs from year 0
 What musicians have songs from 0
Which artist has dark wave music and has a song Ameno
Which other songs by andromeda are from 0
Show the artist with the highest number of songs
What is an electronica artist who also has dark wave music
What other genres are there besides Andromeda's genre
Name all artists who are not of electronica genre.
What is an artist with genres dark wave and dark wave
Which songs came out in 0 and are by Andromeda
Which songs are sung by exactly two artists
What's the genre of dark wave artists
What electronica artists are there
Name the genres of electronica artists
Which artist had the fewest songs
Give me a song by Andromeda
What songs did Andromeda make in 0
What is the genre of the artist of dark wave
What are all of the songs sung by dark wave artists
Which electronica artist has genre electronica
Name some songs that have more than two artists
Name a song that came out in 0 and 0
What songs came out in 0
Name songs that released in 0 or after.
Which artist has the song Ameno and genre electronica
Name a songs by an electronica artist.
What genres is Andromeda
What artists have songs from 0
What songs did not come out in 0
Which artists have less than two genres
Which artists have at most two genres
Which artist is of electronica genre
What other songs did the musician who made Ameno sing
What are the musicians that sing anything apart from Dark Wave
What songs came out in 0, 2006, or after
What are the songs of Andromeda and sung by Andromeda
Name songs by Andromeda that are from 0.
Name artists with the same genre as Andromeda.
Which genre has two artists
What's total number of songs
What's the total number of musicians
What other songs came out in the same year as Ameno
What genre is Ameno's artist
What are the genres of electronica artists
What songs have more than two artists
Which artists have at least two genres
Name a song by the artists of Ameno
What other genres do dark wave singers sing
Which songs came out in years that were not 0
What artists share a genre with Andromeda
List other genres that electronica bands have
Name a song by an artist of dark wave genre.
Which songs were made by Andromeda and Andromeda
Which musicians sing in two genres
Which artists have more than two songs
Name an artist of the electronica genre
What is the song with the most artists
Name songs by Andromeda
Which artist sang Ameno and dark wave
Name songs that have at least two artists
What songs came out after Ameno did
Name songs by Andromeda from 0
What is the genre of Andromeda's music and Andromeda's music
Which dark wave artist sang Ameno
What artists do not make electronica music
Which artist shares the same genre as that of Andromeda
What is the oldest song
What is the name of the electronica artist whose song is Ameno
Name songs by Andromeda
Artists called Andromeda or Sleazy Romance
What songs were made in 0 and sung by Andromeda
Who sings dark wave and has a song called ameno
Which songs were made in 0 and came out in 0
Who sings Ameno and makes electronica music
What are the genres of artists with dark wave music
What genre is Andromeda
Which song has the fewest number of artists
Show songs that were released in 0 or 2006
Which genres have at least two artists
Who has electrinica and dark wave music
What songs are written by dark wave artists
Name songs by the artist who made Ameno
Which artists have the same genre as the genre of singer of andromeda
Show me the artists that sing in two different genres
What songs came out before 0
Who sings Ameno
What songs do Andromeda have
Which songs did Andromeda released in 0
What songs came out in 0 or 2006
Who is the artist of Andromeda's songs
Which artists make music in the electronica and dark wave genres
Which songs came out before Ameno
What songs came out before Ameno did
Who sings Ameno
Which electronica artist sang Ameno
What Andromeda song came out in 0
Show artists of genres dark wave and dark wave
Which dark wave artist sang Ameno
Who is an electronica artist who had the song Ameno
Which genre is represented by less than 2 bands
Which songs came out earlier than 0 or earlier than 2006
What artist sings Ameno and is dark wave
Which artists sang at least two songs
Which artists are both dark wave and electronica
What genre is not the same as the genre of Andromeda
Which music bands perform in less than 2 genres
What is the genre of the musician who made Ameno
Name songs by andromeda and andromeda.
Who is the artist with the highest number of songs
Show me the artists that have no more than 2 songs
Which artist sings Ameno and is dark wave
Name genre of Andromeda or Sleazy Romance.
List all 0 songs
List all electronica musicians
Name songs that came out in years besides 0
Show me some songs made by the artist who sang Ameno
Which songs are from 0
Name a song by a dark wave artist.
What is Andromeda's genre
What other songs are sung by the artist of Ameno
Name artists who sang Ameno or Middleclass love
Who is the dark wave artist who sang Ameno
Name the artist who sang songs by Andromeda
Which songs are sung by artists of genre dark wave


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

! C1413 (R1416) If a submodule-name appears in the end-submodule-stmt, it shall
! be identical to the one in the submodule-stmt.
module ancestor
  interface
    module subroutine hello
    end subroutine
  end interface
end module ancestor

! C1413 - negative - submodule-name in the end-submodule-stmt does not match
!  the name in the submodule-stmt. (compilation failure must report this)
submodule (ancestor) descendant
  contains
  module procedure hello
    print *, "hello world"
  end procedure
end submodule ancestor !{error "PGF90-S-0309-Incorrect name, ancestor, specified in END statement"}

program main
  use ancestor
  call hello
end program main

max_stars_repo_name: abrahamtovarmob/flang

max_issues_repo_name: abrahamtovarmob/flang

max_forks_repo_name: abrahamtovarmob/flang


submodule (nc4fortran) read

use, intrinsic :: iso_c_binding, only : c_null_char

implicit none (type, external)

contains

module procedure get_chunk

logical :: contig
integer :: i, varid

chunk_size = -1

i = nf90_inq_varid(self%file_id, dname, varid)
if (i/=NF90_NOERR) error stop 'ERROR:nc4fortran:chunk: cannot find variable: ' // dname

i = nf90_inquire_variable(self%file_id, varid, contiguous=contig)
if (i/=NF90_NOERR) error stop 'ERROR:nc4fortran:chunk: cannot get variable properties' // dname

if(contig) return
i = nf90_inquire_variable(self%file_id, varid, chunksizes=chunk_size)
if (i/=NF90_NOERR) error stop 'ERROR:nc4fortran:chunk: cannot get variable properties' // dname

end procedure get_chunk

module procedure get_deflate

logical :: contig
integer :: i, varid, deflate_level

get_deflate = .false.

i = nf90_inq_varid(self%file_id, dname, varid)
if (i/=NF90_NOERR) error stop 'ERROR:nc4fortran:get_deflate: cannot find variable: ' // dname

i = nf90_inquire_variable(self%file_id, varid, contiguous=contig)
if (i/=NF90_NOERR) error stop 'ERROR:nc4fortran:get_deflate: cannot get variable properties' // dname

if(contig) return
i = nf90_inquire_variable(self%file_id, varid, deflate_level=deflate_level)
if (i/=NF90_NOERR) error stop 'ERROR:nc4fortran:get_deflate: cannot get variable properties' // dname

get_deflate = deflate_level /= 0

end procedure get_deflate

module procedure get_ndim
integer :: varid, ierr

if(.not.self%is_open) error stop 'ERROR:nc4fortran:read: file handle not open'

drank = -1

ierr = nf90_inq_varid(self%file_id, dname, varid)
if(ierr/=NF90_NOERR) error stop 'ERROR:nc4fortran:get_ndim: could not get variable ID for ' // dname

ierr = nf90_inquire_variable(self%file_id, varid, ndims=drank)
if(ierr/=NF90_NOERR) error stop 'ERROR:nc4fortran:get_ndim: could not get rank for ' // dname

end procedure get_ndim

module procedure get_shape

integer :: ier, varid, i, N
integer, allocatable :: dimids(:)
character(NF90_MAX_NAME), allocatable :: tempnames(:)

N = self%ndim(dname)

allocate(dimids(N), dims(N))

ier = nf90_inq_varid(self%file_id, dname, varid)
if(check_error(ier, dname)) error stop 'ERROR:nc4fortran:get_shape: could not get variable ID for: ' // dname

ier = nf90_inquire_variable(self%file_id, varid, dimids = dimids)
if(check_error(ier, dname)) error stop 'ERROR:nc4fortran:get_shape: could not get dimension IDs for: ' // dname

if (present(dimnames)) allocate(tempnames(N))

do i = 1,N
  if(present(dimnames)) then
    ier = nf90_inquire_dimension(self%file_id, dimid=dimids(i), name=tempnames(i), len=dims(i))
  else
    ier = nf90_inquire_dimension(self%file_id, dimid=dimids(i), len=dims(i))
  endif
  if(ier/=NF90_NOERR) error stop 'ERROR:nc4fortran:get_shape: querying dimension size'
enddo

if (present(dimnames)) then
  allocate(dimnames(N))
  dimnames = tempnames
endif

end procedure get_shape

module procedure nc_check_exist
integer :: varid, ierr

exists = .false.

if(.not.self%is_open) error stop 'ERROR:nc4fortran:exist: file handle not open '

ierr = nf90_inq_varid(self%file_id, dname, varid)

select case (ierr)
case (NF90_NOERR)
  exists = .true.
case (NF90_EBADID)
  write(stderr,*) 'ERROR:nc4fortran:exist: is file opened?  ', self%filename
case (NF90_ENOTVAR)
  if (self%verbose) write(stderr,*) dname, ' does not exist in ', self%filename
case default
  write(stderr,*) 'ERROR:nc4fortran:exist: unknown problem ', self%filename
end select

end procedure nc_check_exist

module procedure nc_exist

type(netcdf_file) :: h

call h%open(filename, action='r')
nc_exist = h%exist(dname)
call h%close()

end procedure nc_exist

end submodule read


SUBROUTINE ZPPSVX_F95(A, B, X, UPLO, AF, FACT, EQUED, S, FERR, BERR, RCOND, INFO)
!
!  -- LAPACK95 interface driver routine (version 3.0) --
!     UNI-C, Denmark; Univ. of Tennessee, USA; NAG Ltd., UK
!     September, 2000
!
!  .. USE STATEMENTS ..
   USE LA_PRECISION, ONLY: WP => DP
   USE LA_AUXMOD, ONLY: LSAME, ERINFO
   USE F77_LAPACK, ONLY: PPSVX_F77 => LA_PPSVX
!  .. IMPLICIT STATEMENT ..
   IMPLICIT NONE
!  .. SCALAR ARGUMENTS ..
   CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO, FACT
   CHARACTER(LEN=1), INTENT(INOUT), OPTIONAL :: EQUED
   INTEGER, INTENT(OUT), OPTIONAL :: INFO
   REAL(WP), INTENT(OUT), OPTIONAL :: RCOND
!  .. ARRAY ARGUMENTS ..
   COMPLEX(WP), INTENT(INOUT) :: A(:), B(:,:)
   COMPLEX(WP), INTENT(OUT) :: X(:,:)
   REAL(WP), INTENT(INOUT), OPTIONAL, TARGET :: S(:)
   COMPLEX(WP), INTENT(INOUT), OPTIONAL, TARGET :: AF(:)
   REAL(WP), INTENT(OUT), OPTIONAL, TARGET :: FERR(:), BERR(:)
!----------------------------------------------------------------------
!
! Purpose
! =======
!
!     LA_PPSVX computes the solution to a linear system of equations
! A*X = B, where A is real symmetric or complex Hermitian and, in either
! case, positive definite, and where X and B are rectangular matrices or
! vectors. A is stored in packed format.
!     LA_PPSVX can also optionally equilibrate the system if A is poorly
! scaled, estimate the condition number of (the equilibrated) A, and
! compute error bounds.
!
! =========
!
!       SUBROUTINE LA_PPSVX( AP, B, X, UPLO=uplo, AFP=afp, &
!                  FACT=fact, EQUED=equed, S=s, FERR=ferr, &
!                  BERR=berr, RCOND=rcond, INFO=info )
!           <type>(<wp>), INTENT(INOUT) :: AP(:), <rhs>
!           <type>(<wp>), INTENT(OUT) :: <sol>
!           CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO
!           <type>(<wp>), INTENT(INOUT), OPTIONAL :: AFP(:)
!           CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: FACT
!           CHARACTER(LEN=1), INTENT(INOUT), OPTIONAL :: EQUED
!           REAL(<wp>), INTENT(INOUT), OPTIONAL :: S(:)
!           REAL(<wp>), INTENT(OUT), OPTIONAL :: <err>
!           REAL(<wp>), INTENT(OUT), OPTIONAL :: RCOND
!           INTEGER, INTENT(OUT), OPTIONAL :: INFO
!       where
!           <type> ::= REAL | COMPLEX
!           <wp>   ::= KIND(1.0) | KIND(1.0D0)
!           <rhs>  ::= B(:,:) | B(:)
!           <sol>  ::= X(:,:) | X(:)
!           <err>  ::= FERR(:), BERR(:) | FERR, BERR
!
! Arguments
! =========
!
! AP      (input/output) REAL or COMPLEX square array, shape (:) with
!         size(AP) = n*(n + 1)=2, where n is a rank of the matrix A.
!         On entry, the upper or lower triangle of matrix A, or its
!         equilibration, in packed storage. The elements are stored
! 	  columnwise as follows:
! 	  if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j<=n;
! 	  if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for 1<=j<=i<=n.
!         On exit, if FACT = 'E', then the equilibrated version of A is
! 	  stored in AP; otherwise, AP is unchanged.
! B       (input/output) REAL or COMPLEX array, shape (:,:) with
!         size(B,1) = n or shape (:) with size(B) = n.
!         On entry, the matrix B.
!         On exit, the scaled version of B if the system has been
!         equilibrated; otherwise, B is unchanged.
! X       (output) REAL or COMPLEX array, shape (:,:) with size(X,1)=n
!         and size(X,2) = size(B,2), or shape (:) with size(X) = n.
!         The solution matrix X .
! UPLO    Optional (input) CHARACTER(LEN=1).
!           = 'U': Upper triangle of A is stored;
!           = 'L': Lower triangle of A is stored.
!         Default value: 'U'.
! AFP     Optional (input or output) REAL or COMPLEX array, shape (:)
!         with the same size as AP.
!         If FACT = 'F' then AFP is an input argument that contains the
! 	  factor U or L from the Cholesky factorization of (the
! 	  equilibrated) A, in the same storage format as A, returned by
! 	  a previous call to LA_PPSVX.
!         If FACT 6= 'F' then AFP is an output argument that contains the
!         factor U or L from the Cholesky factorization of (the
!   	  equilibrated) A in the same storage format as A.
! FACT    Optional (input) CHARACTER(LEN=1).
!         Specifies whether the factored form of the matrix A is supplied
! 	  on entry, and, if not, whether A should be equilibrated before
! 	  it is factored.
!           = 'N': The matrix A will be copied to AFP and factored
! 	         (no equilibration).
!           = 'E': The matrix A will be equilibrated, then copied to AFP
! 	         and factored.
!           = 'F': AFP contains the factored form of (the equilibrated) A.
!         Default value: 'N'.
! EQUED   Optional (input or output) CHARACTER(LEN=1).
!         Specifies the form of equilibration that was done.
!         EQUED is an input argument if FACT = 'F', otherwise it is an
!         output argument:
!           = 'N': No equilibration (always true if FACT = 'N').
!           = 'Y': Equilibration, i.e., A has been premultiplied and
!                postmultiplied by diag(S).
!         Default value: 'N'.
! S       Optional (input or output) REAL array, shape (:) with size(S)
!         = size(A,1).
!         The scaling factors for A.
!         S is an input argument if FACT = 'F' and EQUED = 'Y'.
!         S is an output argument if FACT = 'E' and EQUED = 'Y'.
! FERR    Optional (output) REAL array of shape (:), with size(FERR) =
!         size(X,2), or REAL scalar.
!         The estimated forward error bound for each solution vector X(j)
! 	  (the j-th column of the solution matrix X). If XTRUE is the
! 	  true solution corresponding to X(j) , FERR(j) is an estimated
! 	  upper bound for the magnitude of the largest element in
! 	  (X(j)-XTRUE) divided by the magnitude of the largest element
! 	  in X(j). The estimate is as reliable as the estimate for RCOND,
! 	  and is almost always a slight overestimate of the true error.
! BERR    Optional (output) REAL array of shape (:), with size(BERR) =
!         size(X,2), or REAL scalar.
!         The componentwise relative backward error of each solution
! 	  vector X(j) (i.e., the smallest relative change in any element
! 	  of A or B that makes X(j) an exact solution).
! RCOND   Optional (output) REAL
!         The estimate of the reciprocal condition number of (the
! 	  equilibrated) A. If RCOND is less than the machine precision,
! 	  the matrix is singular to working precision. This condition is
!         indicated by a return code of INFO > 0.
! INFO    Optional (output) INTEGER
!         = 0: successful exit.
!         < 0: if INFO = -i, the i-th argument had an illegal value.
!         > 0: if INFO = i, and i is
!             <= n: the leading minor of order i of (the equilibrated) A
! 	        is not positive definite, so the factorization could
! 		not be completed and the solution and error bounds
! 		could not be computed. RCOND= 0 is returned.
!             = n+1: U or L is nonsingular, but RCOND is less than
! 	        machine precision, so the matrix is singular to
! 		working precision. Nevertheless, the solution and
! 		error bounds are computed because the computed solution
! 		can be more accurate than the value of RCOND would
! 		suggest.
!         If INFO is not present and an error occurs, then the program is
! 	  terminated with an error message.
!-----------------------------------------------------------------------
!  .. PARAMETERS ..
   CHARACTER(LEN=8), PARAMETER :: SRNAME = 'LA_PPSVX'
!  .. LOCAL SCALARS ..
   CHARACTER(LEN=1) :: LFACT, LUPLO, LEQUED
   INTEGER :: LINFO, NRHS, N, NN, ISTAT, ISTAT1, SAF, SS, SFERR, SBERR
   REAL(WP) :: LRCOND, MVS
   COMPLEX(WP) :: WW
!  .. LOCAL POINTERS ..
   REAL(WP),  POINTER :: RWORK(:), LS(:), LFERR(:), LBERR(:)
   COMPLEX(WP),  POINTER :: WORK(:), LAF( :)
!  .. INTRINSIC FUNCTIONS ..
   INTRINSIC PRESENT, SIZE, MINVAL, TINY, REAL, INT, AIMAG
!  .. EXECUTABLE STATEMENTS ..
   LINFO = 0; ISTAT = 0; NN = SIZE(A, 1); NRHS = SIZE(B, 2)
   WW = (-1+SQRT(1+8*REAL(NN,WP)))*0.5; N = INT(WW)
   IF( PRESENT(RCOND) ) RCOND = 1.0_WP
   IF( PRESENT(FACT) )THEN; LFACT = FACT; ELSE; LFACT='N'; END IF
   IF( PRESENT(EQUED) .AND. LSAME(LFACT,'F') )THEN; LEQUED = EQUED
   ELSE; LEQUED='N'; END IF
   IF( PRESENT(AF) )THEN; SAF = SIZE(AF); ELSE; SAF = N*(N+1)/2; END IF
   IF( ( PRESENT(S) ) )THEN; SS = SIZE(S); ELSE; SS = N; END IF
   IF( PRESENT(S) .AND. LSAME(LFACT,'F') .AND. LSAME(LEQUED,'Y') ) THEN
       MVS = MINVAL(S); ELSE; MVS = TINY(1.0_WP); ENDIF
   IF( PRESENT(FERR) )THEN; SFERR = SIZE(FERR); ELSE; SFERR = NRHS; END IF
   IF( PRESENT(BERR) )THEN; SBERR = SIZE(BERR); ELSE; SBERR = NRHS; END IF
   IF(PRESENT(UPLO))THEN; LUPLO = UPLO; ELSE; LUPLO='U'; END IF
!  .. TEST THE ARGUMENTS
   IF( NN < 0 .OR. AIMAG(WW) /= 0 .OR. REAL(N,WP) /= REAL(WW) ) THEN; LINFO = -1
   ELSE IF( SIZE(B, 1) /= N .OR. NRHS < 0 )THEN; LINFO = -2
   ELSE IF( SIZE(X, 1) /= N .OR. SIZE(X, 2) /= NRHS )THEN; LINFO = -3
   ELSE IF( .NOT.LSAME(LUPLO,'U') .AND. .NOT.LSAME(LUPLO,'L') )THEN; LINFO = -4
   ELSE IF( SAF /= N*(N+1)/2 ) THEN; LINFO = -5
   ELSE IF( ( .NOT. ( LSAME(LFACT,'F') .OR. LSAME(LFACT,'N') .OR. &
                    LSAME(LFACT,'E') ) ) .OR. &
      ( LSAME(LFACT,'F') .AND. .NOT.PRESENT(AF) ) )THEN; LINFO = -6
   ELSE IF( .NOT.LSAME(LEQUED,'N') .AND. .NOT.LSAME(LEQUED,'Y') )THEN; LINFO = -7
   ELSE IF( SS /= N .OR. LSAME(LFACT,'F') .AND. LSAME(LEQUED,'Y') &
      .AND. MVS  <= 0.0_WP )THEN; LINFO = -8
   ELSE IF( SFERR /= NRHS )THEN; LINFO = -9
   ELSE IF( SBERR /= NRHS )THEN; LINFO = -10
   ELSE IF ( N > 0 )THEN
      IF( .NOT.PRESENT(AF) ) THEN; ALLOCATE( LAF(N*(N+1)/2), STAT=ISTAT )
      ELSE; LAF => AF; END IF
      IF( ISTAT == 0 )THEN
         IF( .NOT.PRESENT(S) )THEN; ALLOCATE( LS(N), STAT=ISTAT )
         ELSE; LS => S; END IF
      END IF
      IF( ISTAT == 0 )THEN
         IF( .NOT.PRESENT(FERR) )THEN; ALLOCATE( LFERR(NRHS), STAT=ISTAT )
         ELSE; LFERR => FERR; END IF
      END IF
      IF( ISTAT == 0 )THEN
         IF( .NOT.PRESENT(BERR) )THEN; ALLOCATE( LBERR(NRHS), STAT=ISTAT )
         ELSE; LBERR => BERR; END IF
      END IF
      IF( ISTAT == 0 ) ALLOCATE(WORK(2*N), RWORK(N), STAT=ISTAT )
      IF( ISTAT == 0 )THEN
         CALL PPSVX_F77( LFACT, LUPLO, N, NRHS, A, LAF, LEQUED, LS, &
                  B, N, X, N, LRCOND, LFERR, LBERR, WORK, RWORK, LINFO )
      ELSE; LINFO = -100; END IF
      IF( .NOT.PRESENT(S) ) DEALLOCATE( LS, STAT=ISTAT1 )
      IF( .NOT.PRESENT(AF) ) DEALLOCATE( LAF, STAT=ISTAT1 )
      IF( .NOT.PRESENT(FERR) ) DEALLOCATE( LFERR, STAT=ISTAT1 )
      IF( .NOT.PRESENT(BERR) ) DEALLOCATE( LBERR, STAT=ISTAT1 )
      IF( PRESENT(RCOND) ) RCOND=LRCOND
      IF( PRESENT(EQUED) .AND. .NOT.LSAME(LFACT,'F') ) EQUED=LEQUED
      DEALLOCATE( WORK, RWORK, STAT=ISTAT1 )
   END IF
   CALL ERINFO( LINFO, SRNAME, INFO, ISTAT )
END SUBROUTINE ZPPSVX_F95


PROGRAM QA1
! (LICENSE:Public Domain)
   USE M_calcomp
   CHARACTER * 10 ICHR1
   CHARACTER * 14 ICHR2,ICHR3
   CHARACTER * 5  ICHR4,ICHR6
   CHARACTER * 4  ICHR5,ICHR7
   CHARACTER * 29 ICHR8
   CHARACTER * 32 ICHR9,ICHR10,ICHR11,ICHR12
   CHARACTER * 1 IBCD
   ICHR1='WIDTH (FT)'
   ICHR2='THICKNESS (IN)'
   ICHR3='PRESSURE (PSI)'
   ICHR4='THK= '
   ICHR5=' IN.'
   ICHR6='WTH= '
   ICHR7=' FT.'
   ICHR8='CRITICAL BUCKLING PRESSURE OF'
   ICHR9='HYPERBOLIC PARABOLOID SHELLS FOR'
   ICHR10='FIXED WIDTH VS VARYING THICKNESS'
   ICHR11='FIXED THICKNESS VS VARYING WIDTH'
   ICHR12='PREPARED ON A CALCOMP PLOTTER'
   CALL PLOTS(0.0,24.0,0.0,12.0)
! ESTABLISH AN ORIGIN SO NEGATIVE VALUES UP TO -0.5 MAY BE USED
   CALL PLOT(0.5,0.5,-3)
! PLOT X-AXIS FOR WIDTH
   X=0.0
   DO I=1,10
      CALL PLOT(X,0.0,3)
      X=X+1.0
      CALL PLOT(X,0.0,2)
      CALL PLOT(X,-.1,2)
      CALL NUMBER(X,-0.25,0.1,5.0*X,0.0,-1)
   ENDDO
   CALL SYMBOL(4.0,-0.40,0.12,IBCD,1,0.0,-1)
   CALL SYMBOL(4.2,-0.45,0.14,ICHR1,INTEQ,0.0,10)
   CALL PLOT (0.0,0.5,-3)
! PLOT X-AXIS FOR THICKNESS
   X=0.0
   DO I=1,5
      CALL PLOT(X,0.0,3)
      X=X+1.0
      CALL PLOT(X,0.0,2)
      CALL PLOT(X,-.1,2)
      CALL PLOT(X,0.0,2)
      X=X+1.0
      CALL PLOT(X,0.0,2)
      CALL PLOT(X,-.1,2)
      CALL NUMBER(X,-0.25,0.1,X,0.0,-1)
   enddo
   CALL SYMBOL(3.7,-0.40,0.12,IBCD,7,0.0,-1)
   CALL SYMBOL(4.0,-0.45,0.14,ICHR2,INTEQ,0.0,14)
! PLOT Y-AXIS
   Y=0.0
   DO I=1,9
      CALL PLOT(0.0,Y,3)
      Y=Y+1.0
      CALL PLOT(0.0,Y,2)
      CALL PLOT(-.1,Y,2)
      CALL NUMBER(-.15,Y-.2,0.1,1000.*Y,90.0,0)
   enddo
   CALL SYMBOL(-0.30,3.5,0.14,ICHR3,INTEQ,90.0,14)
   THICK=3.0
   WDTH=25.0
   DO I=1,3
      TSQR=THICK*THICK
      WSQR=WDTH*WDTH
      PSI=100.99*TSQR
      CALL SYMBOL(0.6,PSI/1000.0,0.1,ICHR4,INTEQ,0.0,5)
      CALL NUMBER(999.0,999.0,0.10,THICK,0.0,0)
      CALL SYMBOL(999.0,999.0,0.10,ICHR5,INTEQ,0.0,4)
      CALL SYMBOL( 2.0 ,999.0,0.12,IBCD,1,0.0,-1)
      DO J=10,50
         WX=real(J)
         PSI=10099.0*TSQR/(WX*WX)
         CALL PLOT(WX/5.0,PSI/1000.0,2)
      enddo
      PSI=10099.0*81.0/WSQR
      CALL SYMBOL(9.2,PSI/1000.0,0.1,ICHR6,INTEQ,0.0,5)
      CALL NUMBER(999.0,999.0,0.10,WDTH,0.0,0)
      CALL SYMBOL(999.0,999.0,0.10,ICHR7,INTEQ,0.0,4)
      CALL SYMBOL( 9.0 ,999.0,0.12,IBCD,7,0.0,-1)
      DO J=5,50
         TX=real(J)
         TX=(50.0-TX)/5.0
         PSI=10099.0*TX*TX/WSQR
         CALL PLOT(TX,PSI/1000.0,2)
      enddo
      THICK=THICK+3.0
      WDTH=WDTH-5.0
   enddo
   CALL SYMBOL(3.3,8.5,.14,ICHR8,INTEQ,0.,29)
   CALL SYMBOL(3.1,8.2,.14,ICHR9,INTEQ,0.,32)
   CALL SYMBOL(3.1,7.9,.14,ICHR10,INTEQ,0.,32)
   CALL SYMBOL(3.1,7.6,.14,ICHR11,INTEQ,0.,32)
   CALL SYMBOL(3.3,7.0,.14,ICHR12,INTEQ,0.,29)
   CALL PLOT(0.0,0.0,999)
   STOP
END PROGRAM QA1


text:
module category_theory_concepts
    ! Note: Sensible implementations should satisfy
    ! associativity: a // (b // c) == (a // b) // c
    concept :: semigroup(T)
        operator(//)(lhs, rhs) result(combined)
            T, intent(in) :: lhs, rhs
            T :: combined
        end operator(//)
        function sconcat(xs, starting) result(combined)
            T, intent(in) :: xs(:), starting
            T :: combined
            default
                integer :: i
                combined = starting
                do i = 1, size(xs)
                    combined = combined // xs(i)
                end do
            end default
        end function
        function stimes(num, start) result(repeated)
            integer, intent(in) :: num
            T, intent(in) :: start
            T :: repeated
            default
                if (num < 1) then
                    if (monoid(T)) then
                        repeated = mempty(start)
                    else
                        error stop "attempted to repeat non-monoid 0 times"
                    end if
                else
                    repeated = sconcat([(start, i = 1, num-1)], start)
                end if
            end default
        end function
    end concept

    ! Note: Sensible implementations should satisfy
    ! identity: T // mempty(T) == T
    !           mempty(T) // T == T
    concept :: monoid(T)
        requirements :: semigroup(T)
        function mempty(mold)
            T, intent(in) :: mold
            T :: mempty
        end function
        function mappend(x, y) result(combined)
            T, intent(in) :: x, y
            T :: combined
            default
                combined = x // y
            end default
        end function
        function mconcat(xs) result(combined)
            T, intent(in) :: xs(:)
            T :: combined
            default
                combined = sconcat(xs, mempty(combined))
            end default
        end function
    end concept
end module

module maybe
    use category_theory_concepts, only: semigroup, monoid

    concept :: copyable(T)
        assignment: T = T
    end concept

    type :: maybe_t<T>
        private
        logical :: available
        T :: item
    end type
    if (semigroup(T)) then
        satisfies :: semigroup(maybe_t<T>)
        satisfies :: monoid(maybe_t<T>)
    end if

    interface maybe_t
        module procedure just
        module procedure nothing
    end interface

    if (semigroup(T)) then
        interface operator(//)
            module procedure concat
        end interface
    end if
contains
    function just(item) result(maybe)
        T, intent(in) :: item
        type(maybe_t<T>) :: maybe

        maybe%item = item
        maybe%available = .true.
    end function

    function nothing(mold) result(maybe)
        T, intent(in) :: mold
        type(maybe_t<T>) :: maybe

        maybe%available = .false.
    end function

    if (semigroup(T)) then
        function concat(lhs, rhs) result(combined)
            type(maybe_t<T>), intent(in) :: lhs, rhs
            type(maybe_t<T>) :: combined

            if (lhs%available) then
                if (rhs%available) then
                    combined%item = lhs%item // rhs%item
                    combined%available = .true.
                else
                    combined%item = lhs%item
                    combined%available = .true.
                end if
            else
                if (rhs%available) then
                    combined%item = rhs%item
                    combined%available = .true.
                else
                    combined%available = .false.
                end if
            end if
        end function

        function mempty(mold)
            type(maybe_t<T>), intent(in) :: mold
            type(maybe_t<T>) :: mempty

            mempty%available = .false.
        end function
    end if
end module

max_stars_repo_name: everythingfunctional/generics

max_issues_repo_name: everythingfunctional/generics

max_forks_repo_name: everythingfunctional/generics


SUBROUTINE setup_accrete
! Calculates sigma dot expected from mass infall rate
! (This version assumes a Gaussian distribution for sigma dot)

  use gravdata
  use unitdata, only: pi,yr,solarmass,AU
  use winddata

  implicit none

  integer :: i,in,out

  real :: inner,outer, term, integral
  real :: mean, sd

  allocate(sigdot_accrete(nmax))

sigdot_accrete(:) = 0.0

  ! Calculate discrete integral from adding together Gaussian over 3 * sd

  mean = 30.0*AU
  sd = 1.0*AU

  inner = mean - 3.0*sd
  outer = mean + 3.0*sd

  ! Find inner annulus

  i=1
  DO WHILE(rf(i) < inner)
     !print*, i,rf(i),inner
     i=i+1
  ENDDO

  in = i

  ! Now calculate integral
  DO WHILE(rf(i) < outer.and. i < ier-1)

     term= exp(-(rf(i)-mean)**2/(2.0*sd*sd))/sqrt(2.0*pi*sd*sd)
     integral = term*2.0*pi*rf(i)*(rf(i+1)-rf(i))
     i=i+1
  ENDDO
  out = i

!  print*, 'Integral is ', integral

! Now add integral to sigmadot

  DO i=in,out
     term =  exp(-(rf(i)-mean)**2/(2.0*sd*sd))/sqrt(2.0*pi*sd*sd)
     sigdot_accrete(i) = sigdot_accrete(i)+mdot_init*term/integral
  ENDDO

return
end subroutine setup_accrete


module ArrayReadersMF5Module

  use ConstantsModule,   only: LINELENGTH, LENBIGLINE, LENBOUNDNAME, &
                               NAMEDBOUNDFLAG, LINELENGTH, DZERO
  use InputOutputModule, only: openfile, u8rdcom, urword, ucolno, ulaprw
  use KindModule,        only: DP, I4B
  use OpenSpecModule,    only: ACCESS, FORM
  use SimModule,         only: store_error, ustop, store_error_unit, &
                               store_error_filename

  implicit none

  private
  public :: ReadArray
  public :: u1ddbl, u1dint, u2ddbl, u2dint, u3ddbl, u3dint

  interface ReadArray
    module procedure u1ddbl, u1dint, u2ddbl, u2dint, u3ddbl, u3dint, &
                     u1ddbl_3darg, u1dint_3darg, u2dint_1darg, &
                     u3dint_1darg, u2ddbl_1darg, u3ddbl_1darg
  end interface ReadArray

! -- Integer array readers
! subroutine u1dint(ia,aname,jj,in,iout)        ! ia is a 1-D array
! subroutine u1dint_3darg(ia,aname,jj,in,iout)  ! ia is a 3-D array to be read as a 1-D data set
! subroutine u2dint(ia,aname,ii,jj,k,in,iout)              ! ia is a 2-D array to be read as a 1-D data set
! subroutine u2dint_1darg(ia, aname, ii, jj, k, in, iout)  ! ia is a 1-D array to be read as a 1-D data set
! subroutine u3dint(iin,iout,nlay,nrow,ncol,neq,ival,cval)

! -- Real array readers
! subroutine u1ddbl(a,aname,jj,in,iout)         ! a is a 1-D array
! subroutine u1ddbl_3darg(a,aname,jj,in,iout)   ! a is a 3-D array to be read as a 1-D data set
! subroutine u2ddbl(a,aname,ii,jj,k,in,iout)        ! a is a 2-D array to be read as a 1-D data set
! subroutine u2ddbl_1darg(a,aname,ii,jj,k,in,iout)  ! a is a 1-D array to be read as a 1-D data set
! subroutine u3ddbl(iin,iout,nlay,nrow,ncol,neq,rval,cval)       ! rval is a 3-D array to be read as a 1-D data set
! subroutine u3ddbl_1darg(iin,iout,nlay,nrow,ncol,neq,rval,cval) ! rval is a 1-D array to be read as a 1-D data set

contains

  subroutine u1ddbl_3darg(a,aname,jj,in,iout)
    ! Wrapper for u1ddbl to allow array argument
    ! of ReadArray interface to be 3-D.
    ! dummy
    integer,                     intent(in)    :: jj
    real(DP), dimension(jj,1,1), intent(inout) :: a
    character(len=24),           intent(inout) :: aname
    integer,                     intent(in)    :: in, iout
    !
    call u1ddbl(a,aname,jj,in,iout)
    !
    return
  end subroutine u1ddbl_3darg

  subroutine u1ddbl(a,aname,jj,in,iout)
!   ******************************************************************
!   ROUTINE TO INPUT 1-D REAL DATA MATRICES
!     A IS ARRAY TO INPUT
!     ANAME IS 24 CHARACTER DESCRIPTION OF A
!     JJ IS NO. OF ELEMENTS
!     IN IS INPUT UNIT
!     IOUT IS OUTPUT UNIT
!   ******************************************************************
!
!   SPECIFICATIONS:
!   ------------------------------------------------------------------
    ! dummy
    integer, intent(in)                    :: jj
    real(DP), dimension(jj), intent(inout) :: a
    character(len=24), intent(in)          :: aname
    integer, intent(in)                    :: in, iout
    ! local
    integer :: iclose, icol, ierr, ifree, iprn, istart, istop, j, locat, n
    real(DP) :: r, cnstnt
    character(len=20) :: fmtin
    character(len=200) :: cntrl
    character(len=200) :: fname
    character(len=linelength) :: ermsg
    integer, parameter :: nunopn=99
    ! formats
    1 format(i10,f10.0,a20,i10)
    3 format(1x,/1x,a,' =',1p,g14.6)
    5 format(1x,///11x,a,/ &
             1X,'READING ON UNIT ',I4,' WITH FORMAT: ',A20)
    502 format(' ERROR READING ARRAY CONTROL RECORD FOR ',A,':')
    1001 format((1x,1pg12.5,9(1x,g12.5)))
    1002 format((1x,1pg12.5,4(1x,g12.5)))
!   ------------------------------------------------------------------
!
!C1------READ ARRAY CONTROL RECORD AS CHARACTER DATA.
    call u8rdcom(in,iout,cntrl,ierr)
!
!C2------LOOK FOR ALPHABETIC WORD THAT INDICATES THAT THE RECORD IS FREE
!C2------FORMAT.  SET A FLAG SPECIFYING IF FREE FORMAT OR FIXED FORMAT.
    iclose = 0
    ifree = 1
    icol = 1
    call urword(cntrl,icol,istart,istop,1,n,r,iout,in)
    if (cntrl(istart:istop).eq.'CONSTANT') then
      locat = 0
    elseif (cntrl(istart:istop).eq.'INTERNAL') then
      locat = in
    elseif (cntrl(istart:istop).eq.'EXTERNAL') then
      write(ermsg, *) 'Error. EXTERNAL arrays not supported in MODFLOW 6.'
      call store_error(ermsg)
      write(ermsg, *) 'Use OPEN/CLOSE instead.'
      call store_error(ermsg)
      call store_error_unit(in)
      call ustop()
    elseif (cntrl(istart:istop).eq.'OPEN/CLOSE') then
      call urword(cntrl,icol,istart,istop,0,n,r,iout,in)
      fname = cntrl(istart:istop)
      locat = nunopn
      call openfile(locat, iout, fname, 'OPEN/CLOSE')
      iclose=1
    else
      write(ermsg, *) 'ERROR READING CONTROL RECORD FOR ' //                 &
                       trim(adjustl(aname))
      call store_error(ermsg)
      call store_error(trim(adjustl(cntrl)))
      write(ermsg, *) 'Use CONSTANT, INTERNAL, or OPEN/CLOSE.'
      call store_error(ermsg)
      call store_error_unit(in)
      call ustop()
!
!C2A-----DID NOT FIND A RECOGNIZED WORD, SO NOT USING FREE FORMAT.
!C2A-----READ THE CONTROL RECORD THE ORIGINAL WAY.
      ifree = 0
      read(cntrl,1,err=500) locat,cnstnt,fmtin,iprn
    endif
!
!C3------FOR FREE FORMAT CONTROL RECORD, READ REMAINING FIELDS.
    if (ifree.ne.0) then
      call urword(cntrl,icol,istart,istop,3,n,cnstnt,iout,in)
      if (locat.gt.0) then
        call urword(cntrl,icol,istart,istop,1,n,r,iout,in)
        fmtin = cntrl(istart:istop)
        call urword(cntrl,icol,istart,istop,2,iprn,r,iout,in)
      endif
    endif
!
!C4------TEST LOCAT TO SEE HOW TO DEFINE ARRAY VALUES.
    if (locat.le.0) then
!
!C4A-----LOCAT <0 OR =0; SET ALL ARRAY VALUES EQUAL TO CNSTNT. RETURN.
      do j=1,jj
        a(j) = cnstnt
      enddo
      if (iout>0) write(iout,3) aname,cnstnt
      return
    endif
!
!C4B-----LOCAT>0; READ FORMATTED RECORDS USING FORMAT FMTIN.
    if (iout>0) write(iout,5) aname,locat,fmtin
    if (fmtin.eq.'(FREE)') then
      read(locat,*) (a(j),j=1,jj)
    else
      read(locat,fmtin) (a(j),j=1,jj)
    endif
    if (iclose.ne.0) close(unit=locat)
!
!C5------IF CNSTNT NOT ZERO THEN MULTIPLY ARRAY VALUES BY CNSTNT.
    if (cnstnt.eq.DZERO) go to 120
    do j=1,jj
      a(j)=a(j)*cnstnt
    enddo
!
!C6------IF PRINT CODE (IPRN) =0 OR >0 THEN PRINT ARRAY VALUES.
    120 continue
    if (iout>0) then
      if (iprn.eq.0) then
        write(iout,1001) (a(j),j=1,jj)
      elseif (iprn.gt.0) then
        write(iout,1002) (a(j),j=1,jj)
      endif
    endif
!
!C7------RETURN
    return
!C
!C8------CONTROL RECORD ERROR.
    500 continue
    write(ermsg,502) aname
    call store_error(ermsg)
    write(ermsg,'(1x,a)') cntrl
    call store_error(ermsg)
    call store_error_unit(in)
    call ustop()
  end subroutine u1ddbl

  subroutine u1dint_3darg(a,aname,jj,in,iout)
    ! Wrapper for u1dint to allow array argument
    ! of ReadArray interface to be 3-D.
    ! dummy
    integer,                         intent(in)    :: jj
    integer(I4B), dimension(jj,1,1), intent(inout) :: a
    character(len=24),               intent(inout) :: aname
    integer,                         intent(in)    :: in, iout
    !
    call u1dint(a,aname,jj,in,iout)
    !
    return
  end subroutine u1dint_3darg

  subroutine u1dint(ia,aname,jj,in,iout)
!   ******************************************************************
!   ROUTINE TO INPUT 1-D REAL DATA MATRICES
!     A IS ARRAY TO INPUT
!     ANAME IS 24 CHARACTER DESCRIPTION OF A
!     JJ IS NO. OF ELEMENTS
!     IN IS INPUT UNIT
!     IOUT IS OUTPUT UNIT
!   ******************************************************************
!
!      SPECIFICATIONS:
!   ------------------------------------------------------------------
    ! dummy
    integer, intent(in) :: jj
    integer, dimension(jj), intent(inout) :: ia
    character(len=24) :: aname
    integer, intent(in) :: in, iout
    ! local
    integer :: iclose, icnstnt, icol, ierr, ifree, iprn, istart, istop, j, n, &
               locat
    real(DP) :: r
    character(len=20) :: fmtin
    character(len=200) :: cntrl
    character(len=200) :: fname
    character(len=linelength) :: ermsg
    integer, parameter :: nunopn=99
    ! formats
    1 format(i10,i10.0,a20,i10)
    3 format(1x,/1x,a,' =',1p,i10)
    5 format(1X,///11X,A,/ &
            1X,'READING ON UNIT ',I4,' WITH FORMAT: ',A20)
    502 format(' ERROR READING ARRAY CONTROL RECORD FOR ',A,':')
    1001 format(20(1x,i9))
    1002 format(8(1x,i9))
!   ------------------------------------------------------------------
!
!C1------READ ARRAY CONTROL RECORD AS CHARACTER DATA.
    call u8rdcom(in,iout,cntrl,ierr)
!C
!C2------LOOK FOR ALPHABETIC WORD THAT INDICATES THAT THE RECORD IS FREE
!C2------FORMAT.  SET A FLAG SPECIFYING IF FREE FORMAT OR FIXED FORMAT.
    iclose=0
    ifree=1
    icol=1
    call urword(cntrl,icol,istart,istop,1,n,r,iout,in)
    if (cntrl(istart:istop).eq.'CONSTANT') then
      locat=0
    elseif (cntrl(istart:istop).eq.'INTERNAL') then
      locat=in
    elseif (cntrl(istart:istop).eq.'EXTERNAL') then
      write(ermsg, *) 'Error. EXTERNAL arrays not supported in MODFLOW 6.'
      call store_error(ermsg)
      write(ermsg, *) 'Use OPEN/CLOSE instead.'
      call store_error(ermsg)
      call store_error_unit(in)
      call ustop()
    elseif (cntrl(istart:istop).eq.'OPEN/CLOSE') then
      call urword(cntrl,icol,istart,istop,0,n,r,iout,in)
      fname=cntrl(istart:istop)
      locat=nunopn
      call openfile(locat, iout, fname, 'OPEN/CLOSE')
      iclose=1
    else
      write(ermsg, *) 'ERROR READING CONTROL RECORD FOR ' //                 &
                       trim(adjustl(aname))
      call store_error(ermsg)
      call store_error(trim(adjustl(cntrl)))
      write(ermsg, *) 'Use CONSTANT, INTERNAL, or OPEN/CLOSE.'
      call store_error(ermsg)
      call store_error_unit(in)
      call ustop()
!C
!C2A-----DID NOT FIND A RECOGNIZED WORD, SO NOT USING FREE FORMAT.
!C2A-----READ THE CONTROL RECORD THE ORIGINAL WAY.
      ifree=0
      read(cntrl,1,err=500) locat,icnstnt,fmtin,iprn
    endif
!C
!C3------FOR FREE FORMAT CONTROL RECORD, READ REMAINING FIELDS.
    if (ifree.ne.0) then
      call urword(cntrl,icol,istart,istop,2,icnstnt,r,iout,in)
      if (locat.gt.0) then
        call urword(cntrl,icol,istart,istop,1,n,r,iout,in)
        fmtin=cntrl(istart:istop)
        call urword(cntrl,icol,istart,istop,2,iprn,r,iout,in)
      endif
    endif
!c
!c4------test locat to see how to define array values.
    if (locat.le.0) then
!C
!C4A-----LOCAT <0 OR =0; SET ALL ARRAY VALUES EQUAL TO ICNSTNT. RETURN.
      do j=1,jj
        ia(j)=icnstnt
      enddo
      if (iout>0) write(iout,3) aname,icnstnt
      return
    endif
!C
!C4B-----LOCAT>0; READ FORMATTED RECORDS USING FORMAT FMTIN.
    if (iout>0) write(iout,5) aname,locat,fmtin
    if (fmtin.eq.'(FREE)') then
      read(locat,*) (ia(j),j=1,jj)
    else
      read(locat,fmtin) (ia(j),j=1,jj)
    endif
    if (iclose.ne.0) close(unit=locat)
!C
!C5------IF ICNSTNT NOT ZERO THEN MULTIPLY ARRAY VALUES BY ICNSTNT.
    if (icnstnt.ne.0) then
      do j=1,jj
        ia(j)=ia(j)*icnstnt
      enddo
    endif
!C
!C6------IF PRINT CODE (IPRN) =0 OR >0 THEN PRINT ARRAY VALUES.
    if (iout>0) then
      if (iprn.eq.0) then
        write(iout,1001) (ia(j),j=1,jj)
      elseif (iprn.gt.0) then
        write(iout,1002) (ia(j),j=1,jj)
      endif
    endif
!C
!C7------RETURN
    return
!C
!C8------CONTROL RECORD ERROR.
    500 continue
    write(ermsg,502) aname
    call store_error(ermsg)
    write(ermsg,'(1x,a)') cntrl
    call store_error(ermsg)
    call store_error_unit(in)
    call ustop()
  end subroutine u1dint

  subroutine u2ddbl_1darg(a,aname,ii,jj,k,in,iout)
    ! dummy
    real(DP),dimension(jj*ii), intent(inout) :: a
    character(len=24), intent(in) :: aname
    integer, intent(in) :: ii, jj, k, in, iout
    !
    call u2ddbl(a, aname, ii, jj, k, in, iout)
    !
    return
  end subroutine u2ddbl_1darg

  subroutine u2ddbl(a,aname,ii,jj,k,in,iout)
! ******************************************************************
! ROUTINE TO INPUT 2-D DOUBLE PRECISION DATA MATRICES
!   A IS ARRAY TO INPUT
!   ANAME IS 24 CHARACTER DESCRIPTION OF A
!   II IS NO. OF ROWS
!   JJ IS NO. OF COLS
!   K IS LAYER NO. (USED WITH NAME TO TITLE PRINTOUT --)
!          IF K=0, NO LAYER IS PRINTED
!          IF K<0, CROSS SECTION IS PRINTED)
!   IN IS INPUT UNIT
!   IOUT IS OUTPUT UNIT
! ******************************************************************
!
!    SPECIFICATIONS:
! ------------------------------------------------------------------
    ! dummy
    real(DP),dimension(jj,ii), intent(inout) :: a
    character(len=24), intent(in) :: aname
    integer, intent(in) :: ii, jj, k, in, iout
    ! local
    integer :: i, j, iclose, icol, ierr, ifree, ilay, iprn, istart, istop, &
               kper, kstp, locat, n, ncol, nrow
    real(DP) :: r, cnstnt, pertim, totim
    character(len=20) :: fmtin
    character(len=200) :: cntrl
    character(len=16) :: text
    character(len=200) :: fname
    character(len=20) :: ftype
    character(len=linelength) :: ermsg
    integer, parameter :: nunopn=99
    ! formats
    2 format(1x,/1x,a,' =',1p,g14.6,' FOR LAYER',i4)
    3 format(1x,/1x,a,' =',1p,g14.6)
    94 format(1x,///11x,a,' FOR LAYER',I4,/ &
              1X,'READING ON UNIT ',I4,' WITH FORMAT: ',A)
    95 format(1x,///11x,a,/ &
              1x,'READING ON UNIT ',I4,' WITH FORMAT: ',A)
    96 format(1x,///11x,a,' FOR CROSS SECTION',/ &
              1X,'READING ON UNIT ',I4,' WITH FORMAT: ',a)
    201 format(1x,///11x,a,' FOR LAYER',i4,/ &
               1X,'READING BINARY ON UNIT ',i4)
    202 format(1x,///1x,a,/ &
               1x,'READING BINARY ON UNIT ',I4)
    203 format(1x,///1x,a,' FOR CROSS SECTION',/ &
               1X,'READING BINARY ON UNIT ',i4)
    501 format(' ERROR READING ARRAY CONTROL RECORD FOR ',A, &
               ' FOR LAYER',i4,':')
    502 format(' ERROR READING ARRAY CONTROL RECORD FOR ',A,':')
!     ------------------------------------------------------------------
!
!C1------READ ARRAY CONTROL RECORD AS CHARACTER DATA.
    call u8rdcom(in,iout,cntrl,ierr)
!
!C2------LOOK FOR ALPHABETIC WORD THAT INDICATES THAT THE RECORD IS FREE
!C2------FORMAT.  SET A FLAG SPECIFYING IF FREE FORMAT OR FIXED FORMAT.
    iclose=0
    ifree=1
    icol=1
    call urword(cntrl,icol,istart,istop,1,n,r,iout,in)
    if (cntrl(istart:istop).eq.'CONSTANT') then
      locat=0
    elseif (cntrl(istart:istop).eq.'INTERNAL') then
      locat=in
    elseif (cntrl(istart:istop).eq.'EXTERNAL') then
      write(ermsg, *) 'Error. EXTERNAL arrays not supported in MODFLOW 6.'
      call store_error(ermsg)
      write(ermsg, *) 'Use OPEN/CLOSE instead.'
      call store_error(ermsg)
      call store_error_unit(in)
      call ustop()
    elseif (cntrl(istart:istop).eq.'OPEN/CLOSE') then
      call urword(cntrl,icol,istart,istop,0,n,r,iout,in)
      fname=cntrl(istart:istop)
      locat=nunopn
      iclose=1
      ftype = 'OPEN/CLOSE'
    else
      write(ermsg, *) 'ERROR READING CONTROL RECORD FOR ' //                 &
                       trim(adjustl(aname))
      call store_error(ermsg)
      call store_error(trim(adjustl(cntrl)))
      write(ermsg, *) 'Use CONSTANT, INTERNAL, or OPEN/CLOSE.'
      call store_error(ermsg)
      call store_error_unit(in)
      call ustop()
    endif
!
!C3------FOR FREE FORMAT CONTROL RECORD, READ REMAINING FIELDS.
    if (ifree.ne.0) then
      call urword(cntrl,icol,istart,istop,3,n,cnstnt,iout,in)
      if (locat.ne.0) then
        call urword(cntrl,icol,istart,istop,1,n,r,iout,in)
        fmtin=cntrl(istart:istop)
        if (iclose.ne.0) then
          if (fmtin.eq.'(BINARY)') then
            call openfile(locat, iout, fname, ftype, fmtarg_opt=FORM,    &
                          accarg_opt=ACCESS)
          else
            call openfile(locat, iout, fname, ftype)
          endif
        endif
        if (locat.gt.0 .and. fmtin.eq.'(BINARY)') locat=-locat
        call urword(cntrl,icol,istart,istop,2,iprn,r,iout,in)
      endif
    endif
!
!C4------TEST LOCAT TO SEE HOW TO DEFINE ARRAY VALUES.
    if (locat.eq.0) then
!
!C4A-----LOCAT=0; SET ALL ARRAY VALUES EQUAL TO CNSTNT. RETURN.
      do i=1,ii
        do j=1,jj
          a(j,i)=cnstnt
        enddo
      enddo
      if (k.gt.0 .and. iout>0) write(iout,2) aname,cnstnt,k
      if (k.le.0 .and. iout>0) write(iout,3) aname,cnstnt
      return
    elseif (locat.gt.0) then
!
!C4B-----LOCAT>0; READ FORMATTED RECORDS USING FORMAT FMTIN.
        if (iout>0) then
          if (k.gt.0) then
            write(iout,94) aname,k,locat,fmtin
          elseif (k.eq.0) then
            write(iout,95) aname,locat,fmtin
          else
            write(iout,96) aname,locat,fmtin
          endif
        endif
        do i=1,ii
          if (fmtin.eq.'(FREE)') then
            read(locat,*) (a(j,i),j=1,jj)
          else
            read(locat,fmtin) (a(j,i),j=1,jj)
          endif
        enddo
      else
!
!C4C-----LOCAT<0; READ UNFORMATTED ARRAY VALUES.
        locat=-locat
        if (iout>0) then
          if (k.gt.0) then
            write(iout,201) aname,k,locat
          elseif (k.eq.0) then
            write(iout,202) aname,locat
          else
            write(iout,203) aname,locat
          endif
        endif
        read(locat) kstp,kper,pertim,totim,text,ncol,nrow,ilay
        read(locat) a
      endif
!
!C5------IF CNSTNT NOT ZERO THEN MULTIPLY ARRAY VALUES BY CNSTNT.
      if (iclose.ne.0) close(unit=locat)
      if (cnstnt.ne.DZERO) then
        do i=1,ii
          do j=1,jj
            a(j,i)=a(j,i)*cnstnt
          enddo
        enddo
      endif
!
!C6------IF PRINT CODE (IPRN) >0 OR =0 THEN PRINT ARRAY VALUES.
!  320 continue
      if (iprn.ge.0) call ulaprw(a,aname,0,0,jj,ii,0,iprn,iout)
!
!C7------RETURN
      return
!
!C8------CONTROL RECORD ERROR.
      if (k.gt.0) then
        write(ermsg,501) aname,k
      else
        write(ermsg,502) aname
      endif
      call store_error(ermsg)
      write(ermsg,'(1x,a)') cntrl
      call store_error(ermsg)
      call store_error_unit(in)
      call ustop()
  end subroutine u2ddbl

  subroutine u2dint_1darg(ia, aname, ii, jj, k, in, iout)
    ! dummy
    character(len=24),         intent(in) :: aname
    integer, dimension(jj*ii), intent(inout) :: ia
    integer,                   intent(in) :: ii, jj, k, in, iout
    !
    call u2dint(ia, aname, ii, jj, k, in, iout)
    !
    return
  end subroutine u2dint_1darg

  subroutine u2dint(ia,aname,ii,jj,k,in,iout)
! ******************************************************************
! ROUTINE TO INPUT 2-D INTEGER DATA MATRICES
!   IA IS ARRAY TO INPUT
!   ANAME IS 24 CHARACTER DESCRIPTION OF IA
!   II IS NO. OF ROWS
!   JJ IS NO. OF COLS
!   K IS LAYER NO. (USED WITH NAME TO TITLE PRINTOUT --
!          IF K=0, NO LAYER IS PRINTED
!          IF K<0, CROSS SECTION IS PRINTED)
!   IN IS INPUT UNIT
!   IOUT IS OUTPUT UNIT
! ******************************************************************
!
!    SPECIFICATIONS:
! ------------------------------------------------------------------
    ! dummy
    character(len=24), intent(in) :: aname
    integer, dimension(jj,ii), intent(inout) :: ia
    integer, intent(in) :: ii, jj, k, in, iout
    ! local
    integer :: i, j, iclose, icol, iconst, ierr, ifree, iprn, istart, &
               istop, locat, n
    real(DP) :: r
    character(len=20) :: fmtin
    character(len=200) :: cntrl
    character(len=200) :: fname
    character(len=20) :: ftype
    character(len=LINELENGTH) :: ermsg
    integer, parameter :: NUNOPN=99
    ! formats
    1 format(i10,i10,a20,i10)
    82 format(1x,/1x,a,' =',i15,' FOR LAYER',i4)
    83 format(1x,/1x,a,' =',i15)
    94 format(1x,///11x,a,' FOR LAYER',i4,/ &
              1x,'READING ON UNIT ',i4,' WITH FORMAT: ',a)
    95 format(1x,///11x,a,/ &
              1x,'READING ON UNIT ',I4,' WITH FORMAT: ',a)
    96 format(1x,///11x,a,' FOR CROSS SECTION',/ &
              1X,'READING ON UNIT ',i4,' WITH FORMAT: ',a)
    201 format(1x,///11x,a,' FOR LAYER',i4,/ &
               1X,'READING BINARY ON UNIT ',i4)
    202 format(1x,///11x,a,/ &
               1x,'READING BINARY ON UNIT ',i4)
    203 format(1x,///11x,a,' FOR CROSS SECTION',/ &
               1x,'READING BINARY ON UNIT ',i4)
    551 format(1x,i3,1x,60(1x,i1):/(5x,60(1x,i1)))
    552 format(1x,i3,1x,40(1x,i2):/(5x,40(1x,i2)))
    553 format(1x,i3,1x,30(1x,i3):/(5x,30(1x,i3)))
    554 format(1x,i3,1x,25(1x,i4):/(5x,25(1x,i4)))
    555 format(1x,i3,1x,20(1x,i5):/(5x,20(1x,i5)))
    556 format(1x,i3,1x,10(1x,i11):/(5x,10(1x,i11)))
    557 format(1x,i3,1x,25(1x,i2):/(5x,25(1x,i2)))
    558 format(1x,i3,1x,15(1x,i4):/(5x,15(1x,i4)))
    559 format(1x,i3,1x,10(1x,i6):/(5x,10(1x,i6)))
    601 format(' ERROR READING ARRAY CONTROL RECORD FOR ',a, &
               ' FOR LAYER',i4,':')
    602 format(' ERROR READING ARRAY CONTROL RECORD FOR ',a,':')
!     ------------------------------------------------------------------
!
!C1------READ ARRAY CONTROL RECORD AS CHARACTER DATA.
    call u8rdcom(in,iout,cntrl,ierr)
!
!C2------LOOK FOR ALPHABETIC WORD THAT INDICATES THAT THE RECORD IS FREE
!C2------FORMAT.  SET A FLAG SPECIFYING IF FREE FORMAT OR FIXED FORMAT.
    iclose=0
    ifree=1
    icol=1
    call urword(cntrl,icol,istart,istop,1,n,r,iout,in)
    if (cntrl(istart:istop).eq.'CONSTANT') then
      locat=0
    elseif (cntrl(istart:istop).eq.'INTERNAL') then
      locat=in
    elseif (cntrl(istart:istop).eq.'EXTERNAL') then
      write(ermsg, *) 'Error. EXTERNAL arrays not supported in MODFLOW 6.'
      call store_error(ermsg)
      write(ermsg, *) 'Use OPEN/CLOSE instead.'
      call store_error(ermsg)
      call store_error_unit(in)
      call ustop()
    elseif (cntrl(istart:istop).eq.'OPEN/CLOSE') then
      call urword(cntrl,icol,istart,istop,0,n,r,iout,in)
      fname=cntrl(istart:istop)
      locat=nunopn
      iclose=1
      ftype = 'OPEN/CLOSE'
    else
      write(ermsg, *) 'ERROR READING CONTROL RECORD FOR ' //                 &
                       trim(adjustl(aname))
      call store_error(ermsg)
      call store_error(trim(adjustl(cntrl)))
      write(ermsg, *) 'Use CONSTANT, INTERNAL, or OPEN/CLOSE.'
      call store_error(ermsg)
      call store_error_unit(in)
      call ustop()
!
!C2A-----DID NOT FIND A RECOGNIZED WORD, SO NOT USING FREE FORMAT.
!C2A-----READ THE CONTROL RECORD THE ORIGINAL WAY.
      ifree=0
      read(cntrl,1,err=600) locat,iconst,fmtin,iprn
    endif
!
!C3------FOR FREE FORMAT CONTROL RECORD, READ REMAINING FIELDS.
    if (ifree.ne.0) then
      call urword(cntrl,icol,istart,istop,2,iconst,r,iout,in)
      if (locat.ne.0) then
        call urword(cntrl,icol,istart,istop,1,n,r,iout,in)
        fmtin=cntrl(istart:istop)
        if (iclose.ne.0) then
          if (fmtin.eq.'(BINARY)') then
            call openfile(locat, iout, fname, ftype, fmtarg_opt=FORM,    &
                          accarg_opt=ACCESS)
          else
                call openfile(locat, iout, fname, 'OPEN/CLOSE')
             endif
          endif
          if (locat.gt.0 .and. fmtin.eq.'(BINARY)') locat=-locat
          call urword(cntrl,icol,istart,istop,2,iprn,r,iout,in)
       endif
    endif
!
!C4------TEST LOCAT TO SEE HOW TO DEFINE ARRAY VALUES.
    if (locat.eq.0) then
!
!C4A-----LOCAT=0; SET ALL ARRAY VALUES EQUAL TO ICONST. RETURN.
      do i=1,ii
        do j=1,jj
          ia(j,i)=iconst
        enddo
      enddo
      if (k.gt.0 .and. iout>0) write(iout,82) aname,iconst,k
      if (k.le.0 .and. iout>0) write(iout,83) aname,iconst
      return
    elseif (locat.gt.0) then
!
!C4B-----LOCAT>0; READ FORMATTED RECORDS USING FORMAT FMTIN.
      if (iout>0) then
        if (k.gt.0) then
           write(iout,94) aname,k,locat,fmtin
           elseif (k.eq.0) then
              write(iout,95) aname,locat,fmtin
           else
              write(iout,96) aname,locat,fmtin
           endif
        endif
        do i=1,ii
          if (fmtin.eq.'(FREE)') then
             read(locat,*) (ia(j,i),j=1,jj)
          else
             read(locat,fmtin) (ia(j,i),j=1,jj)
          endif
        enddo
      else
!
!C4C-----LOCAT<0; READ UNFORMATTED RECORD CONTAINING ARRAY VALUES.
        locat=-locat
        if (iout>0) then
          if (k.gt.0) then
            write(iout,201) aname,k,locat
          elseif (k.eq.0) then
            write(iout,202) aname,locat
          else
            write(iout,203) aname,locat
          endif
        endif
        read(locat)
        read(locat) ia
      endif
!
!C5------IF ICONST NOT ZERO THEN MULTIPLY ARRAY VALUES BY ICONST.
      if (iclose.ne.0) close(unit=locat)
      if (iconst.ne.0) then
        do i=1,ii
          do j=1,jj
            ia(j,i)=ia(j,i)*iconst
          enddo
        enddo
      endif
!
!C6------IF PRINT CODE (IPRN) <0 THEN RETURN.
      if (iprn.lt.0) return
!
!C7------PRINT COLUMN NUMBERS AT TOP OF PAGE.
      if (iout>0) then
        if (iprn.gt.9 .or. iprn.eq.0) iprn=6
        select case (iprn)
        case (401)
          call ucolno(1,jj,4,60,2,iout)
        case (402)
          call ucolno(1,jj,4,40,3,iout)
        case (403)
          call ucolno(1,jj,4,30,4,iout)
        case (404)
          call ucolno(1,jj,4,25,5,iout)
        case (405)
          call ucolno(1,jj,4,20,6,iout)
        case (406)
          call ucolno(1,jj,4,10,12,iout)
        case (407)
          call ucolno(1,jj,4,25,3,iout)
        case (408)
          call ucolno(1,jj,4,15,5,iout)
        case (409)
          call ucolno(1,jj,4,10,7,iout)
        end select
!
!C8------PRINT EACH ROW IN THE ARRAY.
        do i=1,ii
          select case (iprn)
          case (501)
  !----------------FORMAT 60I1
            write(iout,551) i,(ia(j,i),j=1,jj)
          case (502)
  !----------------FORMAT 40I2
            write(iout,552) i,(ia(j,i),j=1,jj)
          case (503)
  !----------------FORMAT 30I3
            write(iout,553) i,(ia(j,i),j=1,jj)
          case (504)
  !----------------FORMAT 25I4
            write(iout,554) i,(ia(j,i),j=1,jj)
          case (505)
  !----------------FORMAT 20I5
            write(iout,555) i,(ia(j,i),j=1,jj)
          case (506)
  !----------------FORMAT 10I11
            write(iout,556) i,(ia(j,i),j=1,jj)
          case (507)
  !----------------FORMAT 25I2
            write(iout,557) i,(ia(j,i),j=1,jj)
          case (508)
  !----------------FORMAT 15I4
            write(iout,558) i,(ia(j,i),j=1,jj)
          case (509)
  !----------------FORMAT 10I6
            write(iout,559) i,(ia(j,i),j=1,jj)
          end select
        enddo
      endif
!
!C9------RETURN
      return
!
!C10-----CONTROL RECORD ERROR.
  600 if (k.gt.0) then
        write(ermsg,601) aname,k
      else
        write(ermsg,602) aname
      endif
      call store_error(ermsg)
      write(ermsg,'(1x,a)') cntrl
      call store_error(ermsg)
      call store_error_unit(in)
      call ustop()
  end subroutine u2dint

  subroutine u3dint_1darg(iin,iout,nlay,nrow,ncol,neq,ival,cval)
    ! dummy
    integer(I4B), intent(in) :: iin
    integer(I4B), intent(in) :: iout
    integer(I4B), intent(in) :: nlay
    integer(I4B), intent(in) :: nrow
    integer(I4B), intent(in) :: ncol
    integer(I4B), intent(in) :: neq
    integer(I4B), dimension(ncol*nrow*nlay), intent(inout) :: ival
    character (len=24), intent(in) :: cval
    !
    call u3dint(iin, iout, nlay, nrow, ncol, neq, ival, cval)
    !
    return
  end subroutine u3dint_1darg

  subroutine u3dint(iin,iout,nlay,nrow,ncol,neq,ival,cval)
! ******************************************************************************
! Read three-dimensional integer array, consisting of multiple 2d arrays with
! array headers.
! ******************************************************************************
!
!    SPECIFICATIONS:
! ------------------------------------------------------------------------------
    implicit none
    integer(I4B), intent(in) :: iin
    integer(I4B), intent(in) :: iout
    integer(I4B), intent(in) :: nlay
    integer(I4B), intent(in) :: nrow
    integer(I4B), intent(in) :: ncol
    integer(I4B), intent(in) :: neq
    integer(I4B), dimension(ncol,nrow,nlay), intent(inout) :: ival
    character (len=24), intent(in) :: cval
    !local
    integer(I4B) :: k
    !functions
! ------------------------------------------------------------------------------
    !code
    do k = 1, nlay
      call u2dint(ival(:,:,k), cval, nrow, ncol, k, iin, iout)
    enddo
    return
  end subroutine u3dint

  subroutine u3ddbl_1darg(iin,iout,nlay,nrow,ncol,neq,rval,cval)
    ! dummy
    integer(I4B), intent(in) :: iin
    integer(I4B), intent(in) :: iout
    integer(I4B), intent(in) :: nlay
    integer(I4B), intent(in) :: nrow
    integer(I4B), intent(in) :: ncol
    integer(I4B), intent(in) :: neq
    real(DP), dimension(ncol*nrow*nlay), intent(inout) :: rval
    character (len=24), intent(in) :: cval
    !
    call u3ddbl(iin, iout, nlay, nrow, ncol, neq, rval, cval)
    !
    return
  end subroutine u3ddbl_1darg

  subroutine u3ddbl(iin,iout,nlay,nrow,ncol,neq,rval,cval)
! ******************************************************************************
! Read three-dimensional double-precision array, consisting of multiple 2d
! arrays with array headers.
! ******************************************************************************
!
!    SPECIFICATIONS:
! ------------------------------------------------------------------------------
    implicit none
    integer(I4B), intent(in) :: iin
    integer(I4B), intent(in) :: iout
    integer(I4B), intent(in) :: nlay
    integer(I4B), intent(in) :: nrow
    integer(I4B), intent(in) :: ncol
    integer(I4B), intent(in) :: neq
    real(DP), dimension(ncol,nrow,nlay), intent(inout) :: rval
    character (len=24), intent(in) :: cval
    !local
    integer(I4B) :: k
    !functions
! ------------------------------------------------------------------------------
    !code
!    istart = 1
!    istop = ncol * nrow
    do k = 1, nlay
      call u2ddbl(rval(:,:,k),cval,nrow,ncol,k,iin,iout)
!      istart = istop + 1
!      istop = istop + ncol * nrow
    enddo
    return
  end subroutine u3ddbl

end module ArrayReadersMF5Module


text:
c***********************************************************************
c  Copyright 2006 John A. Trangenstein
c
c  This software is made available for research and instructional use
c  only.
c  You may copy and use this software without charge for these
c  non-commercial purposes, provided that the copyright notice and
c  associated text is reproduced on all copies.
c  For all other uses (including distribution of modified versions),
c  please contact the author at
c    John A. Trangenstein
c    Department of Mathematics
c    Duke University
c    Durham, NC 27708-0320
c    USA
c  or
c    johnt@math.duke.edu
c
c  This software is made available "as is" without any assurance that it
c  is completely correct, or that it will work for your purposes.
c  Use the software at your own risk.
c***********************************************************************
      subroutine fluxderv(fc,lc,ifirst,ilast,
     &  conservd,
     &  dfdu    )
c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
      include "const.i"
      include "linearad.i"
c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
      integer fc,lc,ifirst,ilast
      double precision conservd(fc:lc)
c
      double precision dfdu(fc:lc)
c
      integer ic
c     ******************************************************************
c     compute derivative of flux with respect to conserved variable
c     ******************************************************************
      do ic=ifirst,ilast
        dfdu(ic)=velocity
      enddo

      return
      end

      subroutine riemann(fs,ls,ifirst,ilast,
     &  left,right,
     &  flux)
c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
      include "linearad.i"
c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
      integer fs,ls,ifirst,ilast
c
      double precision
     &  left(fs:ls+1),
     &  right(fs:ls+1)
c
      double precision flux(fs:ls+1)
      integer ie
c     ******************************************************************
c     the following riemann solver is hard-wired for linear advection
c     with velocity > 0
c     ******************************************************************
      do ie=ifirst,ilast+1
        flux(ie)=velocity*left(ie)
      enddo
      return
      end

ext: f


text:
!==============================================================================!
  subroutine Grid_Mod_Allocate_Nodes(grid, n)
!------------------------------------------------------------------------------!
  implicit none
!---------------------------------[Arguments]----------------------------------!
  type(Grid_Type) :: grid
  integer         :: n
!==============================================================================!

  ! Store the number of nodes for the grid
  grid % n_nodes = n

  ! Allocate memory for node coordinates
  allocate(grid % xn(1:n));  grid % xn = 0.0
  allocate(grid % yn(1:n));  grid % yn = 0.0
  allocate(grid % zn(1:n));  grid % zn = 0.0

  end subroutine

max_stars_repo_name: MassimoBorrelliPhysicist/T-Flows

max_issues_repo_name: MassimoBorrelliPhysicist/T-Flows

max_forks_repo_name: MassimoBorrelliPhysicist/T-Flows


text:
! { dg-do run }
! { dg-options "-std=f2008 -fall-intrinsics" }

! PR fortran/44709
! Check that exit and cycle from within a BLOCK works for loops as expected.

! Contributed by Daniel Kraft, d@domob.eu.

PROGRAM main
  IMPLICIT NONE
  INTEGER :: i

  ! Simple exit without loop name.
  DO
    BLOCK
      EXIT
    END BLOCK
    CALL abort ()
  END DO

  ! Cycle without loop name.
  DO i = 1, 1
    BLOCK
      CYCLE
    END BLOCK
    CALL abort ()
  END DO

  ! Exit loop by name from within a BLOCK.
  loop1: DO
    DO
      BLOCK
        EXIT loop1
      END BLOCK
      CALL abort ()
    END DO
    CALL abort ()
  END DO loop1

  ! Cycle loop by name from within a BLOCK.
  loop2: DO i = 1, 1
    loop3: DO
      BLOCK
        CYCLE loop2
      END BLOCK
      CALL abort ()
    END DO loop3
    CALL abort ()
  END DO loop2
END PROGRAM main

max_stars_repo_name: maurizioabba/rose

max_issues_repo_name: sujankh/rose-matlab

max_forks_repo_name: sujankh/rose-matlab


text:
C    @(#)csread.f	20.3 2/13/96
        subroutine csread
C
C       This is a dummy routine which is substituted for a similar
C       routine in EPRI's RP1964 code.
C
        write (*, 100) 'CSREAD'
  100   format (' Dummy routine ', a, ' entered.')
        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 hspwr (u,udt,udtt,id,temp,y,z)
!!!!c     implicit double precision (a-h,o-z)                                    dp
!!!!c
!!!!c     write nodal data into hsp file
!!!!c
      use EC_OutputData

      implicit none
      integer nume,nume2
      parameter (nume=40000)
	  parameter (nume2=20000)
      common/bk02/ioofc,iphase,imass,lpar(9)
      integer ioofc,iphase,imass,lpar

      common/bk08/kprint,nstep,ite,ilimit,newstf
      integer kprint,nstep,ite,ilimit,newstf

      common/bk10/npb,nodep(2,8)
      integer npb,nodep

      common/bk14/lfna(15),lfnt(6)
      integer lfna,lfnt

      common/bk17/dn1,dn2,nwebuf,ntime,numnp,neq,ibar,mthsol
      integer nwebuf,ntime,numnp,neq,ibar,mthsol
      real dn1,dn2

      common/bk23/itemp,itherm,irtin
      integer itemp,itherm,irtin

      common/bk32/nsref,nequit,time,timep,lprint,nprint
      integer nsref,nequit,time,timep,lprint,nprint

!!	  common /pcracktip/ connect(4,nume2),node(2,nume2),penta(nume2), &
!!     	                 ndflag(2,nume2), numnpt, numeltu, ndc

      dimension u(*),udt(*),udtt(*),id(2,*),temp(*)
      dimension y(*),z(*)
      real u,udt,udtt,temp,y,z
      integer id

      real d(7),d1(2)
      integer nodeId,i,kk

!c     print displacements, velocities, and accelerations
!!!!!      do 50 ib=1,npb
      !- no need for this loop b/c it's always 1 to 1
!!!      if (startNode.eq.0) go to 50
    rNodesCoords=0

    do  nodeId=1,numnp
        d=0.0
        do  i=1,2 !-- dof at each node are located at 1,2
            kk=id(i,nodeId)
            !-- if the node has a BC then it's zero
            if (kk==0) cycle
            d(i)=u(kk)
            !-- if dynamic then do vel and accel
            if (imass==0) cycle
            d(i+2)=udt(kk)
            d(i+4)=udtt(kk)
        enddo
        if (itemp.ne.0) d(7)=temp(nodeId)
!!!!c      if (ic.gt.0) go to 30
!!!!c      ic=50
!!!!c      call header
!!!!c      write(lfnt(2),60) nstep,timep
!!!!c   30 ic=ic-1
!!!!c      write(lfnt(2),70) ii,(d(l),l=1,7)
!!!!ck----for history plot by m.k.
        d1(1)=d(1)+y(nodeId)
        d1(2)=d(2)+z(nodeId)
!!!!!c      write(29,100) nodeId,d1(1),d1(2)
        rNodesCoords(1,nodeId)=d1(1)
        rNodesCoords(2,nodeId)=d1(2)
!!!!ck----end
    enddo

!!!!!   50 continue
      return
!!!c
!!!c
!!!c   60 format(///' n o d a l   p r i n t   o u t   f o r   t i m e   s t
!!!c     1e p ',i5,31x,' ( at time ',1pe10.4,' )'/
!!!c     2/' nodal point y-displacement  z-displacement    y-velocity      z
!!!c     3-velocity  y-acceleration  z-acceleration  temperature')
!!!c   70 format (i9,7e15.4)
!!!!  100 format(i5,5x,e15.6,5x,e15.6)
      end

!!!!!!!!!!!      subroutine hspwr (u,udt,udtt,id,temp,y,z)
!!!!!!!!!!!c     implicit double precision (a-h,o-z)                                    dp
!!!!!!!!!!!c
!!!!!!!!!!!c     write nodal data into hsp file
!!!!!!!!!!!c
!!!!!!!!!!!      parameter (nume=40000)
!!!!!!!!!!!	  parameter (nume2=20000)
!!!!!!!!!!!      common/bk02/ioofc,iphase,imass,lpar(9)
!!!!!!!!!!!      common/bk08/kprint,nstep,ite,ilimit,newstf
!!!!!!!!!!!      common/bk10/npb,nodep(2,8)
!!!!!!!!!!!      common/bk14/lfna(15),lfnt(6)
!!!!!!!!!!!      common/bk17/dn1,dn2,nwebuf,ntime,numnp,neq,ibar,mthsol
!!!!!!!!!!!      common/bk23/itemp,itherm,irtin
!!!!!!!!!!!      common/bk32/nsref,nequit,time,timep,lprint,nprint
!!!!!!!!!!!	  common /pcracktip/ connect(4,nume2),node(2,nume2),penta(nume2),
!!!!!!!!!!!     >	                 ndflag(2,nume2), numnpt, numeltu, ndc
!!!!!!!!!!!
!!!!!!!!!!!      dimension u(*),udt(*),udtt(*),id(2,*),temp(*),d(7)
!!!!!!!!!!!      dimension y(*),z(*),d1(2)
!!!!!!!!!!!	  real node
!!!!!!!!!!!
!!!!!!!!!!!
!!!!!!!!!!!!	  do i=1,nume2
!!!!!!!!!!!!	      do j=1,2
!!!!!!!!!!!!		      node(j,i)=0.0
!!!!!!!!!!!!		  end do
!!!!!!!!!!!!	  end do
!!!!!!!!!!!!c
!!!!!!!!!!!!c     print displacements, velocities, and accelerations
!!!!!!!!!!!!c
!!!!!!!!!!!      ic=0
!!!!!!!!!!!      do 50 ib=1,npb
!!!!!!!!!!!      node1=nodep(1,ib)
!!!!!!!!!!!      if (node1.eq.0) go to 50
!!!!!!!!!!!      node2=nodep(2,ib)
!!!!!!!!!!!      do 40 ii=node1,node2
!!!!!!!!!!!      do 10 i=1,7
!!!!!!!!!!!   10 d(i)=0.
!!!!!!!!!!!      do 20 i=1,2
!!!!!!!!!!!      kk=id(i,ii)
!!!!!!!!!!!      if (kk.eq.0) go to 20
!!!!!!!!!!!      d(i)=u(kk)
!!!!!!!!!!!      if (imass.eq.0) go to 20
!!!!!!!!!!!      d(i+2)=udt(kk)
!!!!!!!!!!!      d(i+4)=udtt(kk)
!!!!!!!!!!!   20 continue
!!!!!!!!!!!      if (itemp.ne.0) d(7)=temp(ii)
!!!!!!!!!!!c      if (ic.gt.0) go to 30
!!!!!!!!!!!c      ic=50
!!!!!!!!!!!c      call header
!!!!!!!!!!!c      write(lfnt(2),60) nstep,timep
!!!!!!!!!!!c   30 ic=ic-1
!!!!!!!!!!!c      write(lfnt(2),70) ii,(d(l),l=1,7)
!!!!!!!!!!!ck----for history plot by m.k.
!!!!!!!!!!!          d1(1)=d(1)+y(ii)
!!!!!!!!!!!          d1(2)=d(2)+z(ii)
!!!!!!!!!!!c      write(29,100) ii,d1(1),d1(2)
!!!!!!!!!!!          node(1,ii)=d1(1)
!!!!!!!!!!!		  node(2,ii)=d1(2)
!!!!!!!!!!!ck----end
!!!!!!!!!!!   40 continue
!!!!!!!!!!!
!!!!!!!!!!!   50 continue
!!!!!!!!!!!      return
!!!!!!!!!!!c
!!!!!!!!!!!c
!!!!!!!!!!!c   60 format(///' n o d a l   p r i n t   o u t   f o r   t i m e   s t
!!!!!!!!!!!c     1e p ',i5,31x,' ( at time ',1pe10.4,' )'/
!!!!!!!!!!!c     2/' nodal point y-displacement  z-displacement    y-velocity      z
!!!!!!!!!!!c     3-velocity  y-acceleration  z-acceleration  temperature')
!!!!!!!!!!!c   70 format (i9,7e15.4)
!!!!!!!!!!!  100 format(i5,5x,e15.6,5x,e15.6)
!!!!!!!!!!!      end

max_stars_repo_name: imohame/LabCode

max_issues_repo_name: imohame/LabCode

max_forks_repo_name: imohame/LabCode


text:
Function subcr2(t, u)
  Implicit Double Precision (A-H, O-Z)
  subcr2 = 4.D0/9.D0*(t**2+u**2)
  Return
End Function subcr2

max_stars_repo_name: xiaohaijin/AMPT

max_issues_repo_name: xiaohaijin/AMPT

max_forks_repo_name: xiaohaijin/AMPT


text:
*dk,termcode
      subroutine termcode()
C
C #####################################################################
C
C     PURPOSE -
C
C        None
C
C     INPUT ARGUMENTS -
C
C        None
C
C     OUTPUT ARGUMENTS -
C
C        None
C
C     CHANGE HISTORY -
C
C        $Log: termcode.f,v $
C        Revision 2.00  2007/11/09 20:04:04  spchu
C        Import to CVS
C
CPVCS
CPVCS       Rev 1.2   Mon Apr 14 17:04:32 1997   pvcs
CPVCS    No change.
CPVCS
CPVCS       Rev 1.1   01/04/95 22:06:26   llt
CPVCS    unicos changes (made by het)
CPVCS
CPVCS       Rev 1.0   11/13/94 11:44:50   pvcs
CPVCS    Orginal Version
C
C ######################################################################
C
       implicit real*8 (a-h,o-z)
      idebug=0
      if(idebug.eq.1) print *,"In stub routine: termcode"
      stop
      end

max_forks_repo_name: daniellivingston/LaGriT


text:
! check_reals.f90 --
!     Module to check that reals are initialised
!
!     Note:
!     The routines can not be elemental, due to the pointer to "check"
!     This means that we need to add separate versions for arrays
!
module check_reals
    type checked_real
        integer, pointer :: check => null()
        real             :: value
    endtype

    integer, target, private :: check

    interface assignment(=)
        module procedure set_value_checked
        module procedure set_value_real
        module procedure set_real_checked
    end interface

    interface operator(+)
        module procedure add_checked
    end interface
contains

subroutine set_real_checked( x, y )
    real, intent(out)               :: x
    type(checked_real), intent(in)  :: y

    ! Note: because of "elemental" we can not check the state of y

    x = y%value
end subroutine set_real_checked

subroutine set_value_checked( x, y )
    type(checked_real), intent(out) :: x
    type(checked_real), intent(in)  :: y

    if ( .not. associated(x%check) ) then
        x%check => check
    endif
    if ( .not. associated(y%check) ) then
        x%check = x%check + 1
    endif

    x%value = y%value
end subroutine set_value_checked

subroutine set_value_real( x, y )
    type(checked_real), intent(out) :: x
    real, intent(in)                :: y

    if ( .not. associated(x%check) ) then
        x%check => check
    endif

    x%value = y ! No check possible
end subroutine set_value_real

type(checked_real) function add_checked( x, y )
    type(checked_real), intent(in) :: x, y

    add_checked%check => check
    add_checked%value =  x%value + y%value

    if ( .not. associated(x%check) ) then
        add_checked%check = add_checked%check + 1
    endif

    if ( .not. associated(y%check) ) then
        add_checked%check = add_checked%check + 1
    endif

end function add_checked

subroutine check_assignment( lineno, filename )
    integer :: lineno
    character(len=*) :: filename

    if ( check /= 0 ) then
        write(*,*) 'One or more uninitialised variables used at line ', &
            lineno, ' in file ', trim(filename)
    endif
    check = 0
end subroutine check_assignment

end module check_reals

max_issues_repo_name: TerribleDev/Fortran-docker-mvc

max_forks_repo_name: TerribleDev/Fortran-docker-mvc


text:
less_toxic(r1,l1).
less_toxic(j1,e1).
less_toxic(b1,l1).
less_toxic(s1,b1).
less_toxic(s1,h1).
less_toxic(k1,aa1).
less_toxic(ee1,jj1).
less_toxic(bb1,h1).
less_toxic(ll1,w1).
less_toxic(j1,t1).
less_toxic(ff1,t1).
less_toxic(u1,c1).
less_toxic(ee1,aa1).
less_toxic(m1,dd1).
less_toxic(g1,cc1).
less_toxic(x1,t1).
less_toxic(j1,aa1).
less_toxic(cc1,u1).
less_toxic(w1,l1).
less_toxic(k1,dd1).
less_toxic(ff1,jj1).
less_toxic(g1,b1).
less_toxic(kk1,v1).
less_toxic(ff1,aa1).
less_toxic(bb1,f1).
less_toxic(ff1,a1).
less_toxic(i1,d1).
less_toxic(q1,l1).
less_toxic(cc1,c1).
less_toxic(t1,f1).
less_toxic(x1,i1).
less_toxic(b1,jj1).
less_toxic(j1,cc1).
less_toxic(k1,t1).
less_toxic(ii1,jj1).
less_toxic(y1,f1).
less_toxic(m1,t1).
less_toxic(j1,d1).
less_toxic(x1,d1).
less_toxic(b1,e1).
less_toxic(b1,a1).
less_toxic(ee1,v1).
less_toxic(y1,e1).
less_toxic(ff1,f1).
less_toxic(hh1,w1).
less_toxic(g1,w1).
less_toxic(s1,c1).

max_stars_repo_name: manoelfranca/cilppp

max_issues_repo_name: manoelfranca/cilppp

max_forks_repo_name: manoelfranca/cilppp


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

         function foounfr(i)
           integer foounfr,i,j
           open(12,file='unffile1.dat', form='unformatted')
           read(12) j
!            print *, "i, j:", i,j
           foounfr=i
         end

         subroutine unfread
         integer a,b,foounfr
         integer c(3)
         character*20 writetome
         c(1) = 1
         c(2) = 2
         c(3) = 3
         a=3
         b=4
         open(10,file='unffile2.dat',form='unformatted')
         read(10) a,c(foounfr(2)),b
!          print *, "a c b", a, c, b
         if  (a .eq. 1 .and. c(1) .eq. 1 .and. c(2) .eq. 1 .and. &
             c(3) .eq. 3 .and. b .eq. 3) then
             print *, "PASS"
         else
             print *, "FAIL"
         endif
         end

         function foow2(i)
         integer i,foow2
         write(10) i,i+2,i+3
!            print *, "write to 10", i, i+2, i+3
         foow2 = i+1
         end

         function foow(i)
           integer foow,i,foow2
           open(12,file='unffile1.dat', form='unformatted')
           write(unit=12) i+7, foow2(1), i
!            print *, "write to 12", i+7, i+1, i
           foow=i+3
           close(12)
         end

         program mm
         integer a,b,foow
         character*20 writetome
         a=1
         b=4
         open(10,file='unffile2.dat', form='unformatted')
!          print *, "write to 10", a
         write(10) a,foow(1),b
!          print *, "write to 10", b
         close(10)

         call unfread()
         end


text:
	PROGRAM PREAMP
C
C	THIS PROGRAM CALCULATES THE ELECTRIC PREAMP RESPONSE,
C	WITH (ICOMP=1)  OR WITHOUT (ICOMP=0) COMPENSATION FILTER
C	IT WRITES A FILE FOR011.DAT TO BE PLOTTED BY MONGO
C
	COMPLEX Z1,Z2,Z3,Z4,Y1,Y2,VIN,VAC,VDC,V1,V2,V3
	DATA ICOMP /0/
	DATA C9 /22.E-12/
	DATA R9,R10 /5.E8,5.E8/
	DATA R33 /1.E4/
	DATA C16 /1.E-8/
	DATA C12,C13,C15/15.E-9,4.7E-9,180.E-12/
	DATA R28,R29,R32 /1.E5, 1.2E3, 2.2E3/
	DATA R2C,C2C /4.64E3,1.E-6/
	DATA TWOPI /6.2831853/
	DATA FHZMIN,FHZMAX,NF /1.,200.E3,120/
C
	FRAT = ALOG(FHZMAX/FHZMIN)/(NF-1)
	FRAT = EXP(FRAT)
	FHZ = FHZMIN
	VIN = 1.
	DO 100 NN = 1,NF
	W = TWOPI*FHZ
C
C	GAIN OF THE INPUT CIRCUIT, BEFORE Q1
C
	Y1 = CMPLX(1./R9, W*C9)
	Z1 = 1./Y1
	V1 = VIN*R10/(R10 + Z1)
C
C	GAIN OF THE DC OUTPUT
C
	Z1 = CMPLX(R33,-1./W/C16)
	Z2 = CMPLX(0.,-1./W/C16)
	VDC = V1*Z2/Z1
C
C	GAIN OF THE OUTPUT CIRCUIT AROUND U2
C	V1 IS THE RELAY OUTPUT
C
	Z1 = CMPLX(R28,-1./(W*C12))
C	V2 IS THE INPUT AT PIN 3 OF U2
	V2 = V1*R28/Z1
C	V3 IS THE OUTPUT VOLTAGE AT PIN 6 OF U2
	Y1 = CMPLX(1./R32,W*C15)
	Z1 = 1./Y1
	Z2 = CMPLX(R29,-1./W/C13)
	V3 = V2*(Z2 + Z1)/Z2
	IF(ICOMP.NE.0) THEN
C
C	  COMPENSATION NETWORK FOR INPUT CIRCUIT, CONSISTING OF
C	  R1C IN SERIES WITH R2C AND C2C
C
	  V2 = VDC
	  Z1 = CMPLX(R2C,-1./W/C2C)
	  Z2 = CMPLX(R1C,0.)
	  VDC = V2*Z1/(Z2 + Z1)
	ENDIF
C
C	WRITE OUTPUT FILE
C
	VAC = V3
	GAINAC = CABS(VAC)
	VR = VAC
	VI = AIMAG(VAC)
	PHAC = 57.29578*ATAN2(VI,VR)
	GAINDC = CABS(VDC)
	VR = VDC
	VI = AIMAG(VDC)
	PHDC = 57.29578*ATAN2(VI,VR)
C
	WRITE(11,1001) FHZ,VAC,GAINAC,PHAC,VDC,GAINDC,PHDC
 1001	FORMAT(E13.4,3F7.3,F6.1,2X,3F7.3,F6.1)
	PRINT*,FHZ,VAC,GAINAC,PHAC
	FHZ = FHZ*FRAT
 100	CONTINUE
	STOP
	END
	SUBROUTINE MGO
C	THIS IS  PREAMP.MGO
C	STORED HERE FOR REFERENCE--TO BE RUN INTERACTIVELY
C
C	DATA FOR011.DAT
C	FORMAT (E13.4,3F7.3,F6.1,2X,3F7.3,F6.1)
C	XCOLUMN 1
C	XLOGARITHM 1
C	YCOLUMN 4                 ! GAIN AC
C	LIMITS  -0.5  6.   0.  4.
C	CONNECT
C	BOX
C	XCOLUMN 1
C	XLOGARITHM 1
C	YCOLUMN 8                 ! GAIN DC
C	LIMITS 0.  6.  0.  5.
C	CONNECT
C	XLABEL LOG FREQUENCY (HZ)
C	YLABEL GAIN
C	ID
	RETURN
	END

ext: for


text:
subroutine evolve( umid, pmid )

! Use umid and pmid from Riemann solver to update velocity, density, and total energy.
! Physical zones are from nmin to nmax.  Zone boundary numbers run from nmin to nmax+1
!-----------------------------------------------------------------------
! GLOBALS
use global
use sweeps

IMPLICIT NONE
! LOCALS
INTEGER :: n
REAL(kind=8) :: dtheta
REAL(kind=8), DIMENSION(maxsweep) :: umid, pmid, amid, uold, xa1, dvol1, upmid, dm, dtbdm
REAL(kind=8), DIMENSION(maxsweep) :: grav0, grav1, xa2, fict0, fict1, xa3
REAL(kind=8), PARAMETER :: third = 1.0 / 3.0

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

call volume (nmin, nmax, ngeom, radius, xa , dx , dvol1 )

! grid position evolution

do n = nmin-3, nmax + 4
  dm   (n) = r(n) * dvol1(n)
  dtbdm(n) = dt / dm(n)
  xa1  (n) = xa(n)
  xa   (n) = xa(n) + dt * umid(n) / radius
  upmid(n) = umid(n) * pmid(n)
enddo

xa1(nmin-4) = xa(nmin-4)
xa1(nmax+5) = xa(nmax+5)

do n = nmin-4, nmax+5
  xa2(n)   = xa1(n) + 0.5*dx(n)
  dx (n)   = xa(n+1) - xa(n)
  xa3(n)   = xa (n) + 0.5*dx(n)
enddo

! Calculate forces using coordinates at t and at t+dt, note that
!   fictitious forces at t+dt depend on updated velocity, but we ignore this

call forces(xa2,grav0,fict0)
call forces(xa3,grav1,fict1)

! Calculate dvolume and average area based on geometry of sweep

call volume (nmin, nmax, ngeom, radius, xa , dx , dvol )

select case (ngeom)
  case(1)
    amid = 0.5*(xa + xa1)
  case (2)
    amid = (xa-xa1)*(third*(xa-xa1)+xa1)+xa1**2
  case (4)
   do n = nmin-3, nmax+4
     dtheta  = xa(n) - xa1(n)
     if(dtheta == 0.0) then
       amid(n) = sin(xa(n))
     else
       amid(n) = (cos(xa1(n))-cos(xa(n)))/dtheta
     endif
   enddo
  case default
   amid = 1.0
end select

do n = nmin-3, nmax+3

! density evolution. lagrangian code, so all we have to do is watch the change in the geometry.

  r(n) = r(n) * ( dvol1(n) / dvol(n) )
  r(n) = max(r(n),smallr)

! velocity evolution due to pressure acceleration and forces.

  uold (n) = u(n)
  u(n) = u(n) - dtbdm(n)*(pmid(n+1)-pmid(n))*0.5*(amid(n+1)+amid(n)) + 0.5*dt*(grav0(n)+fict0(n)+grav1(n)+fict1(n))

! total energy evolution

  e(n) = e(n) - dtbdm(n)*(amid(n+1)*upmid(n+1) - amid(n)*upmid(n)) + 0.5*dt*(uold(n)*grav0(n) + u(n)*grav1(n))
  q(n) = e(n) - 0.5*(u(n)**2+v(n)**2+w(n)**2)
  q(n) = max(q(n),smallp/(gamm*r(n)))

enddo

return
end

max_stars_repo_name: samgeen/Weltgeist

max_issues_repo_name: samgeen/Weltgeist

max_forks_repo_name: samgeen/Weltgeist