text:
      subroutine diag_comp(ilocal,E_st,err_st,vr,workr_n,kpt,iislda)
*************************************************
cc     Written by Lin-Wang Wang, March 30, 2001.
*************************************************************************
**  copyright (c) 2003, The Regents of the University of California,
**  through Lawrence Berkeley National Laboratory (subject to receipt of any
**  required approvals from the U.S. Dept. of Energy).  All rights reserved.
*************************************************************************

******************************************
***  Note for subspace diagonalization, the purpose is to make:
****  ug_m1 * H * ug_m2 = delta_m1,m2.
****  as a result, the S operation is not really needed here.
****  We will diagonalize h(m1,m2), find U.  We don't need to call the
****  general eigen vector solver for h*psi=e s*psi

      use fft_data
      use load_data
      use data

      implicit double precision (a-h,o-z)

      parameter (lwork=6000)

      include 'param.escan_real'

      complex*16 ugh(mg_nx)
      complex*16 h(mst,mst)
      real*8 E_st(mst),err_st(mst)
      complex*16 workx(lwork)
      real*8 workrx(3*mst)

      real*8 vr(mr_n)
      complex*16 workr_n(mr_n)

      real*8 Dij0(32,32,mtype),Qij(32,32,mtype)
      integer isNLa(9,matom),ipsp_type(mtype)
      complex*16 sumdum(32,matom)

******* extra due to djacobi()
      integer ind(mst)

      complex*16 ctmp(mst),c

      common /comisNLa/isNLa,Dij0,Qij,ipsp_all,ipsp_type

**********************************************
**** prepare the matrix
**********************************************
      ng_n=ngtotnod(inode,kpt)

      do 100 m1=1,mx

      call Hpsi_comp(ug_n(1,m1),ugh,ilocal,vr,workr_n,kpt,1,
     &  sug_n(1,m1),sumdum,iislda)

      do 100 m2=1,m1

      c=dcmplx(0.d0,0.d0)
      do i=1,ng_n
      c=c+ugh(i)*dconjg(ug_n(i,m2))
      enddo

      call global_sumc(c)
      c=c*vol

      h(m1,m2)=dconjg(c)
      h(m2,m1)=c
100   continue

********************************************
********************************************
      call system_czheev('V','U',mx,h,mst,E_st,workx,
     &  lwork,workrx,info)
************************************
********* the unitary rotation

      do 200 i=1,ng_n

      do m=1,mx
       c=dcmplx(0.d0,0.d0)

       do m1=1,mx
       c=c+h(m1,m)*ug_n(i,m1)    ! terrible operation
       enddo

       ctmp(m)=c

      enddo

      do m=1,mx
      ug_n(i,m)=ctmp(m)       ! terrible operation
      enddo
200   continue
*********************************
      if(ipsp_all.eq.2) then
      do 201 i=1,ng_n

      do m=1,mx
       c=dcmplx(0.d0,0.d0)

       do m1=1,mx
       c=c+h(m1,m)*sug_n(i,m1)    ! terrible operation
       enddo

       ctmp(m)=c

      enddo

      do m=1,mx
      sug_n(i,m)=ctmp(m)         ! terrible operation
      enddo
201   continue
      endif
*********************************
ccccccccccccccccccccccccccccccccccccccccccccccccccccc
cccc   test   ! we should not do this one !!!
c      do m=1,mx
c
c      call Hpsi_comp(ug_n(1,m),ugh,ilocal,vr,workr_n,kpt,1,sug_n(1,m),iislda)
c
c      s=0.d0
c
c      if(ipsp_all.eq.1) then
c      do i=1,ng_n
c      s=s+cdabs(ugh(i)-E_st(m)*ug_n(i,m))**2
c      enddo
c       else
c      do i=1,ng_n
c      s=s+cdabs(ugh(i)-E_st(m)*sug_n(i,m))**2
c      enddo
c      endif
c
c
c      call global_sumr(s)
c
c      s=s*vol
c      err_st(m)=dsqrt(s)
c      enddo
***********************************
      if(inode_tot.eq.1) then
       write(6,*) "*********************************"
       write(6,*) "*****kpt= ", kpt
       write(6,*) "report from diag_real"
c       write(6,*) "err of each states, A.U"
c       write(6,102) (err_st(i), i=1,mx)
       write(6,*) "eigen energies, in eV"
       write(6,103) (E_st(i)*27.211396d0, i=1,mx)
       write(6,*) "*********************************"
      endif
101   format(5(i6,7x))
102   format(5(E10.4,3x))
103   format(5(f12.8,1x))

      return
      end

max_stars_repo_name: qsnake/petot

max_issues_repo_name: qsnake/petot

max_forks_repo_name: qsnake/petot


text:
program ciclista

    implicit none
    double precision, dimension(0:500) :: v, v1, tempo, diff
    double precision :: m, p, dt, b, ro, a
    integer :: c

    m = 60
    p = 400
    dt = 0.05
    b = 05
    ro = 1
    a = 0.33
    v(0) = 4

	do c = 1,500
	    tempo(c) = c*dt
	    diff(c-1) = p/(m*v(c-1))
	    v(c) = diff(c-1)*dt + v(c-1) - ((b*ro*a*v(c-1)**2)/m)*dt
!	    v(c) = diff(c-1)*dt + v(c-1)
	    write(*,*) tempo(c), v(c)
	enddo

    open(1,FILE = "dados2.txt")

	do c = 1,500
	    write(1,*) tempo(c), v(c)
	enddo

    close(1)

end program

max_stars_repo_name: j-rheinheimer/Fisica-Computacional-I

max_issues_repo_name: j-rheinheimer/Fisica-Computacional-I

max_forks_repo_name: j-rheinheimer/Fisica-Computacional-I


text:
! This file is part of toml-f.
!
! Copyright (C) 2019-2020 Sebastian Ehlert
!
! Licensed under either of Apache License, Version 2.0 or MIT license
! at your option; you may not use this file except in compliance with
! the License.
!
! Unless required by applicable law or agreed to in writing, software
! distributed under the License is distributed on an "AS IS" BASIS,
! WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
! See the License for the specific language governing permissions and
! limitations under the License.

!> Implementation of the TOML array data type.
module tomlf_type_array
   use tomlf_error, only : toml_stat
   use tomlf_type_value, only : toml_value, toml_visitor
   use tomlf_structure, only : toml_ordered, new_ordered
   implicit none
   private

   public :: toml_array, new_array, new, len

   !> TOML array
   type, extends(toml_value) :: toml_array

      !> Is an inline array rather than an array of tables
      logical :: inline = .true.

      !> Storage unit for TOML values of this array
      class(toml_ordered), allocatable :: list

   contains

      !> Get the TOML value at a given index
      procedure :: get

      !> Append value to array
      procedure :: push_back

      !> Release allocation hold by TOML array
      procedure :: destroy

   end type toml_array

   !> Create standard constructor
   interface toml_array
      module procedure :: new_array_func
   end interface toml_array

   !> Overloaded constructor for TOML values
   interface new
      module procedure :: new_array
   end interface

   !> Overload len function
   interface len
      module procedure :: get_len
   end interface

contains

!> Constructor to create a new TOML array and allocate the internal storage
subroutine new_array(self)

   !> Instance of the TOML array
   type(toml_array), intent(out) :: self

   call new_ordered(self%list)

end subroutine new_array

!> Default constructor for TOML array type
function new_array_func() result(self)

   !> Instance of the TOML array
   type(toml_array) :: self

   call new_array(self)

end function new_array_func

!> Get number of TOML values in the array
pure function get_len(self) result(length)

   !> Instance of the TOML array
   class(toml_array), intent(in) :: self

   !> Current length of the array
   integer :: length

   length = self%list%get_len()

end function get_len

!> Get the TOML value at the respective index
subroutine get(self, idx, ptr)

   !> Instance of the TOML array
   class(toml_array), intent(inout) :: self

   !> Index to the TOML value
   integer, intent(in) :: idx

   !> Pointer to the TOML value
   class(toml_value), pointer, intent(out) :: ptr

   call self%list%get(idx, ptr)

end subroutine get

!> Push back a TOML value to the array
subroutine push_back(self, val, stat)

   !> Instance of the TOML array
   class(toml_array), intent(inout) :: self

   !> TOML value to append to array
   class(toml_value), allocatable, intent(inout) :: val

   !> Status of operation
   integer, intent(out) :: stat

   if (allocated(val%key)) then
      stat = toml_stat%fatal
      return
   end if

   call self%list%push_back(val)

   stat = toml_stat%success

end subroutine push_back

!> Deconstructor to cleanup allocations (optional)
subroutine destroy(self)

   !> Instance of the TOML array
   class(toml_array), intent(inout) :: self

   if (allocated(self%key)) then
      deallocate(self%key)
   end if

   if (allocated(self%list)) then
      call self%list%destroy
      deallocate(self%list)
   end if

end subroutine destroy

end module tomlf_type_array

max_stars_repo_name: yundantianchang/toml-f

max_issues_repo_name: yundantianchang/toml-f

max_forks_repo_name: yundantianchang/toml-f


text:
C$Procedure  ZZEKSEI ( Private: EK, set encoded integer )

      SUBROUTINE ZZEKSEI ( HANDLE, ADDRSS, IVAL )

C$ Abstract
C
C     SPICE Private routine intended solely for the support of SPICE
C     routines.  Users should not call this routine directly due
C     to the volatile nature of this routine.
C
C     Set an encoded integer at a specifed address from a character
C     data page.
C
C
C$ Disclaimer
C
C     THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE
C     CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S.
C     GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE
C     ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE
C     PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS"
C     TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY
C     WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A
C     PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC
C     SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE
C     SOFTWARE AND RELATED MATERIALS, HOWEVER USED.
C
C     IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA
C     BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT
C     LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND,
C     INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS,
C     REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE
C     REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY.
C
C     RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF
C     THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY
C     CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE
C     ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE.
C
C$ Required_Reading
C
C     EK
C
C$ Keywords
C
C     EK
C     PRIVATE
C
C$ Declarations

      INCLUDE 'ekdatpag.inc'

      INTEGER               HANDLE
      INTEGER               ADDRSS
      INTEGER               IVAL

C$ Brief_I/O
C
C     Variable  I/O  Description
C     --------  ---  --------------------------------------------------
C     HANDLE     I   EK file handle.
C     ADDRSS     I   DAS character address.
C     IVAL       I   Integer value to write.
C
C$ Detailed_Input
C
C     HANDLE         is the handle of an EK file open for write access.
C
C     ADDRSS         is the DAS character start address at which an
C                    integer, encoded as a string, is to be written.
C                    An encoded integer occupies ENCSIZ characters,
C                    where the parameter ENCSIZ is defined in the
C                    include file ekdatpag.inc.
C
C     IVAL           is an integer value to be written in encoded form.
C
C$ Detailed_Output
C
C     None.  See $Particulars for a description of the effect of this
C     routine.
C
C$ Parameters
C
C     None.
C
C$ Exceptions
C
C     1)  If HANDLE is invalid, the error will be diagnosed by routines
C         called by this routine.
C
C     2)  If the DAS character address range
C
C            ADDRSS .. ADDRSS+ENCSIZ-1
C
C         is not a range of DAS character addresses that have been
C         initialized, the error wll be diagnosed by routines
C         called by this routine.
C
C$ Files
C
C     None.
C
C$ Particulars
C
C     This routine should be used for all EK applications requiring
C     storage of encoded integer values as characters.  Use of this
C     routine should ensure consistent encoding across the library.
C
C     Encoded integers written by this routine should be read using
C     ZZEKGEI.
C
C$ Examples
C
C     See ZZEKAD03.
C
C$ Restrictions
C
C     1)  Portability dictates that the base used for encoding be
C         no greater than 128.
C
C$ Literature_References
C
C     None.
C
C$ Author_and_Institution
C
C     N.J. Bachman       (JPL)
C
C$ Version
C
C-    Beta Version 1.0.0, 10-OCT-1995 (NJB)
C
C-&

C
C     Local variables
C
      CHARACTER*(ENCSIZ)    CVAL

C
C     Discovery error handling should be used in this utility.
C
C
C     Encode the number.
C
      CALL PRTENC ( IVAL, CVAL )

C
C     Write the encoded value.
C
      CALL DASUDC ( HANDLE, ADDRSS, ADDRSS+ENCSIZ-1, 1, ENCSIZ, CVAL )

      RETURN
      END

ext: f

max_stars_repo_name: agforero/FTFramework

max_issues_repo_name: agforero/fortran-testing-framework

max_forks_repo_name: agforero/fortran-testing-framework


text:
      subroutine intge3(cgexp,cgexpi,ier,iern1,iern2,ietmax,jern1,
     $ jern2,jetmax,jgext,jgexti,net,neti,netmax,ngexpi,ngexti,
     $ noutpt,nptmax,nstmax,nttyo,ugexj,ugexji,ugexp,ugexpi,ugexsi,
     $ uphase,uspec,xbar,xbarlg,xgexsi)
c
c     This subroutine interprets any concentrations and compositions
c     of generic exchange phases read from the EQ3NR input file. Here
c     concentration means moles of exchanger phase per kg H2O, and
c     composition means a set of mole fractions of the component
c     species on each site of the exchanger phase.
c
c     This subroutine is called by:
c
c       EQ3NR/eq3nr.f
c
c-----------------------------------------------------------------------
c
c     Principal input:
c
c
c     Principal output:
c
c
c-----------------------------------------------------------------------
c
      implicit none
c
c-----------------------------------------------------------------------
c
c     Calling sequence variable declarations.
c
      integer ietmax,jetmax,netmax,nptmax,nstmax
c
      integer noutpt,nttyo
c
      integer jern1(jetmax,netmax),jern2(jetmax,netmax),jgext(netmax),
     $ jgexti(netmax),ngexpi(netmax),ngexti(jetmax,netmax)
      integer ier,iern1,iern2,net,neti
c
      character*48 uspec(nstmax)
      character*24 ugexp(netmax),ugexpi(netmax),
     $ ugexsi(ietmax,jetmax,netmax),uphase(nptmax)
      character*8 ugexj(jetmax,netmax),ugexji(jetmax,netmax)
c
      real(8) cgexp(netmax),cgexpi(netmax),xbar(nstmax),xbarlg(nstmax),
     $ xgexsi(ietmax,jetmax,netmax)
c
c-----------------------------------------------------------------------
c
c     Local variable declarations.
c
      integer iei,je,jeei,jei,jj,jj2,jj3,j2,j3,j4,j5,j6,nd2,ne,neei,
     $ nei,np,nr1,nr2,ns
c
      integer ilnobl
c
      character*24 ugexpd,ustr,uxp,uxs
      character*8 ugexjd,uxj
      character*8 ux8a,ux8b
c
      real(8) xsum,xx
c
      real(8) tlg
c
c-----------------------------------------------------------------------
c
      ier = 0
      if (neti .le. 0) go to 999
c
      if (net .le. 0) then
        call lejust(ugexpi(1))
        j4 = ilnobl(ugexpi(1))
        if (neti .eq. 1) then
          nei = 1
          write (noutpt,1000) ugexpi(nei)(1:j4)
          write (nttyo,1000) ugexpi(nei)(1:j4)
 1000     format(/' * Error - (EQ3NR/intge3) No generic exchanger',
     $    ' phases were declared',/7x,'on the input file, but a ',
     $    ' concentration and composition are',/7x,'specified for',
     $    ' the generic exchanger phase ',a,'.',/7x,'Specifying a',
     $    ' concentration and  composition does not',
     $    /7x,'automatically create such a phase.',/7x,'Other input',
     $    ' file directives are required.')
          ier = ier + 1
        else
          nei = 1
          write (noutpt,1010) neti,ugexpi(nei)(1:j4)
          write (nttyo,1010) neti,ugexpi(nei)(1:j4)
 1010     format(/' * Error - (EQ3NR/intge3) No generic exchanger',
     $    ' phases were declared',/7x,'on the input file, but',
     $    ' concentrations and compositions are specified',/7x,'for ',
     $    i3,' such phases, including ',a,'.',/7x,'Specifying a',
     $    ' concentration and  composition does not',
     $    /7x,'automatically create such a phase.',/7x,'Other input',
     $    ' file directives are required.')
          ier = ier + 1
        endif
      endif
c
      if (ier .gt. 0) go to 999
c
c* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
c
c     Left-justify all input exchanger phase names and site names. Make
c     sure that no such names are blank. Assign defaults if necessary.
c
      do nei = 1,neti
        call lejust(ugexpi(nei))
        j4 = ilnobl(ugexpi(nei))
        if (j4 .le. 0) then
c
c         Calling sequence substitutions:
c           nei for ne
c
          call adgexp(nei,noutpt,nttyo,ugexpd)
          ugexpi(nei) = ugexpd
        endif
        do jei = 1,jgexti(nei)
          call lejust(ugexji(jei,nei))
          j3 = ilnobl(ugexji(jei,nei))
          if (j3 .le. 0) then
c
c           Calling sequence substitutions:
c             jei for je
c
            call adgexj(jei,noutpt,nttyo,ugexjd)
            ugexji(jei,nei) = ugexjd
          endif
        enddo
      enddo
c
c* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
c
c     Make sure that the names of exchanger phases for which
c     concentrations and compositions are specified are unique.
c     Make sure that the names of the sites of these phases are
c     unique for each such phase.
c
      do nei = 1,neti
        j4 = ilnobl(ugexpi(nei))
        if (nei .gt. 1) then
          do neei = 1,nei - 1
            if (ugexpi(nei)(1:24) .eq. ugexpi(neei)(1:24)) then
              write (noutpt,1030) ugexpi(nei)(1:j4),nei,neei
              write (nttyo,1030) ugexp(nei)(1:j4),nei,neei
 1030         format (/' * Error - (EQ3NR/intge3) "',a,'" is the name',
     $        ' specified',/7x,'for exchanger phases ',i3,' and ',i3,
     $        ' on the list of such phases',/7x,'whose concentrations',
     $        ' and compositions are given on the input file.',
     $        /7x,'Only one concentration and composition may be',
     $        ' entered per',/7x,'exchanger phase.')
             ier = ier + 1
            endif
          enddo
        endif
c
        do jei = 1,jgexti(nei)
          j3 = ilnobl(ugexji(jei,nei))
          if (jei .gt. 1) then
            do jeei = 1,jei - 1
              if (ugexji(jei,nei)(1:8) .eq. ugexji(jeei,nei)(1:8)) then
                write (noutpt,1040) ugexji(jei,nei)(1:j3),jei,jeei,
     $          ugexpi(nei)(1:j4)
                write (nttyo,1040) ugexji(jei,nei)(1:j3),jei,jeei,
     $          ugexpi(nei)(1:j4)
 1040           format (/' * Error - (EQ3NR/intge3) "',a,'" is the',
     $          ' name specified',/7x,'for sites ',i3,' and ',i3,' of',
     $          ' exchanger phase ',a,/7x,', whose composition is',
     $          ' given on the input file.',/7x,'A site name must be',
     $          ' unique for a given exchanger phase.')
                ier = ier + 1
              endif
            enddo
          endif
        enddo
      enddo
c
      if (ier .gt. 0) go to 999
c
c* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
c
c     Interpret the input data.
c
      do nei = 1,neti
        uxp = ugexpi(nei)
        j4 = ilnobl(uxp)
        ne = 0
c
        do np = iern1,iern2
          if (uxp(1:24) .eq. uphase(np)(1:24)) go to 100
        enddo
c
        write (noutpt,1070) uxp(1:j4)
        write (nttyo,1070) uxp(1:j4)
 1070   format(/' * Error - (EQ3NR/intge3) The generic exchanger',
     $  ' phase',/7x,a,', whose composition is specified on the input',
     $  /7x,"file, doesn't match the name of any such phase declared",
     $  /7x,'on the input file.')
        ier = ier + 1
        go to 200
c
  100   ne = np - iern1 + 1
        ngexpi(nei) = np
        cgexp(ne) = cgexpi(nei)
c
        if (jgexti(nei) .ne. jgext(ne)) then
          write (ux8a,'(i5)') jgexti(nei)
          call lejust(ux8a)
          j5 = ilnobl(ux8a)
          write (ux8b,'(i5)') jgext(ne)
          call lejust(ux8b)
          j6 = ilnobl(ux8b)
          write (noutpt,1080) uxp(1:j4),ux8a(1:j5),ux8b(1:j6)
          write (nttyo,1080) uxp(1:j4),ux8a(1:j5),ux8b(1:j6)
 1080     format(/' * Error - (EQ3NR/intge3) The generic exchanger',
     $  ' phase ',a,/7x,'has a specified composition including ',a,
     $  ' exchange site(s), but',/7x,'this phase actually has ',a,
     $  ' exchange site(s). The number of such',/7x,'sites much match.')
          ier = ier + 1
          go to 200
        endif
c
        do jei = 1,jgexti(nei)
          uxj = ugexji(jei,nei)
          j3 = ilnobl(uxj)
c
          do je = 1,jgext(ne)
            if (uxj(1:8) .eq. ugexj(je,ne)(1:8)) go to 110
          enddo
c
          write (noutpt,1110) uxj(1:j3),uxp(1:j4)
          write (nttyo,1110) uxj(1:j3),uxp(1:j4)
 1110     format(/' * Error - (EQ3NR/intge3) Site ',a,' of generic',
     $    ' exchanger phase',/7x,a,', whose composition is specified',
     $    ' on',/7x,"the input file, doesn't match the name of any",
     $    ' site',/7x,'of this phase as declared on the input file.')
          ier = ier + 1
          go to 190
c
  110     xsum = 0.
          do iei = 1,ngexti(jei,nei)
            uxs = ugexsi(iei,jei,nei)
            j2 = ilnobl(uxs)
c
c           Compose the exchanger species name, by combining the
c           name of the exchangeable species (the aqueous species)
c           with the site name. The algorithm for this follows that
c           used in EQLIB/intexi.f, except that the phase part of the
c           name is not employed here.
c
            jj2 = j2
            jj3 = j3
            nd2 = 0
  250       jj = jj2 + jj3 + 1
            if (jj .gt. 24) then
              if (nd2 .lt. 2) then
                jj2 = jj2 - 1
                nd2 = nd2 + 1
                go to 250
              else
                jj3 = jj3 - 1
                nd2 = 0
                go to 250
              endif
            endif
            ustr = ' '
            ustr(1:jj2) = ugexsi(iei,jei,nei)(1:jj2)
            ustr(jj2 + 1:jj2 + 1) = ' '
            ustr(jj2 + 2:jj) = ugexji(jei,nei)(1:jj3)
c
            nr1 = jern1(je,ne)
            nr2 = jern2(je,ne)
c
            do ns = nr1,nr2
              if (ustr(1:24) .eq. uspec(ns)(1:24)) go to 130
            enddo
c
            write (noutpt,1120) uxs(1:j2),uxj(1:j3),uxp(1:j4)
            write (nttyo,1120) uxs(1:j2),uxj(1:j3),uxp(1:j4)
 1120       format(/' * Error - (EQ3NR/intge3) The species ',a,' for',
     $      /7x,'site ',a,' of generic exchanger phase ',a,',',
     $      /7x,'whose composition is specified on the input file,',
     $      " doesn't match",/7x,'the name of any species for this',
     $      ' site of this phase',/7x,'as declared on the input file.')
            ier = ier + 1
            go to 180
c
  130       xx = xgexsi(iei,jei,nei)
            if (xx .ge. 0.) then
              xsum = xsum + xx
              xbar(ns) = xx
              xbarlg(ns) = tlg(xx)
            else
              write (noutpt,1130) uxs(1:j2),uxj(1:j3),uxp(1:j4),xx
              write (nttyo,1130) uxs(1:j2),uxj(1:j3),uxp(1:j4),xx
 1130         format(/' * Error - (EQ3NR/intge3) The species ',a,
     $        ' for ',/7x,'site ',a,' of generic exchanger phase ',a,
     $        /7x,'has an illegal negative mole fraction of ',1pe12.5,
     $        ' specified',/7x,'on the input file.')
              ier = ier + 1
            endif
  180       continue
          enddo
c
c         Normalize the mole fractions on the current site.
c
          nr1 = jern1(je,ne)
          nr2 = jern2(je,ne)
          if (xsum .gt. 0.) then
            do ns = nr1,nr2
              xx = xbar(ns)/xsum
              xbar(ns) = xx
              xbarlg(ns) = tlg(xx)
            enddo
          endif
c
  190     continue
        enddo
  200   continue
      enddo
c
c* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
c
  999 continue
      end


text:
!*******************************************************************************
!>  @file unit_test_runner.f
!>  @brief Utility to run the LIBSTELL unit tests.
!
!  Note separating the Doxygen comment block here so detailed decription is
!  found in the Module not the file.
!
!>  These tests run module tests embeded within specific modules.
!*******************************************************************************
      PROGRAM LIBSTELL_UNIT_TEST_RUNNER
      USE line_segment
      USE coordinate_utilities
      USE functions
      USE integration_path

      IMPLICIT NONE

!  local variables
      LOGICAL :: tests_failed

!  Start of executable code
      tests_failed = .false.

! Line segment tests
      IF (line_seg_test()) THEN
         WRITE (*,*) 'Line Segment Test Passed'
      ELSE
         tests_failed = .true.
      END IF

! Coordinate tests
      IF (cood_utils_test()) THEN
         WRITE (*,*) 'Coord Utilites Test Passed'
      ELSE
         tests_failed = .true.
      END IF

! Profile function tests
      IF (function_test()) THEN
         WRITE (*,*) 'Functions Test Passed'
      ELSE
         tests_failed = .true.
      END IF

! Integration path tests
      IF (path_test()) THEN
         WRITE (*,*) 'Integration Path Test Passed'
      ELSE
         tests_failed = .true.
      END IF

!  The CTest unit test frame work chooses a pass fail based on the exit code of
!  the program.
      IF (tests_failed) THEN
         CALL EXIT(1)
      END IF

      END PROGRAM

max_stars_repo_name: ORNL-Fusion/libstell

max_issues_repo_name: ORNL-Fusion/libstell

max_forks_repo_name: ORNL-Fusion/LIBSTELL


text:
      subroutine load_para(npara,param,value)
c----------------------------------------------------------------------
c Read the params from the run_card.dat file
c----------------------------------------------------------------------
      implicit none
c
c     arguments
c
      character*20 param(*),value(*)
      integer npara
c
c     local
c
      logical fopened,done
      integer iunit
      character*20 ctemp
      integer k,i,l1,l2,iproc
      character*132 buff
      data iunit/21/
c
c     global
c
      integer ngroup
      common/to_group/ngroup
c
c----------
c     start
c----------
c
c     read the run_card.dat
c
      npara=0
      param(1)=' '
      value(1)=' '
c
c     open file
c
      call open_file(iunit,'run_card.dat',fopened)
      if(.not.fopened) then
         write(*,*) 'Error: File run_card.dat not found'
         stop
      else
c
c     first look for process-specific parameters
c
      done=.false.
      do while(.not.done)
         read(iunit,'(a132)',end=20,err=20) buff
         if(buff(1:1).ne.'#' .and. index(buff,"=").gt.0
     $        .and. index(buff,"@").gt.0) then
            l1=index(buff,"@")
            l2=index(buff,"!")
            if(l2.eq.0) l2=l1+20  !maybe there is no comment...
            read(buff(l1+1:l2),*,err=11) iproc
            if(iproc.ne.ngroup) cycle

            l1=index(buff,"=")
            l2=index(buff,"@")
            if(l2-l1.lt.0) cycle
            npara=npara+1
c
             value(npara)=buff(1:l1-1)
             ctemp=value(npara)
             call case_trap2(ctemp)
             value(npara)=ctemp
c
             param(npara)=" "//buff(l1+1:l2-1)
             ctemp=param(npara)
             call case_trap2(ctemp)
             param(npara)=ctemp
c
 11          cycle
         endif
      enddo
 20   rewind(iunit)
c
c     read in values
c
      done=.false.
      do while(.not.done)
         read(iunit,'(a132)',end=96,err=96) buff
         if(buff(1:1).ne.'#' .and. index(buff,"=").gt.0
     $        .and. index(buff,"@").le.0) then
            l1=index(buff,"=")
            l2=index(buff,"!")
            if(l2.eq.0) l2=l1+20  !maybe there is no comment...
            if(l2-l1.lt.0) cycle
            npara=npara+1
c
             value(npara)=buff(1:l1-1)
             ctemp=value(npara)
             call case_trap2(ctemp)
             value(npara)=ctemp
c
             param(npara)=" "//buff(l1+1:l2-1)
             ctemp=param(npara)
             call case_trap2(ctemp)
             param(npara)=ctemp
c
         endif
      enddo
 96   close(iunit)
      endif
c
c     open file
c
c
c     tjs modified 11-16-07 to include grid_card.dat
c
      call open_file(iunit,'grid_card.dat',fopened)
      if(fopened) then
c
c     first look for process-specific parameters
c
      done=.false.
      do while(.not.done)
         read(iunit,'(a132)',end=30,err=30) buff
         if(buff(1:1).ne.'#' .and. index(buff,"=").gt.0
     $        .and. index(buff,"@").gt.0) then
            l1=index(buff,"@")
            l2=index(buff,"!")
            if(l2.eq.0) l2=l1+20  !maybe there is no comment...
            read(buff(l1+1:l2),*,err=21) iproc
            if(iproc.ne.ngroup) cycle

            l1=index(buff,"=")
            l2=index(buff,"@")
            if(l2-l1.lt.0) cycle
            npara=npara+1
c
             value(npara)=buff(1:l1-1)
             ctemp=value(npara)
             call case_trap2(ctemp)
             value(npara)=ctemp
c
             param(npara)=" "//buff(l1+1:l2-1)
             ctemp=param(npara)
             call case_trap2(ctemp)
             param(npara)=ctemp
c
 21          cycle
         endif
       enddo
 30   rewind(iunit)
c
c     read in values
c
      done=.false.
      do while(.not.done)
         read(iunit,'(a132)',end=99,err=99) buff
         if(buff(1:1).ne.'#' .and. index(buff,"=").gt.0
     $        .and. index(buff,"@").le.0) then
            l1=index(buff,"=")
            l2=index(buff,"!")
            if(l2.eq.0) l2=l1+20  !maybe there is no comment...
            if(l2-l1.lt.0) cycle
            npara=npara+1
c
             value(npara)=buff(1:l1-1)
             ctemp=value(npara)
             call case_trap2(ctemp)
             value(npara)=ctemp
c
             param(npara)=" "//buff(l1+1:l2-1)
c             write (*,*) param(npara),l1,l2
             ctemp=param(npara)
             call case_trap2(ctemp)
             param(npara)=ctemp
c             write(*,*) "New param:",param(npara)," = ", value(npara)
c
         endif
      enddo
 99   close(iunit)
      endif

      return
      end

      subroutine get_real(npara,param,value,name,var,def_value)
c----------------------------------------------------------------------------------
c     finds the parameter named "name" in param and associate to "value" in value
c----------------------------------------------------------------------------------
      implicit none

c
c     arguments
c
      integer npara
      character*20 param(*),value(*)
      character*(*)  name
      real*8 var,def_value
      character*20 c_param,c_name
c
c     local
c
      logical found
      integer i
c
c     start
c
      i=1
      found=.false.
      do while(.not.found.and.i.le.npara)
          call firststring(c_param,param(i))
          call firststring(c_name,name)
         found = (c_param .eq. c_name)
         if (found) read(value(i),*) var
c         if (found) write (*,*) name,var
         i=i+1
      enddo
      if (.not.found) then
         write (*,*) "Warning: parameter ",name," not found"
         write (*,*) "         setting it to default value ",def_value
         var=def_value
      endif
      return

      end
c

      subroutine get_integer(npara,param,value,name,var,def_value)
c----------------------------------------------------------------------------------
c     finds the parameter named "name" in param and associate to "value" in value
c----------------------------------------------------------------------------------
      implicit none
c
c     arguments
c
      integer npara
      character*20 param(*),value(*)
      character*(*)  name
      integer var,def_value
      character*20 c_param,c_name
c
c     local
c
      logical found
      integer i
c
c     start
c
      i=1
      found=.false.
      do while(.not.found.and.i.le.npara)
         call firststring(c_param,param(i))
          call firststring(c_name,name)
         found = (c_param .eq. c_name)
         if (found) read(value(i),*) var
c         if (found) write (*,*) name,var
         i=i+1
      enddo
      if (.not.found) then
         write (*,*) "Warning: parameter ",name," not found"
         write (*,*) "         setting it to default value ",def_value
         var=def_value
      endif
      return

      end
c
      subroutine get_int8(npara,param,value,name,var,def_value)
c----------------------------------------------------------------------------------
c     finds the parameter named "name" in param and associate to "value" in value
c----------------------------------------------------------------------------------
      implicit none
c
c     arguments
c
      integer npara
      character*20 param(*),value(*)
      character*(*)  name
      integer def_value
      integer*8 var
      character*20 c_param,c_name
c
c     local
c
      logical found
      integer i
c
c     start
c
      i=1
      found=.false.
      do while(.not.found.and.i.le.npara)
         call firststring(c_param,param(i))
          call firststring(c_name,name)
         found = (c_param .eq. c_name)
         if (found) read(value(i),*) var
c         if (found) write (*,*) name,var
         i=i+1
      enddo
      if (.not.found) then
         write (*,*) "Warning: parameter ",name," not found"
         write (*,*) "         setting it to default value ",def_value
         var=def_value
      endif
      return

      end
c
      subroutine get_string(npara,param,value,name,var,def_value)
c----------------------------------------------------------------------------------
c     finds the parameter named "name" in param and associate to "value" in value
c----------------------------------------------------------------------------------
      implicit none

c
c     arguments
c
      integer npara
      character*20 param(*),value(*)
      character*(*)  name
      character*(*)  var,def_value
      character*20 c_param,c_name
c
c     local
c
      logical found
      integer i
c
c     start
c
      i=1
      found=.false.
      do while(.not.found.and.i.le.npara)
         call firststring(c_param,param(i))
          call firststring(c_name,name)
         found = (c_param .eq. c_name)
         if (found) read(value(i),*) var
c         if (found) write (*,*) name,var
         i=i+1
      enddo
      if (.not.found) then
         write (*,*) "Warning: parameter ",name," not found"
         write (*,*) "         setting it to default value ",def_value
         var=def_value
      endif
      return

      end
c
      subroutine get_logical(npara,param,value,name,var,def_value)
c----------------------------------------------------------------------------------
c     finds the parameter named "name" in param and associate to "value" in value
c----------------------------------------------------------------------------------
      implicit none

c
c     arguments
c
      integer npara
      character*20 param(*),value(*)
      character*(*)  name
      logical  var,def_value
      character*20 c_param,c_name
c
c     local
c
      logical found
      integer i
c
c     start
c
      i=1
      found=.false.
      do while(.not.found.and.i.le.npara)
         call firststring(c_param,param(i))
          call firststring(c_name,name)
         found = (c_param .eq. c_name)
         if (found) read(value(i),*) var
c         if (found) write (*,*) name,var
         i=i+1
      enddo
      if (.not.found) then
         write (*,*) "Warning: parameter ",name," not found"
         write (*,*) "         setting it to default value ",def_value
         var=def_value
      endif
      return

      end
c

      subroutine case_trap2(name)
c**********************************************************
c change the string to lowercase if the input is not
c**********************************************************
      implicit none
c
c     ARGUMENT
c
      character*(*) name
c
c     LOCAL
c
      integer i,k

      do i=1,len(name)
         k=ichar(name(i:i))
         if(k.ge.65.and.k.le.90) then  !upper case A-Z
            k=ichar(name(i:i))+32
            name(i:i)=char(k)
         endif
      enddo

      return
      end

      subroutine to_upper(name)
c**********************************************************
c change the string to uppercase if the input is not
c**********************************************************
      implicit none
c
c     ARGUMENT
c
      character*(*) name
c
c     LOCAL
c
      integer i,k

      do i=1,len(name)
         k=ichar(name(i:i))
         if(k.gt.90) then  !upper case A-Z
            k=ichar(name(i:i))-32
            name(i:i)=char(k)
         endif
      enddo

      return
      end

c +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
c ++
c ++ firststring -> return the first "word" of string
c ++ & remove whitespaces around
c ++ Needed to correct a bug in "get_" routines
c ++ Michel Herquet - CP3 - 05-04-2006
c ++
c +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++

      subroutine firststring(first,string)

      implicit none
      character*(*) string
      character*20 first
      character*20 temp

      temp=string
      do while(temp(1:1) .eq. ' ')
	temp=temp(2:len(temp))
      end do
      first=temp(1:index(temp,' ')-1)

      end


text: #redirect Department of Plant Sciences

max_stars_repo_name: voflo/Search

max_issues_repo_name: voflo/Search

max_forks_repo_name: voflo/Search


text:
      logical*4 function tmatch(name,patt)
      implicit none
      integer*4 lenw
      character*(*) name,patt
      logical*4 tmatchl
      tmatch=tmatchl(name,lenw(name),patt,lenw(patt))
      return
      end

      recursive logical*4 function tmatchl(name,ln,patt,lp)
     $     result(lx)
      use tfstk
      implicit none
      integer*4 lp,ln,notchar1,ia,regexp,ir,ia1,ia2
      character*(*) name,patt
      character en,ep
      logical*4 tmatchl1,tmatchl3
      integer*8 iafwild
      data iafwild/0/
      if(lp .le. 0)then
        lx=ln .le. 0
        return
      endif
      if(iafwild .eq. 0)then
        iafwild=ktfsymbolz('$WildCardID',11)
      endif
      if(rlist(iafwild-4) .ne. 0.d0)then
        en=name(ln+1:ln+1)
        name(ln+1:ln+1)=char(0)
        ep=patt(lp+1:lp+1)
        patt(lp+1:lp+1)=char(0)
        ir=regexp(name,patt)
        name(ln+1:ln+1)=en
        patt(lp+1:lp+1)=ep
        lx=ir .eq. 1
        return
      endif
      ia=index(patt(1:lp),'|')
      if(ia .gt. 0)then
        lx=tmatchl(name,ln,patt(1:ia-1),ia-1) .or.
     $       tmatchl(name,ln,patt(ia+1:lp),lp-ia)
        return
      else
        ia1=index(patt(1:lp),'{')
        if(ia1 .le. 0)then
          ia2=index(patt(1:lp),'%')
          if(ia2 .le. 0)then
            lx=tmatchl3(name,ln,patt,lp)
            return
          endif
        endif
        if(ln .le. 0)then
          lx=notchar1(patt(1:lp),lp,'*',1) .eq. 0
        else
          lx=tmatchl1(name,ln,patt,lp)
        endif
      endif
      return
      end

      recursive logical*4 function tmatchl1(name,ln,patt,lp)
     $     result(lx)
      implicit none
      integer*4 lp,ln,notchar1,ic,notany1,ifany1,ic1,ic2,id1
      character*(*) name,patt
      logical*4 tmatchl2
      lx=.false.
      id1=index(patt(1:lp),'{')
      if(id1 .le. 0)then
        lx=tmatchl2(name,ln,patt,lp)
        return
      elseif(id1 .eq. 1)then
        ic=index(patt(1:lp),'}')
        if(ic .eq. 0)then
          ic=lp+1
        endif
        if(patt(2:2) .eq. '^')then
          if(index(patt(3:ic-1),name(1:1)) .gt. 0)then
            return
          endif
        elseif(index(patt(2:ic-1),name(1:1)) .eq. 0)then
          return
        endif
        if(lp .le. ic)then
          lx=ln .eq. 1
        elseif(ln .eq. 1)then
          lx=notchar1(patt,lp,'*',ic+1) .eq. 0
        else
          lx=tmatchl1(name(2:ln),ln-1,patt(ic+1:lp),lp-ic)
        endif
        return
      endif
      ic1=notany1(patt,lp,'*%{}',1)
      if(ic1 .eq. 1)then
        ic2=max(ifany1(patt,lp,'*%{',ic1+1)-1,ic1)
        if(ln .lt. ic2)then
          return
        elseif(name(1:ic2) .ne. patt(1:ic2))then
          return
        elseif(ic2 .eq. lp)then
          lx=ln .eq. ic2
        elseif(ln .eq. ic2)then
          lx=notchar1(patt,lp,'*',ic2+1) .eq. 0
        else
          lx=tmatchl1(name(ic2+1:ln),ln-ic2,
     $         patt(ic2+1:lp),lp-ic2)
        endif
        return
      endif
      if(ic1 .ne. 0)then
        if(id1+1 .ne. ic1)then
          ic2=max(ifany1(patt,lp,'*%{',ic1+1)-1,ic1)
          if(index(name(1:ln),patt(ic1:ic2)) .le. 0)then
            return
          endif
        endif
      endif
      if(patt(1:1) .eq. '*')then
        if(lp .eq. 1)then
          lx=.true.
        else
          lx=tmatchl1(name,ln,patt(2:lp),lp-1)
          if(.not. lx .and. ln .ne. 1)then
            lx=tmatchl1(name(2:ln),ln-1,patt(1:lp),lp)
          endif
        endif
        return
      elseif(patt(1:1) .eq. '%')then
        if(lp .eq. 1)then
          lx=ln .eq. 1
        elseif(ln .eq. 1)then
          lx=notchar1(patt,lp,'*',2) .eq. 0
        else
          lx=tmatchl1(name(2:ln),ln-1,patt(2:lp),lp-1)
        endif
      elseif(name(1:1) .eq. '}')then
        if(lp .eq. 1)then
          lx=ln .eq. 1
        elseif(ln .eq. 1)then
          lx=notchar1(patt,lp,'*',2) .eq. 0
        else
          lx=tmatchl1(name(2:ln),ln-1,patt(2:lp),lp-1)
        endif
      endif
      return
      end

      recursive logical*4 function tmatchl2(name,ln,patt,lp)
     $     result(lx)
      implicit none
      integer*4 lp,ln,notchar1,notany1,ifany1,ic1,ic2
      character*(*) name,patt
      lx=.false.
      ic1=notany1(patt,lp,'*%',1)
      if(ic1 .eq. 1)then
        ic2=max(ifany1(patt,lp,'*%',ic1+1)-1,ic1)
        if(ln .lt. ic2)then
          return
        elseif(name(1:ic2) .ne. patt(1:ic2))then
          return
        elseif(ic2 .eq. lp)then
          lx=ln .eq. ic2
        elseif(ln .eq. ic2)then
          lx=notchar1(patt,lp,'*',ic2+1) .eq. 0
        else
          lx=tmatchl2(name(ic2+1:ln),ln-ic2,
     $         patt(ic2+1:lp),lp-ic2)
        endif
        return
      endif
      if(ic1 .ne. 0)then
        ic2=max(ifany1(patt,lp,'*%',ic1+1)-1,ic1)
        if(index(name(1:ln),patt(ic1:ic2)) .le. 0)then
          return
        endif
      endif
      if(patt(1:1) .eq. '*')then
        if(lp .eq. 1)then
          lx=.true.
        else
          lx=tmatchl2(name,ln,patt(2:lp),lp-1)
          if(.not. lx .and. ln .ne. 1)then
            lx=tmatchl2(name(2:ln),ln-1,patt(1:lp),lp)
          endif
        endif
        return
      else
        if(lp .eq. 1)then
          lx=ln .eq. 1
        elseif(ln .eq. 1)then
          lx=notchar1(patt(2:lp),lp-1,'*',1) .eq. 0
        else
          lx=tmatchl2(name(2:ln),ln-1,patt(2:lp),lp-1)
        endif
      endif
      return
      end

      recursive logical*4 function tmatchl3(name,ln,patt,lp)
     $     result(lx)
      implicit none
      integer*4 lp,ln,notchar1,ic1,ic2,id1,id2
      character*(*) name,patt
      lx=.false.
      ic1=notchar1(patt,lp,'*',1)
      if(ic1 .eq. 1)then
        ic2=max(0,index(patt(ic1+1:lp),'*')-1)+ic1
        if(ln .lt. ic2)then
          return
        elseif(name(1:ic2) .ne. patt(1:ic2))then
          return
        elseif(ic2 .eq. lp)then
          lx=ln .eq. ic2
        elseif(ln .eq. ic2)then
          lx=notchar1(patt,lp,'*',ic2+1) .eq. 0
        else
          lx=tmatchl3(name(ic2+1:ln),ln-ic2,
     $         patt(ic2+1:lp),lp-ic2)
        endif
        return
      endif
      if(ic1 .ne. 0)then
        ic2=max(0,index(patt(ic1+1:lp),'*')-1)+ic1
        if(ic2 .eq. lp)then
          if(ln .ge. ic2-ic1+1)then
            lx=name(ln-ic2+ic1:ln) .eq. patt(ic1:ic2)
          endif
          return
        endif
        id1=index(name(1:ln),patt(ic1:ic2))
        if(id1 .le. 0)then
          return
        endif
        id2=id1+ic2-ic1
        if(ln .eq. id2)then
          lx=notchar1(patt,lp,'*',ic2+1) .eq. 0
        else
          lx=tmatchl3(name(id2+1:ln),ln-id2,
     $         patt(ic2+1:lp),lp-ic2) .or.
     $         tmatchl3(name(id2+1:ln),ln-id2,
     $         patt,lp)
        endif
        return
      endif
      if(lp .eq. 1)then
        lx=.true.
      else
        lx=tmatchl3(name,ln,patt(2:lp),lp-1)
        if(.not. lx .and. ln .ne. 1)then
          lx=tmatchl3(name(2:ln),ln-1,patt(1:lp),lp)
        endif
      endif
      return
      end

max_stars_repo_name: noboruatkek/SAD

max_issues_repo_name: noboruatkek/SAD

max_forks_repo_name: noboruatkek/SAD


text:
C  *********************************************************
C  *                                                       *
C  *    TEST NUMBER: 04.02.05.03/12                        *
C  *    TEST TITLE : Appearance of bundled attributes      *
C  *                                                       *
C  *    PHIGS Validation Tests, produced by NIST           *
C  *                                                       *
C  *********************************************************

      COMMON /GLOBNU/ CTLHND, ERRSIG, ERRFIL, IERRCT, UNERR,
     1        TESTCT, IFLERR, PASSSW, ERRSW, MAXLIN,
     2        CONID, MEMUN, WKID, WTYPE, GLBLUN, INDLUN,
     3        DUMINT, DUMRL
      INTEGER         CTLHND, ERRSIG, ERRFIL, IERRCT, UNERR,
     1        TESTCT, IFLERR, PASSSW, ERRSW, MAXLIN,
     2        CONID, MEMUN, WKID, WTYPE, GLBLUN, INDLUN,
     3        DUMINT(20), ERRIND
      REAL    DUMRL(20)

      COMMON /GLOBCH/ PIDENT,    GLBERR,    TSTMSG,     FUNCID,
     1                DUMCH
      CHARACTER       PIDENT*40, GLBERR*60, TSTMSG*900, FUNCID*80,
     1                DUMCH(20)*20

      COMMON /DIALOG/ DOUTYP, DINTYP, DSTDNR, DSTRID, PSTRID, DTCLIM,
     1                SCRMOD, DTXCI, SPECWT,
     2                DSIZE, EFRAC, DYXRAT, SYXRAT, MTRPDC, WCPDC, QVIS
      INTEGER         DOUTYP, DINTYP, DSTDNR, DSTRID, PSTRID, DTCLIM,
     1                SCRMOD, DTXCI, SPECWT
      REAL            DSIZE, EFRAC, DYXRAT, SYXRAT, MTRPDC, WCPDC, QVIS

C aspect source
      INTEGER    PBUNDL,     PINDIV
      PARAMETER (PBUNDL = 0, PINDIV = 1)

C type of returned value
      INTEGER PSET, PREALI
      PARAMETER (PSET = 0, PREALI = 1)

C interior style
      INTEGER    PHOLLO,   PSOLID,   PPATTR,   PHATCH,   PISEMP
      PARAMETER (PHOLLO=0, PSOLID=1, PPATTR=2, PHATCH=3, PISEMP=4)

C linetype
      INTEGER    PLSOLI,    PLDASH,    PLDOT,   PLDASD
      PARAMETER (PLSOLI= 1, PLDASH=2 , PLDOT=3, PLDASD=4)

C off/on switch for edge flag and error handling mode
      INTEGER    POFF,     PON
      PARAMETER (POFF = 0, PON = 1)

C colour model
      INTEGER    PRGB,     PCIE,     PHSV,     PHLS
      PARAMETER (PRGB = 1, PCIE = 2, PHSV = 3, PHLS = 4)

C aspect identifier
      INTEGER    PLN,      PLWSC,    PPLCI,    PMK,      PMKSC
      PARAMETER (PLN  = 0, PLWSC= 1, PPLCI= 2, PMK  = 3, PMKSC= 4)

      INTEGER    PPMCI,    PTXFN,    PTXPR,    PCHXP,    PCHSP
      PARAMETER (PPMCI= 5, PTXFN= 6, PTXPR= 7, PCHXP= 8, PCHSP= 9)

      INTEGER    PTXCI,    PIS,      PISI,     PICI,     PEDFG
      PARAMETER (PTXCI=10, PIS  =11, PISI =12, PICI =13, PEDFG=14)

      INTEGER    PEDT,     PEWSC,    PEDCI
      PARAMETER (PEDT=15,  PEWSC=16, PEDCI=17)

      INTEGER    IMPMAX, CSIZ, CDIM
      PARAMETER  (IMPMAX = 600, CSIZ = 6)

      INTEGER    PICSTR, TXCI, IX, LDX, NAREA
      INTEGER    NUMET, STDDX, REGDX, IMPDX, THISET, NUMEW
      INTEGER    PERM(20), SZBT, FILON, NUMDIS, NPTS(1)
      INTEGER    NUMPAS,SZCOLT,VISDX,NUMCI, MAXCOL, EXPLCT, UNDF(3)
      INTEGER    LAVSET(10), LAVIET(IMPMAX), LAVRET(10), RTANS(20)
      INTEGER    RNDINT, ITRIM, COLEL, EDCOL(20), VISCOL, PECI
      INTEGER    IDUM1, IDUM2, IDUM3, IDUM4, IDUM5, IDUM6, IDUM7

      REAL       NOMEW, MINEW, MAXEW, TSTEW1, TSTEW2, MULT,THISEW
      REAL       XA(6), YA(6), YLOC, YINCR, RAD, CENTX, CENTY, PI
      REAL       BCKCOL(CSIZ), FORCOL(CSIZ), NEWCOL(CSIZ), MINLW
      REAL       RDUM1, RDUM2, RDUM3

      CHARACTER LDESCR(4)*14, PROMPT*200, PFSW*1

      DATA LDESCR /'solid','dashed','dotted','dashed-dotted'/

      CALL INITGL ('04.02.05.03/12')

C open PHIGS
      CALL XPOPPH (ERRFIL, MEMUN)
C set-up of workstation and dialogue area
      PICSTR = 101
      TXCI = 1
      CALL SETDLG (PICSTR, 801,TXCI)
      CALL PSCMD (WKID, PRGB)

      CALL POPST (PICSTR)
C  by convention, view #1 is for picture
      CALL PSVWI (1)

C  set all ASFs to BUNDLED
      CALL SETASF (PBUNDL)
C  set interior style attribute ASFs to INDIVIDUAL
C     set interior style = EMPTY, interior color index = 1
      CALL PSIASF (PIS, PINDIV)
      CALL PSIASF (PICI, PINDIV)
      CALL PSIS (PISEMP)
      CALL PSICI (1)

C    numet  = number of available edgetypes
C    lavset = list of available standard edgetypes
C    lavret = list of available registered edgetypes
C    laviet = list of available implementor-defined edgetypes
C    numew  = number of available edge-widths
C    nomew  = nominal edge-width (DC)
C    minew,maxew = minimum,maximum edge-width (DC)

      CALL PQEDF (SPECWT, 0, ERRIND, NUMET, IDUM1,
     1            NUMEW, NOMEW, MINEW, MAXEW, IDUM2)
      CALL CHKINQ ('pqedf', ERRIND)

      STDDX = 0
      REGDX = 0
      IMPDX = 0

      DO 50 LDX=1, ABS(NUMET)
         CALL PQEDF (SPECWT, LDX, ERRIND, IDUM1, THISET, IDUM2, RDUM1,
     1               RDUM2, RDUM3, IDUM3)
         CALL CHKINQ ('pqedf', ERRIND)
         IF (THISET .GT. PLDASD) THEN
            REGDX = REGDX + 1
            LAVRET(REGDX) = THISET
         ELSEIF (THISET .GE. PLSOLI) THEN
            STDDX = STDDX + 1
            LAVSET(STDDX) = THISET
         ELSE
            IF (IMPDX .LT. IMPMAX) THEN
               IF (NUMET .LT. 0) THEN
                  IMPDX = IMPDX + 1
                  LAVIET (IMPDX) = -LDX
               ELSE
                  IMPDX = IMPDX + 1
                  LAVIET (IMPDX) = THISET
               ENDIF
            ENDIF
         ENDIF
50    CONTINUE

C     szbt = size of edge bundle table
      CALL PQWKSL (SPECWT, ERRIND, IDUM1, IDUM2, IDUM3, IDUM4,
     1             SZBT, IDUM5, IDUM6, IDUM7)
      CALL CHKINQ ('pqwksl', ERRIND)

C  *** *** ***   edge flag indicator   *** *** ***

C  mark start of edge flag indicator
      CALL PLB (1)

C  filon  = number of areas to be drawn with edge flag ON
      NAREA = 8
      FILON = RNDINT (1, NAREA)

C  set edge representations 1--NAREA
      DO 60 IX = 1, NAREA
         IF (IX .LE. FILON) THEN
             CALL PSEDR (WKID, IX, PON,  PSOLID, 1.0, 1)
         ELSE
             CALL PSEDR (WKID, IX, POFF, PSOLID, 1.0, 1)
         ENDIF
60    CONTINUE

C  display in random order bundles 1-NAREA
      CALL RNPERM (NAREA, PERM)
      CALL DRBUED (NAREA, PERM)

C  mark end of edge flag indicator
      CALL PLB (2)
      CALL SETMSG ('3 4 5 6 30 31', 'The edge of a polygonal area '  //
     1             'should be visible when the edge flag is ON and ' //
     2             'not visible when the edge flag is OFF.')

      PROMPT = 'EDGE FLAG INDICATOR: which triangles have visible ' //
     1         'edges? '

      DO 70 IX = 1,NAREA
         RTANS(PERM(IX)) = IX
70    CONTINUE

      CALL DLSTPF (PROMPT, FILON,RTANS, 'S')

C  clear out last display from structure
      CALL PSEP (1)
      CALL PDELLB (1,2)
C
C  *** *** ***   edgetype   *** *** ***
C  stddx = size of lavset
C  set edge representation 1--stddx
      DO 150 IX = 1, STDDX
         CALL PSEDR (WKID, IX, PON, LAVSET(IX) , 1.0, 1)
150   CONTINUE

C  Display in random order bundles 1 thru stddx
      CALL RNPERM (STDDX, PERM)
      CALL DRBUED (STDDX, PERM)

      CALL SETMSG ('3 4 5 6 38 39', 'The standard edgetypes should ' //
     1             'be recognizable from their standard description.')

      PROMPT = 'STANDARD EDGETYPES: List, in order, the numeric ' //
     1         'labels for edgetypes: ' // LDESCR(LAVSET(1))
      RTANS(PERM(1)) = 1
      DO 170 LDX = 2, STDDX
         PROMPT(ITRIM(PROMPT)+1:) = ', ' // LDESCR(LAVSET(LDX))
         RTANS(PERM(LDX)) = LDX
170   CONTINUE
      PROMPT(ITRIM(PROMPT)+1:) = '.'
      CALL DLSTPF (PROMPT, STDDX,RTANS, 'L')

C  clear out last display from structure
      CALL PSEP (1)
      CALL PDELLB (1, 2)

C  regdx = size of lavret
      IF (REGDX .LT. 1) THEN
         CALL INMSG ('No registered edgetypes are supported.')
         GOTO 290
      ENDIF

C  numdis = min(regdx, 8, szbt)
C  lindis = numdis entries, randomly chosen from lavret
      NUMDIS = MIN(REGDX, 8, SZBT)
      CALL RNSET (NUMDIS, REGDX, PERM)
      CALL SRTIAR (NUMDIS, PERM)
      CALL SRTIAR (REGDX, LAVRET)
      CALL LBEDTY (WKID, NUMDIS, PERM, LAVRET)

      CALL SETMSG ('3 4 5 6 38 40', 'The registered edgetypes (> 4) ' //
     1             'should agree with their registered description.')

      CALL DYNPF ('REGISTERED EDGETYPES: Is each edgetype depicted ' //
     1            'according to its numeric identifier''s '          //
     2            'specification in the ISO register? ', 'Y')
C
C  neg_type:
290   CONTINUE

C  clear out last display from structure
      CALL PSEP (1)
      CALL PDELLB (1, 2)

C  impdx = size of laviet
      IF (IMPDX .LT. 1) THEN
         CALL INMSG ('No implementor defined edge types are supported.')
         GOTO 390
      ENDIF

C  numdis = min(impdx, 8, szbt)
C  lindis = numdis entries, randomly chosen from laviet
      NUMDIS = MIN(IMPDX, 8, SZBT)
      CALL RNSET (NUMDIS, IMPDX, PERM)
      CALL SRTIAR (NUMDIS, PERM)
      CALL SRTIAR (IMPDX, LAVIET)
      CALL LBEDTY (WKID, NUMDIS, PERM, LAVIET)

      CALL SETMSG ('3 4 5 6 38 41', 'Implementor-defined edgetypes ' //
     1             '(< 1) should agree with the descriptions '       //
     2             'supplied by the implementor.')

      CALL DYNPF ('IMPLEMENTOR DEFINED EDGETYPES: Is each edgetype ' //
     1            'depicted according to its numeric identifier''s ' //
     2            'specification in the implementor documentation?','Y')

C  end_edgetype:
390   CONTINUE

C  clear out last display from structure
      CALL PSEP (1)
      CALL PDELLB (1, 2)

C  *** *** ***   edge-width   *** *** ***

C  Get minimum line width to allow simulation of edge width
      CALL PQPLF (SPECWT, 0, ERRIND, IDUM1,IDUM2,IDUM3, RDUM1,
     1            MINLW, RDUM2, IDUM4)
      CALL CHKINQ ('pqplf', ERRIND)

C  Are there at least two visually distinguishable edge-widths?
      IF ((NUMEW .EQ. 1) .OR. (MAXEW .LE. 1.02 * MINEW)
     1    .OR. (MAXEW-MINEW .LT.  QVIS))    THEN
         TSTEW1 = MAXEW
         TSTEW2 = TSTEW1
         MULT = 2.0
      ELSE
         TSTEW1 = MINEW
         TSTEW2 = MAXEW
         IF (NUMEW .EQ. 0) THEN
C   continuous range of edgewidths available - take 4 geometric steps
             MULT = 0.9999 * ((TSTEW2/TSTEW1) ** 0.25)
         ELSE
C   discrete set of edgewidths available - test min/max only
             MULT = 0.9999 * (TSTEW2/TSTEW1)
         ENDIF
      ENDIF

C  initialize numpas and thisew
      NUMPAS = 0
      THISEW = TSTEW1

C  loop thru various edgewidths
1000  CONTINUE

C  test bundle with both requested & expected edge width = thisew
      CALL SHEDBW ('VARIOUS EDGEWIDTH SCALE FACTORS', WKID, THISEW,
     1             THISEW, NOMEW, MINLW, PFSW)

      IF (PFSW .EQ. 'A') THEN
         IF (NUMPAS .LT. 2) THEN
            CALL INMSG ('Skipping test case for various scale '     //
     1                  'factors because largest valid edge width ' //
     2                  'is greater than screen size.')
            GOTO 1110
         ELSE
            GOTO 1100
         ENDIF
      ELSEIF (PFSW .NE. 'P') THEN
            NUMPAS = 0
            GOTO 1100
      ENDIF

      NUMPAS = NUMPAS + 1
      THISEW = THISEW * MULT
      IF (THISEW .LE. TSTEW2) GOTO 1000

1100  CONTINUE

C  do_test_msg:
      CALL SETMSG ('3 4 5 6 45 46 47', 'Available edgewidth scale ' //
     1             'factors should control the realized thickness ' //
     2             'of a edge.')
      CALL IFPF (NUMPAS.GT.0)

1110  CONTINUE

C  min_max_coerce:
      CALL SETMSG ('3 4 5 6 45 46 48', 'A requested positive ' //
     1             'edgewidth scale factor below the minimum ' //
     2             'available should be realized as the minimum.')

C  test bundle with requested edge width = minew/2
C                         expected edge width = minew
      CALL SHEDBW ('POSITIVE EDGEWIDTH BELOW MINIMUM', WKID,
     1              MINEW/2, MINEW, NOMEW, MINLW, PFSW)
      CALL IFPF (PFSW .EQ. 'P')

      CALL SETMSG ('3 4 5 6 45 46 48', 'A requested negative '     //
     1             'edgewidth scale factor should be realized as ' //
     2             'the minimum.')
      CALL SHEDBW ('NEGATIVE EDGEWIDTH', WKID, -MAXEW-100,
     1              MINEW, NOMEW, MINLW, PFSW)
      CALL IFPF (PFSW .EQ. 'P')

C  to test requested edge width = maxew*2
C  expected edge width = maxew
      CALL SHEDBW ('POSITIVE EDGEWIDTH ABOVE MAXIMUM', WKID,
     1              MAXEW*2, MAXEW, NOMEW, MINLW, PFSW)

      IF (PFSW.EQ.'A') THEN
         CALL INMSG ('Skipping test case for requested scale factor ' //
     1               'greater than maximum because largest valid '    //
     2               'edge width is greater than screen size.')
      ELSE
         CALL SETMSG ('3 4 5 6 45 46 48', 'A requested edgewidth ' //
     1                'scale factor above the maximum available '  //
     2                'should be realized as the maximum.')
         CALL IFPF (PFSW .EQ. 'P')
      ENDIF

C  *** *** ***   edge color index   *** *** ***
C
      CALL SETMSG ('3 4 5 6 49 50 51', 'A defined edge color index ' //
     1             'should cause the addressed entry in the color '  //
     2             'table to be used when rendering a edge.')
      CALL PSCMD (WKID, PRGB)

C  bckcol = background color = realized color spec for entry #0
C  forcol = foreground color = realized color spec for entry #1
      CALL PQCR (WKID, 0, CSIZ, PREALI, ERRIND, CDIM, BCKCOL)
      CALL CHKINQ ('pqcr', ERRIND)
      CALL PQCR (WKID, 1, CSIZ, PREALI, ERRIND, CDIM, FORCOL)
      CALL CHKINQ ('pqcr', ERRIND)

C  szcolt = maximum size of color table (including entry #0)
      CALL PQWKSL (SPECWT, ERRIND, IDUM1, IDUM2, IDUM3, IDUM4, IDUM5,
     1             IDUM6, SZCOLT, IDUM7)
      CALL CHKINQ ('pqwksl', ERRIND)

C  numdis = number of edges to be drawn
      NUMDIS = MIN (8, SZCOLT, SZBT)

C  edcol  = random permutation of #0,#1, and numdis-2 random choices
C           from entries #2 to #szcolt-1
      CALL RNBSET (NUMDIS-2, 2, SZCOLT-1, EDCOL)
      EDCOL(NUMDIS-1) = 1
      EDCOL(NUMDIS) = 0
      CALL RNPERM (NUMDIS, PERM)

C  visdx = randomly select an entry from edcol to be made visible
      VISDX = RNDINT (1, NUMDIS-1)
      VISCOL = EDCOL(VISDX)

C  ensure dialogue visible
      DTXCI = VISCOL
      CALL PSIASF (PTXCI, PINDIV)
      CALL PSTXCI (VISCOL)

      YLOC  = 0.9
      YINCR = 0.8/(NUMDIS-1)
      XA(1) = 0.3
      XA(2) = 0.7
      XA(3) = 0.5
      CALL NUMLAB (NUMDIS, .25, YLOC+0.3*YINCR, YINCR)
      NPTS(1) = 3

C  for each color entry, set to background color and draw edges
      DO 2110 IX = 1,NUMDIS
         CALL PSEDI (IX)
         YA(1) = YLOC
         YA(2) = YLOC
         YA(3) = YLOC + 0.6*YINCR
         CALL PFAS (1,NPTS, XA, YA)

         PECI = EDCOL(PERM(IX))
         CALL PSCR (WKID, PECI, CDIM, BCKCOL)
         CALL PSEDR (WKID, IX, PON, 1, 1.0, PECI)
         YLOC = YLOC - YINCR
2110  CONTINUE
      CALL PSCR (WKID, VISCOL, CDIM, FORCOL)

      CALL DCHPF ('DEFINED EDGE COLOR INDICES: which triangle is ' //
     1            'visible? ', NUMDIS, VISDX, PERM)

C  clear out last display from structure
      CALL PSEP (1)
      CALL PDELLB (1,2)
C
C  end_def_col:
C
      CALL SETMSG ('3 4 5 6 49 50 52', 'An undefined edge color '    //
     1             'index should cause entry number 1 in the color ' //
     2             'table to be used when rendering an edge.')

C  set entry #1 in color table opposite from BCKCOL
      DO 2300 IX = 1, 3
         IF (BCKCOL(IX) .GT. 0.5) THEN
            NEWCOL(IX) = 0.0
         ELSE
            NEWCOL(IX) = 1.0
         ENDIF
2300  CONTINUE

C  set entry #1 different from FORCOL - make sure undefined default
C  to *current* color-rep of #1, not just a predefined color.
      IF (FORCOL(3) .GT. 0.5) THEN
         NEWCOL(3) = 0.0
      ELSE
         NEWCOL(3) = 1.0
      ENDIF
      CALL PSCR (WKID, 1, CDIM, NEWCOL)
      CALL PQECI (WKID, 0, ERRIND, NUMCI, IDUM1)
      CALL CHKINQ ('pqeci', ERRIND)

      MAXCOL = 0
      DO 2400 IX = 1, NUMCI
         CALL PQECI (WKID, IX, ERRIND, IDUM1, COLEL)
         CALL CHKINQ ('pqeci',ERRIND)
         MAXCOL = MAX(MAXCOL, COLEL)
2400  CONTINUE

C  explct = number of explicit edges of color #1 = random integer
C  from 0 to min(4, szbt-3)
      EXPLCT = RNDINT (0, MIN(4, SZBT-3))
C  display in random order bundles #1 thru explct+3
      NUMDIS = EXPLCT + 3
      CALL RNPERM (NUMDIS, PERM)

C  u1,u2,u3 = 3 undefined, positive color indices
      UNDF(1) = MAXCOL + 1
      UNDF(2) = MAXCOL + 10
      UNDF(3) = MAXCOL + 90

C  draw star with color #1
      CALL PSIASF (PEDCI, PINDIV)
      CALL PSEDCI (1)
      RAD = .15
      CENTX = .5
      CENTY = .75
      PI = 3.14159265
      DO 2500 IX = 1,6
         YA(IX) = CENTY + RAD * COS((4*PI*IX)/5)
         XA(IX) = CENTX + RAD * SIN((4*PI*IX)/5)
2500  CONTINUE
      NPTS(1) = 6
      CALL PFAS (1, NPTS, XA, YA)

C  set up bundles 1 thru 3 with undf, 4 thru (explct+3) with #1
      CALL SETASF (PBUNDL)
      CALL PSIASF (PIS, PINDIV)
      CALL PSIASF (PICI, PINDIV)
      CALL PSIS (PISEMP)
      CALL PSICI (1)
      DO 2600 IX = 1, 3
         CALL PSEDR (WKID, IX, PON, 1, 1.0, UNDF(IX))
2600  CONTINUE
      DO 2610 IX = 4, EXPLCT+3
         CALL PSEDR (WKID, IX, PON, 1, 1.0, 1)
2610  CONTINUE

      XA(1) = 0.3
      XA(2) = 0.7
      XA(3) = 0.7
      XA(4) = 0.3
      YLOC  = 0.5
      YINCR = 0.5 / (NUMDIS+1)
      NPTS(1) = 4
      DO 2700 IX = 1, NUMDIS
         CALL PSEDI (PERM(IX))
         YA(1) = YLOC
         YA(2) = YLOC
         YA(3) = YLOC - 0.5*YINCR
         YA(4) = YA(3)
         CALL PFAS (1, NPTS, XA, YA)
         YLOC = YLOC - YINCR
2700  CONTINUE

      CALL DCHPFV ('UNDEFINED EDGE COLOR INDICES: how many '      //
     1             'rectangles have edges the same color as the ' //
     2             'star?', 12, NUMDIS)

666   CONTINUE
C  wrap it up.
      CALL ENDIT
      END


text:
      SUBROUTINE BMG2_SymStd_SOLVE_cg_unpack(&
     &                Q, Q_SER,&
     &                II, JJ, NGx, NGy, iGs, jGs,&
     &                NProcI, NProcJ, NProc, MyProc,&
     &                ProcCoord,&
     &                MPICOMM&
     &                ) BIND(C, NAME='BMG2_SymStd_SOLVE_cg_unpack')

! ======================================================================
!  --------------------
!   DESCRIPTION:
!  --------------------
!
!     BMG2_SymStd_SOLVE_cg_boxmg solves on the coarsest grid using
!     the serial BoxMG code (BMG2_SER_SymStd_SOLVE_boxmg).
!
! ======================================================================
! $license_flag$
! ======================================================================
!  --------------------
!   INPUT:
!  --------------------
!
!     QF        Refer to BMG2_SymStd_SOLVE_boxmg
!
!     II        Number of grid points in x direction, including
!               two fictitious points.
!     JJ        Number of grid points in y direction, including
!               two fictitious points.
!
! ======================================================================
!  --------------------
!   INPUT/OUTPUT:
!  --------------------
!
!
!
! ======================================================================
!  --------------------
!   OUTPUT:
!  --------------------
!
!     Q         Refer to BMG2_SymStd_SOLVE_boxmg
!
! ======================================================================
!  --------------------
!   LOCAL:
!  --------------------
!
!
! ======================================================================
      USE ModInterface
      IMPLICIT NONE

! ----------------------------
!     Includes
!
      INCLUDE 'BMG_stencils_f90.h'
      INCLUDE 'BMG_constants_f90.h'
      INCLUDE 'BMG_workspace_f90.h'
      INCLUDE 'BMG_parameters_f90.h'

      INCLUDE 'mpif.h'

! ----------------------------
!     Argument Declarations
! ----------------------------

      !
      !  Global/Local indexing
      !
      integer(len_t), VALUE :: II,JJ,&
           NGx,NGy, iGs, jGs

      !
      !  Solution and RHS
      !
      real(real_t) :: Q(II,JJ), Q_SER(*)

      !
      !  Processor grid
      !
      integer(c_int), VALUE :: NProcI, NProcJ, NProc, MyProc
      integer(c_int) :: ProcCoord(2,NProc), ProcGrid(NProcI,NProcJ)

      !
      !  MPI communicator
      !
      integer, VALUE ::  MPICOMM

! ----------------------------
!     Local Declarations
! ----------------------------

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

! ------------------------------------------------
!     Unpack
! ------------------------------------------------

!$$$      MyProcI = ProcCoord(1,MyProc)
!$$$      MyProcJ = ProcCoord(2,MyProc)
!$$$
!$$$      CALL BMG2_SymStd_DUMP_vector(
!$$$     &          BMG_IOFLAG, QF, iONE, NOG,
!$$$     &          II, JJ, NGx, NGy,
!$$$     &          iGs, jGs, 'QF-cg', .FALSE.,
!$$$     &          ProcGrid, NProcI, NProcJ, NProc,
!$$$     &          MyProcI, MyProcJ, MPICOMM
!$$$     &          )
!$$$

! ------------------------------------------------
!     Extract the local data
! ------------------------------------------------

     !  IF ( BMG_iPARMS(id_BMG2_CG_COMM).EQ.BMG_CG_GATHER_SCATTER) THEN

     !     !
     !     ! Broadcast the solution vector
     !     !
     !     CALL MPI_Bcast(&
     ! &            BMG_rWORK_CS(p_U), NGx*NGy, MPI_DOUBLE_PRECISION, &
     ! &            iZERO, MPICOMM, IERR&
     ! &            )

     !  END IF

      CALL BMG2_SymStd_COPY_cg_rV_G_L(&
     &                Q_SER, NGx, NGy,&
     &                Q, II, JJ, iGs, jGs,&
     &                ProcCoord, NProcI, NProcJ,&
     &                Nproc, MyProc&
     &                )

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

      RETURN
      END

max_stars_repo_name: cedar-framework/cedar

max_issues_repo_name: cedar-framework/cedar

max_forks_repo_name: cedar-framework/cedar


!-----------------------------------------------------------------------
      program test
      implicit none
      include 'ceedf.h'

      integer ceed,err
      integer r

      integer ne
      parameter(ne=3)
      integer strides(3)

      character arg*32

      call getarg(1,arg)
      call ceedinit(trim(arg)//char(0),ceed,err)

      strides=[1,2,2]
      call ceedelemrestrictioncreateblockedstrided(ceed,ne,2,2,1,ne+1,&
     & strides,r,err)

      call ceedelemrestrictionview(r,err)

      call ceedelemrestrictiondestroy(r,err)
      call ceeddestroy(ceed,err)

      end
!-----------------------------------------------------------------------


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

max_stars_repo_name: manoelfranca/cilppp

max_issues_repo_name: manoelfranca/cilppp

max_forks_repo_name: manoelfranca/cilppp


text: write (89,100) "Hello world!"

max_issues_repo_name: seanwallawalla-forks/RosettaCodeData

max_forks_repo_name: seanwallawalla-forks/RosettaCodeData


! { dg-do compile }
! { dg-options "-std=f2008" }
!
! PR fortran/48820
!
! Test TYPE(*)

subroutine one(a)
  type(*)  :: a ! { dg-error "TS 29113/TS 18508: Assumed type" }
end subroutine one


text:
SUBROUTINE neo_eval(theta,phi,bval,gval,kval,pval,qval)
! Evaluation of Splines
! **********************************************************************
! Modules
! **********************************************************************
  USE neo_precision
  USE neo_input
  USE neo_work
  USE neo_exchange
  USE neo_units
  USE neo_parameters
  USE neo_control
  USE neo_spline
! **********************************************************************
! Local Definitions
! **********************************************************************
  IMPLICIT NONE

  REAL(kind=dp), INTENT(in)  ::   theta, phi
  REAL(kind=dp), INTENT(out) ::   bval, gval, kval, pval, qval
! **********************************************************************
! Evaluation of pointer
! **********************************************************************
  CALL poi2d(theta_int,phi_int,mt,mp,                                  &
             theta_start,theta_end,phi_start,phi_end,                  &
             theta,phi,theta_ind,phi_ind,theta_d,phi_d,ierr)
! **********************************************************************
! Evaluation of 2d-splines
! **********************************************************************
  CALL eva2d(theta_n,phi_n,theta_ind,phi_ind,theta_d,phi_d,            &
             b_spl,bval)
  CALL eva2d(theta_n,phi_n,theta_ind,phi_ind,theta_d,phi_d,            &
             g_spl,gval)
  CALL eva2d(theta_n,phi_n,theta_ind,phi_ind,theta_d,phi_d,            &
             k_spl,kval)
  CALL eva2d(theta_n,phi_n,theta_ind,phi_ind,theta_d,phi_d,            &
             p_spl,pval)
  IF (calc_cur .EQ. 1) THEN
     CALL eva2d(theta_n,phi_n,theta_ind,phi_ind,theta_d,phi_d,         &
                q_spl,qval)
  END IF
  RETURN
END SUBROUTINE neo_eval

max_stars_repo_name: joseluisvelasco/STELLOPT

max_issues_repo_name: joseluisvelasco/STELLOPT

max_forks_repo_name: joseluisvelasco/STELLOPT


text:
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!Physical Conditions and Initial Abundances
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

!Initial physics variables and final  values. for temp, density and time
initialTemp=10.0;maxTemp=300
initialDens=1.00d2;finalDens=1.00d6
currentTime=0.0;finalTime=1.00d7

!radfield in habing, cosmic ray ionisation rates as multiple of standard
radfield=1.0;zeta=1.0

!Scale freeze out efficiency by an aribtrary value.
fr=1.0;

!Size of cloud set by inner and outer radii (rin and rout). used to calculate extinction.
!baseAv is extinction at cloud edge
!points is number of parcels to run model for. spaced  evenly between rin and rout
rout=0.05;rin=0;baseAv=1.0;points=1

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!Behavioural switches
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!switch (0/1) -> finish model run at (finalTime/finalDens)
switch=1

!collapse (0/1/2/3/4) 1/0 are on/off for standard free-fall. 2/3/4 are different collapse modes noted in cloud.f90
!collape=0/1 ONLY if not using cloud.f90
!In all cases collapse=1 lets chem.f90 know it should call  densdot in the physics module to get time derivative of density and include it in ODES
!Any other values tells it to use density value as set by physics module
collapse=1
!for collapse=1 can introduce factor bc to slow freefall
bc=1.0

!If you want to read abundances from a file (abundFile) set to 1
!If you set to zero, final abundances are written to abundFile
readAbunds=1
!phase chooses behaviour. Basic clouds in phase 1. Hot core /cshock in phase 2 (depending on physics module)
phase=2;

!non-thermal Desorption. Turn it all on/off. Turn off h2, cosmic ray induced and uv induced off separately too
desorb=1;
h2desorb=1;crdesorb=1;uvcr=1;

!evap sets thermal desorption  (0/1/2) -> (none/temp dependent/ instantaneous)
evap=1

!ion sets ionization fraction of carbon. See chem.f90:initialise
ion=2

!cloud module specific variable for phase 2, temp profile depends on mass of star
!Tempindx selects mass: 1=1Msol,2=5,3=10M,4=15M,5=25M,6=60M
tempindx=3

!cshock module specific variable, uncomment or comment as  needed
vs=60.0

!initial fractional abundances of elements(from Asplund et al. 2009 ARAA table 1 -SOLAR)
fh=0.0;fhe = 0.1;fc  = 2.6d-04;fo  = 4.6d-04;fn  = 6.1d-05
fs  = 1.318d-05;fmg = 3.981d-05;fsi = 1.0d-07;fcl = 3.162d-07;
fp=2.57d-09 ; ff = 3.6d-08 !fp depleted 1/100 of solar

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!Input and output Files
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

!A full output of abundances is written by default. Additionally, name species here for
!a columnated output of time,density,temperature and abundances of those species
!Fortran will reject this array if species with shorter names are not padded with spaces at the end.
!array commented so it does not override array in input file.
!If no array is passed in input, no column file is written
!outSpecies=(/'CO ','H2S','OCS','CS '/)

!writeStep sets how often columns written out. Columns written every n steps for writeStep=n.
writeStep=2

!If readAbund=1, starting abundances are read from abundFile
!If readAbund=0, final abundances are written to abundFile
abundFile="output/start/n1000000.dat"
!Full output written to outputFlie
outputFile="output/start/v60n1000000.dat"
!columnated output of time,dens,temp and outSpecies written to column file
columnFile='output/start/columncloud.dat'

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!More complicated parameters that affect core code below. Do not alter without reading articles associated  !
!with each process. eg chemistry variables below are reference in rates.f90                                 !
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

!Chemistry variables
!Description and use found in rate.f90
!Desorption treatment is described in Roberts et al. 2007, these are rates and efficiencies of processes that cause desorption
ebmaxh2=1.21d3;epsilon=0.01;ebmaxcrf=1.21d3;uvcreff=1.0d-3
ebmaxcr=1.21d3;phi=1.0d5;ebmaxuvcr=1.0d4; uvy=0.1
omega=0.5;grainRadius=0.1d-06

max_stars_repo_name: tomasjames/UCLCHEM

max_issues_repo_name: tomasjames/UCLCHEM

max_forks_repo_name: tomasjames/UCLCHEM


text:
C
C $Id: curvi.f,v 1.5 2008-07-27 03:10:10 haley Exp $
C
C                Copyright (C)  2000
C        University Corporation for Atmospheric Research
C                All Rights Reserved
C
C The use of this Software is governed by a License Agreement.
C
C NOTE: If you make any changes to this software, please remember to
C make the same changes to the corresponding double precision routine.
C
      function curvi (xl,xu,n,x,y,yp,sigma)
c
      integer n
      real xl,xu,x(n),y(n),yp(n),sigma
c
c                                 coded by alan kaylor cline
c                           from fitpack -- january 26, 1987
c                        a curve and surface fitting package
c                      a product of pleasant valley software
c                  8603 altus cove, austin, texas 78759, usa
c
c this function integrates a curve specified by a spline
c under tension between two given limits. the subroutine
c curv1 should be called earlier to determine necessary
c parameters.
c
c on input--
c
c   xl and xu contain the upper and lower limits of inte-
c   gration, respectively. (sl need not be less than or
c   equal to xu, curvi (xl,xu,...) .eq. -curvi (xu,xl,...) ).
c
c   n contains the number of points which were specified to
c   determine the curve.
c
c   x and y are arrays containing the abscissae and
c   ordinates, respectively, of the specified points.
c
c   yp is an array from subroutine curv1 containing
c   the values of the second derivatives at the nodes.
c
c and
c
c   sigma contains the tension factor (its sign is ignored).
c
c the parameters n, x, y, yp, and sigma should be input
c unaltered from the output of curv1.
c
c on output--
c
c   curvi contains the integral value.
c
c none of the input parameters are altered.
c
c this function references package modules intrvl and
c snhcsh.
c
c-----------------------------------------------------------
c
c denormalize tension factor
c
      sigmap = abs(sigma)*float(n-1)/(x(n)-x(1))
c
c determine actual upper and lower bounds
c
      xxl = xl
      xxu = xu
      ssign = 1.
      if (xl .lt. xu) go to 1
      xxl = xu
      xxu = xl
      ssign = -1.
      if (xl .gt. xu) go to 1
c
c return zero if xl .eq. xu
c
      curvi = 0.
      return
c
c search for proper intervals
c
    1 ilm1 = intrvl (xxl,x,n)
      il = ilm1+1
      ium1 = intrvl (xxu,x,n)
      iu = ium1+1
      if (il .eq. iu) go to 8
c
c integrate from xxl to x(il)
c
      sum = 0.
      if (xxl .eq. x(il)) go to 3
      del1 = xxl-x(ilm1)
      del2 = x(il)-xxl
      dels = x(il)-x(ilm1)
      t1 = (del1+dels)*del2/(2.*dels)
      t2 = del2*del2/(2.*dels)
      sum = t1*y(il)+t2*y(ilm1)
      if (sigma .eq. 0.) go to 2
      call snhcsh (dummy,c1,sigmap*del1,2)
      call snhcsh (dummy,c2,sigmap*del2,2)
      call snhcsh (ss,cs,sigmap*dels,3)
      sum = sum+((dels*dels*(cs-ss/2.)-del1*del1*(c1-ss/2.))
     *           *yp(il)+del2*del2*(c2-ss/2.)*yp(ilm1))/
     *          (sigmap*sigmap*dels*(1.+ss))
      go to 3
    2 sum = sum-t1*t1*dels*yp(il)/6.
     *         -t2*(del1*(del2+dels)+dels*dels)*yp(ilm1)/12.
c
c integrate over interior intervals
c
    3 if (iu-il .eq. 1) go to 6
      ilp1 = il+1
      do 5 i = ilp1,ium1
        dels = x(i)-x(i-1)
        sum = sum+(y(i)+y(i-1))*dels/2.
        if (sigma .eq. 0.) go to 4
        call snhcsh (ss,cs,sigmap*dels,3)
        sum = sum+(yp(i)+yp(i-1))*dels*(cs-ss/2.)/
     *            (sigmap*sigmap*(1.+ss))
        go to 5
    4   sum = sum-(yp(i)+yp(i-1))*dels*dels*dels/24.
    5   continue
c
c integrate from x(iu-1) to xxu
c
    6 if (xxu .eq. x(ium1)) go to 10
      del1 = xxu-x(ium1)
      del2 = x(iu)-xxu
      dels = x(iu)-x(ium1)
      t1 = del1*del1/(2.*dels)
      t2 = (del2+dels)*del1/(2.*dels)
      sum = sum+t1*y(iu)+t2*y(ium1)
      if (sigma .eq. 0.) go to 7
      call snhcsh (dummy,c1,sigmap*del1,2)
      call snhcsh (dummy,c2,sigmap*del2,2)
      call snhcsh (ss,cs,sigmap*dels,3)
      sum = sum+(yp(iu)*del1*del1*(c1-ss/2.)+yp(ium1)*
     *          (dels*dels*(cs-ss/2.)-del2*del2*(c2-ss/2.)))
     *         /(sigmap*sigmap*dels*(1.+ss))
      go to 10
    7 sum = sum-t1*(del2*(del1+dels)+dels*dels)*yp(iu)/12.
     *         -t2*t2*dels*yp(ium1)/6.
      go to 10
c
c integrate from xxl to xxu
c
    8 delu1 = xxu-x(ium1)
      delu2 = x(iu)-xxu
      dell1 = xxl-x(ium1)
      dell2 = x(iu)-xxl
      dels = x(iu)-x(ium1)
      deli = xxu-xxl
      t1 = (delu1+dell1)*deli/(2.*dels)
      t2 = (delu2+dell2)*deli/(2.*dels)
      sum = t1*y(iu)+t2*y(ium1)
      if (sigma .eq. 0.) go to 9
      call snhcsh (dummy,cu1,sigmap*delu1,2)
      call snhcsh (dummy,cu2,sigmap*delu2,2)
      call snhcsh (dummy,cl1,sigmap*dell1,2)
      call snhcsh (dummy,cl2,sigmap*dell2,2)
      call snhcsh (ss,dummy,sigmap*dels,-1)
      sum = sum+(yp(iu)*(delu1*delu1*(cu1-ss/2.)
     *            -dell1*dell1*(cl1-ss/2.))
     *          +yp(ium1)*(dell2*dell2*(cl2-ss/2.)
     *            -delu2*delu2*(cu2-ss/2.)))/
     *          (sigmap*sigmap*dels*(1.+ss))
      go to 10
    9 sum = sum-t1*(delu2*(dels+delu1)+dell2*(dels+dell1))*
     *             yp(iu)/12.
     *         -t2*(dell1*(dels+dell2)+delu1*(dels+delu2))*
     *             yp(ium1)/12.
c
c correct sign and return
c
   10 curvi = ssign*sum
      return
      end

max_stars_repo_name: tenomoto/ncl

max_issues_repo_name: tenomoto/ncl

max_forks_repo_name: tenomoto/ncl


text:
MODULE c_arrays

  IMPLICIT NONE

CONTAINS

  FUNCTION array_in(n,x) RESULT(y)
    INTEGER, INTENT(in) :: n
    INTEGER, INTENT(in) :: x(n)
    INTEGER :: y
    y = SUM(x)
  END FUNCTION array_in

  ! Test assumed size array
  FUNCTION array_in_2(x) RESULT(y)
    INTEGER, INTENT(in) :: x(*)
    INTEGER :: y
    y = SUM(x(1:4))
  END FUNCTION array_in_2

  SUBROUTINE array_out(nx,ny,x,y)
    INTEGER, INTENT(in) :: nx,ny
    INTEGER, INTENT(out) :: x(nx)
    INTEGER, DIMENSION(ny), INTENT(out) :: y
    x = 20
    y = 30
  END SUBROUTINE  array_out

  FUNCTION inner_prod(n,a,b) RESULT(y)
    INTEGER, INTENT(in) :: n, a(n), b(n)
    INTEGER :: y
    y = DOT_PRODUCT(a,b)
  END FUNCTION inner_prod

END MODULE c_arrays

max_stars_repo_name: mcfarljm/fortwrap

max_issues_repo_name: mcfarljm/fortwrap

max_forks_repo_name: mcfarljm/fortwrap


text:
module Svc {

  @ A component for logging Com buffers
  active component ComLogger {

    # ----------------------------------------------------------------------
    # General ports
    # ----------------------------------------------------------------------

    @ Com input port
    async input port comIn: Fw.Com

    @ Ping input port
    async input port pingIn: Svc.Ping

    @ Ping output port
    output port pingOut: Svc.Ping

    # ----------------------------------------------------------------------
    # Special ports
    # ----------------------------------------------------------------------

    @ Command registration port
    command reg port cmdRegOut

    @ Command received port
    command recv port cmdIn

    @ Command response port
    command resp port cmdResponseOut

    @ Event port
    event port logOut

    @ Text event port
    text event port LogText

    @ Time get port
    time get port timeCaller

    # ----------------------------------------------------------------------
    # Commands
    # ----------------------------------------------------------------------

    include "Commands.fppi"

    # ----------------------------------------------------------------------
    # Events
    # ----------------------------------------------------------------------

    include "Events.fppi"

  }

}

ext: fpp


text:
      subroutine sptr_save (sflag)
!***********************************************************************
!  Copyright, 2004,  The  Regents  of the  University of California.
!  This program was prepared by the Regents of the University of
!  California at Los Alamos National Laboratory (the University) under
!  contract No. W-7405-ENG-36 with the U.S. Department of Energy (DOE).
!  All rights in the program are reserved by the DOE and the University.
!  Permission is granted to the public to copy and use this software
!  without charge, provided that this Notice and any statement of
!  authorship are reproduced on all copies. Neither the U.S. Government
!  nor the University makes any warranty, express or implied, or
!  assumes any liability or responsibility for the use of this software.
!***********************************************************************
!D1
!D1 PURPOSE
!D1
!D1 Perform initial setup functions for the streamline particle
!D1 tracking calculations.
!D1
!***********************************************************************
!D2
!D2 REVISION HISTORY
!D2
!D2 FEHM Version 2.30
!D2
!D2 $Log:   /pvcs.config/fehm90/src/sptr_save.f_a  $
!D2
!***********************************************************************
!D3
!D3 REQUIREMENTS TRACEABILITY
!D3
!D3 2.3.6 Streamline particle-tracking module
!D3
!***********************************************************************
!D4
!D4 SPECIAL COMMENTS AND REFERENCES
!D4
!D4 Requirements from SDN: 10086-RD-2.20-00
!D4   SOFTWARE REQUIREMENTS DOCUMENT (RD) for the
!D4   FEHM Application Version 2.20
!D4
!***********************************************************************

      use comai
      use comdi
      use comsk
      use comsptr
      use comxi

      integer sflag, i, j, k

      open (isptr7, file = nmfil(23), form = cform(23),
     .     status = cstats(23))

      if (sflag .eq. 0) then
! Read stored sptr arrays
         if (cform(23) .eq. 'formatted' .or.
     .        cform(23) .eq. 'FORMATTED') then
            read (isptr7, *) node_count
            if (node_count .ne. 0) then
               read (isptr7, *) (node_omr(i), i = 1, node_count)
               do j = 1, 7
                  read (isptr7, *) (iboulist(i,j), i=1,neq)
               end do
            end if
            do j = -3, 3
               read (isptr7, *) (irray(i,j), i=1,neq)
            end do
            read (isptr7, *) (ddx(i), i=1,neq)
            read (isptr7, *) (ddy(i), i=1,neq)
            read (isptr7, *) (ddz(i), i=1,neq)
            do j = 1, 3
               read (isptr7, *) (corn(i, j), i=1,neq)
            end do
            if (.not. compute_flow) then
               do j = -3, 3
                  read (isptr7, *) (ggg(i, j), i=1,neq)
               end do
            end if
         else
            read (isptr7) node_count
            if (node_count .ne. 0) then
               read (isptr7) (node_omr(i), i = 1, node_count)
               do j = 1, 7
                  read (isptr7) (iboulist(i,j), i=1,neq)
               end do
            end if
            do j = -3, 3
               read (isptr7) (irray(i,j), i=1,neq)
            end do
            read (isptr7) (ddx(i), i=1,neq)
            read (isptr7) (ddy(i), i=1,neq)
            read (isptr7) (ddz(i), i=1,neq)
            do j = 1, 3
               read (isptr7) (corn(i, j), i=1,neq)
            end do
            if (.not. compute_flow) then
               do j = -3, 3
                  read (isptr7) (ggg(i, j), i=1,neq)
               end do
            end if
         end if

      else
! Save sptr arrays
         if (cform(23) .eq. 'formatted' .or.
     .        cform(23) .eq. 'FORMATTED') then
            write (isptr7, *) node_count
            if (node_count .ne. 0) then
               write (isptr7, *) (node_omr(i), i = 1, node_count)
               do j = 1, 7
                  write (isptr7, *) (iboulist(i,j), i=1,neq)
               end do
            end if
            do j = -3, 3
               write (isptr7, *) (irray(i, j), i=1,neq)
            end do
            write (isptr7, *) (ddx(i), i=1,neq)
            write (isptr7, *) (ddy(i), i=1,neq)
            write (isptr7, *) (ddz(i), i=1,neq)
            do j = 1, 3
               write (isptr7, *) (corn(i, j), i=1,neq)
            end do
            if (.not. compute_flow) then
               do j = -3, 3
                  write (isptr7, *) (ggg(i, j), i=1,neq)
               end do
               write(isptr7,*)(ps_trac(i),i=1,neq)
            end if
         else
            write (isptr7) node_count
            if (node_count .ne. 0) then
               write (isptr7) (node_omr(i), i = 1, node_count)
               do j = 1, 7
                  write (isptr7) (iboulist(i,j), i=1,neq)
               end do
            end if
            do j = -3, 3
               write (isptr7) (irray(i, j), i=1,neq)
            end do
            write (isptr7) (ddx(i), i=1,neq)
            write (isptr7) (ddy(i), i=1,neq)
            write (isptr7) (ddz(i), i=1,neq)
            do j = 1, 3
               write (isptr7) (corn(i, j), i=1,neq)
            end do
            if (.not. compute_flow) then
               do j = -3, 3
                  write (isptr7) (ggg(i, j), i=1,neq)
               end do
               write(isptr7)(ps_trac(i),i=1,neq)
            end if
         end if
      end if

      close (isptr7)

      end

max_stars_repo_name: satkarra/FEHM

max_issues_repo_name: satkarra/FEHM

max_forks_repo_name: satkarra/FEHM