text:
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!!!!
!!!!   MIT License
!!!!
!!!!   ParaMonte: plain powerful parallel Monte Carlo library.
!!!!
!!!!   Copyright (C) 2012-present, The Computational Data Science Lab
!!!!
!!!!   This file is part of the ParaMonte library.
!!!!
!!!!   Permission is hereby granted, free of charge, to any person obtaining a
!!!!   copy of this software and associated documentation files (the "Software"),
!!!!   to deal in the Software without restriction, including without limitation
!!!!   the rights to use, copy, modify, merge, publish, distribute, sublicense,
!!!!   and/or sell copies of the Software, and to permit persons to whom the
!!!!   Software is furnished to do so, subject to the following conditions:
!!!!
!!!!   The above copyright notice and this permission notice shall be
!!!!   included in all copies or substantial portions of the Software.
!!!!
!!!!   THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
!!!!   EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
!!!!   MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
!!!!   IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM,
!!!!   DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR
!!!!   OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE
!!!!   OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
!!!!
!!!!   ACKNOWLEDGMENT
!!!!
!!!!   ParaMonte is an honor-ware and its currency is acknowledgment and citations.
!!!!   As per the ParaMonte library license agreement terms, if you use any parts of
!!!!   this library for any purposes, kindly acknowledge the use of ParaMonte in your
!!!!   work (education/research/industry/development/...) by citing the ParaMonte
!!!!   library as described on this page:
!!!!
!!!!       https://github.com/cdslaborg/paramonte/blob/main/ACKNOWLEDGMENT.md
!!!!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

!>  \brief This module contains tests of the module [Err_mod](@ref err_mod).
!>  \author Amir Shahmoradi

module Test_Err_mod

    use Err_mod
    use Decoration_mod, only: TAB
    use Test_mod, only: Test_type
    implicit none

    private
    public :: test_Err

    type(Test_type) :: Test

    character(*), parameter :: mc_prefix =  TAB//TAB//"ParaMonte"
    character(*), parameter :: mc_msg    =  "What does a fish know about the water in which it swims all its life?    Albert Einstein\n" // &
                                            "Everything should be made as simple as possible, but not simpler.    Albert Einstein\n" // &
                                            "The absence of evidence is not evidence for absence.    Carl Sagan\n" // &
                                            "If I have seen further, it is by standing on the shoulders of giants.    Isaac Newton\n" // &
                                            "I don't pretend to understand the universe - it's much bigger than I am.    Thomas Carlyle"

!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

contains

!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

    subroutine test_Err()

        implicit none

        Test = Test_type(moduleName=MODULE_NAME)
        call Test%run(test_note_1, "test_note_1")
        call Test%run(test_note_2, "test_note_2")
        call Test%run(test_warn_1, "test_warn_1")
        call Test%run(test_warn_2, "test_warn_2")
        call Test%run(test_abort_1, "test_abort_1")
        call Test%run(test_abort_2, "test_abort_2")
        call Test%finalize()

    end subroutine test_Err

!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

    function test_note_1() result(assertion)

        use JaggedArray_mod, only: CharVec_type
        use Constants_mod, only: IK
        use String_mod, only: num2str

        implicit none

        integer(IK) :: fileUnit, i, iostat
        logical :: assertion, assertionCurrent
        integer(IK), parameter :: NLINE = 5_IK
        type(CharVec_type), allocatable :: OutputList_ref(:)
        type(CharVec_type), allocatable :: OutputList(:)

        assertion = .true.

        if (allocated(OutputList)) deallocate(OutputList); allocate(OutputList(NLINE))
        if (allocated(OutputList_ref)) deallocate(OutputList_ref); allocate(OutputList_ref(NLINE))

        OutputList_ref(1)%record = "        ParaMonte - NOTE: What does a fish know about the water in which it swims all its life?    Albert Einstein"
        OutputList_ref(2)%record = "        ParaMonte - NOTE: Everything should be made as simple as possible, but not simpler.    Albert Einstein"
        OutputList_ref(3)%record = "        ParaMonte - NOTE: The absence of evidence is not evidence for absence.    Carl Sagan"
        OutputList_ref(4)%record = "        ParaMonte - NOTE: If I have seen further, it is by standing on the shoulders of giants.    Isaac Newton"
        OutputList_ref(5)%record = "        ParaMonte - NOTE: I don't pretend to understand the universe - it's much bigger than I am.    Thomas Carlyle"

        open(newunit = fileUnit, status = "scratch")
        !open(newunit = fileUnit, file = Test%outDir//"/Test_Err_mod@test_note_1."//num2str(Test%Image%id)//".out", status = "replace")

        call note   ( msg = mc_msg &
                    , prefix  = mc_prefix &
                    , newline  = "\n" &
                    , outputUnit = fileUnit &
                    , marginTop = 0_IK &
                    , marginBot = 0_IK &
                    )

        rewind(fileUnit)

        do i = 1, NLINE

            if(allocated(OutputList(i)%record)) deallocate(OutputList(i)%record)
            allocate(character(132) :: OutputList(i)%record)

            read(fileUnit,"(A132)", iostat = iostat) OutputList(i)%record
            assertion = iostat == 0_IK
            if (.not. assertion) return ! LCOV_EXCL_LINE

            OutputList(i)%record = trim(OutputList(i)%record)

            assertionCurrent = OutputList(i)%record == OutputList_ref(i)%record
            assertion = assertion .and. assertionCurrent

            if (Test%isVerboseMode .and. .not. assertionCurrent) then
            ! LCOV_EXCL_START
                write(Test%outputUnit,"(*(g0))")
                write(Test%outputUnit,"(*(g0))") "OutputList_ref(",num2str(i),")%record = ", OutputList_ref(i)%record
                write(Test%outputUnit,"(*(g0))") "OutputList    (",num2str(i),")%record = ", OutputList(i)%record
                write(Test%outputUnit,"(*(g0))")
            end if
            ! LCOV_EXCL_STOP

        end do

    end function test_note_1

!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

    function test_note_2() result(assertion)

        use JaggedArray_mod, only: CharVec_type
        use Constants_mod, only: IK, NLC
        use String_mod, only: num2str, replaceStr

        implicit none

        integer(IK) :: fileUnit, i, iostat
        logical :: assertion, assertionCurrent
        integer(IK), parameter :: NLINE = 7_IK
        type(CharVec_type), allocatable :: OutputList_ref(:)
        type(CharVec_type), allocatable :: OutputList(:)

        assertion = .true.

        if (allocated(OutputList)) deallocate(OutputList); allocate(OutputList(NLINE))
        if (allocated(OutputList_ref)) deallocate(OutputList_ref); allocate(OutputList_ref(NLINE))

        OutputList_ref(1)%record = ""
        OutputList_ref(2)%record = " - NOTE: What does a fish know about the water in which it swims all its life?    Albert Einstein"
        OutputList_ref(3)%record = " - NOTE: Everything should be made as simple as possible, but not simpler.    Albert Einstein"
        OutputList_ref(4)%record = " - NOTE: The absence of evidence is not evidence for absence.    Carl Sagan"
        OutputList_ref(5)%record = " - NOTE: If I have seen further, it is by standing on the shoulders of giants.    Isaac Newton"
        OutputList_ref(6)%record = " - NOTE: I don't pretend to understand the universe - it's much bigger than I am.    Thomas Carlyle"
        OutputList_ref(7)%record = ""

        open(newunit = fileUnit, status = "scratch")
        !open(newunit = fileUnit, file = Test%outDir//"/Test_Err_mod@test_note_2."//num2str(Test%Image%id)//".out", status = "replace")

        call note   ( msg = replaceStr(mc_msg, "\n", NLC) &
                    , outputUnit = fileUnit &
                    , newline  = NLC &
                    )

        rewind(fileUnit)

        do i = 1, NLINE

            if(allocated(OutputList(i)%record)) deallocate(OutputList(i)%record)
            allocate(character(132) :: OutputList(i)%record)

            read(fileUnit,"(A132)", iostat = iostat) OutputList(i)%record
            assertion = iostat == 0_IK
            if (.not. assertion) return ! LCOV_EXCL_LINE

            OutputList(i)%record = trim(OutputList(i)%record)

            assertionCurrent = OutputList(i)%record == OutputList_ref(i)%record
            assertion = assertion .and. assertionCurrent

            if (Test%isVerboseMode .and. .not. assertionCurrent) then
            ! LCOV_EXCL_START
                write(Test%outputUnit,"(*(g0))")
                write(Test%outputUnit,"(*(g0))") "OutputList_ref(",num2str(i),")%record = ", OutputList_ref(i)%record
                write(Test%outputUnit,"(*(g0))") "OutputList    (",num2str(i),")%record = ", OutputList(i)%record
                write(Test%outputUnit,"(*(g0))")
            end if
            ! LCOV_EXCL_STOP

        end do

    end function test_note_2

!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

    function test_warn_1() result(assertion)

        use JaggedArray_mod, only: CharVec_type
        use Constants_mod, only: IK
        use String_mod, only: num2str

        implicit none

        integer(IK) :: fileUnit, i, iostat
        logical :: assertion, assertionCurrent
        integer(IK), parameter :: NLINE = 5_IK
        type(CharVec_type), allocatable :: OutputList_ref(:)
        type(CharVec_type), allocatable :: OutputList(:)

        assertion = .true.

        if (allocated(OutputList)) deallocate(OutputList); allocate(OutputList(NLINE))
        if (allocated(OutputList_ref)) deallocate(OutputList_ref); allocate(OutputList_ref(NLINE))

        OutputList_ref(1)%record = "        ParaMonte - WARNING: What does a fish know about the water in which it swims all its life?    Albert Einstein"
        OutputList_ref(2)%record = "        ParaMonte - WARNING: Everything should be made as simple as possible, but not simpler.    Albert Einstein"
        OutputList_ref(3)%record = "        ParaMonte - WARNING: The absence of evidence is not evidence for absence.    Carl Sagan"
        OutputList_ref(4)%record = "        ParaMonte - WARNING: If I have seen further, it is by standing on the shoulders of giants.    Isaac Newton"
        OutputList_ref(5)%record = "        ParaMonte - WARNING: I don't pretend to understand the universe - it's much bigger than I am.    Thomas Carlyle"

        open(newunit = fileUnit, status = "scratch")
        !open(newunit = fileUnit, file = Test%outDir//"/Test_Err_mod@test_warn_1."//num2str(Test%Image%id)//".out", status = "replace")

        call warn   ( msg = mc_msg &
                    , prefix  = mc_prefix &
                    , newline  = "\n" &
                    , outputUnit = fileUnit &
                    , marginTop = 0_IK &
                    , marginBot = 0_IK &
                    )

        rewind(fileUnit)

        do i = 1, NLINE

            if(allocated(OutputList(i)%record)) deallocate(OutputList(i)%record)
            allocate(character(132) :: OutputList(i)%record)

            read(fileUnit,"(A132)", iostat = iostat) OutputList(i)%record
            assertion = iostat == 0_IK
            if (.not. assertion) return ! LCOV_EXCL_LINE

            OutputList(i)%record = trim(OutputList(i)%record)

            assertionCurrent = OutputList(i)%record == OutputList_ref(i)%record
            assertion = assertion .and. assertionCurrent

            if (Test%isVerboseMode .and. .not. assertionCurrent) then
            ! LCOV_EXCL_START
                write(Test%outputUnit,"(*(g0))")
                write(Test%outputUnit,"(*(g0))") "OutputList_ref(",num2str(i),")%record = ", OutputList_ref(i)%record
                write(Test%outputUnit,"(*(g0))") "OutputList    (",num2str(i),")%record = ", OutputList(i)%record
                write(Test%outputUnit,"(*(g0))")
            end if
            ! LCOV_EXCL_STOP

        end do

    end function test_warn_1

!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

    function test_warn_2() result(assertion)

        use JaggedArray_mod, only: CharVec_type
        use Constants_mod, only: IK, NLC
        use String_mod, only: num2str, replaceStr

        implicit none

        integer(IK) :: fileUnit, i, iostat
        logical :: assertion, assertionCurrent
        integer(IK), parameter :: NLINE = 7_IK
        type(CharVec_type), allocatable :: OutputList_ref(:)
        type(CharVec_type), allocatable :: OutputList(:)

        assertion = .true.

        if (allocated(OutputList)) deallocate(OutputList); allocate(OutputList(NLINE))
        if (allocated(OutputList_ref)) deallocate(OutputList_ref); allocate(OutputList_ref(NLINE))

        OutputList_ref(1)%record = ""
        OutputList_ref(2)%record = " - WARNING: What does a fish know about the water in which it swims all its life?    Albert Einstein"
        OutputList_ref(3)%record = " - WARNING: Everything should be made as simple as possible, but not simpler.    Albert Einstein"
        OutputList_ref(4)%record = " - WARNING: The absence of evidence is not evidence for absence.    Carl Sagan"
        OutputList_ref(5)%record = " - WARNING: If I have seen further, it is by standing on the shoulders of giants.    Isaac Newton"
        OutputList_ref(6)%record = " - WARNING: I don't pretend to understand the universe - it's much bigger than I am.    Thomas Carlyle"
        OutputList_ref(7)%record = ""

        open(newunit = fileUnit, status = "scratch")
        !open(newunit = fileUnit, file = Test%outDir//"/Test_Err_mod@test_warn_2."//num2str(Test%Image%id)//".out", status = "replace")

        call warn   ( msg = replaceStr(mc_msg, "\n", NLC) &
                    , outputUnit = fileUnit &
                    , newline  = NLC &
                    )

        rewind(fileUnit)

        do i = 1, NLINE

            if(allocated(OutputList(i)%record)) deallocate(OutputList(i)%record)
            allocate(character(132) :: OutputList(i)%record)

            read(fileUnit,"(A132)", iostat = iostat) OutputList(i)%record
            assertion = iostat == 0_IK
            if (.not. assertion) return ! LCOV_EXCL_LINE

            OutputList(i)%record = trim(OutputList(i)%record)

            assertionCurrent = OutputList(i)%record == OutputList_ref(i)%record
            assertion = assertion .and. assertionCurrent

            if (Test%isVerboseMode .and. .not. assertionCurrent) then
            ! LCOV_EXCL_START
                write(Test%outputUnit,"(*(g0))")
                write(Test%outputUnit,"(*(g0))") "OutputList_ref(",num2str(i),")%record = ", OutputList_ref(i)%record
                write(Test%outputUnit,"(*(g0))") "OutputList    (",num2str(i),")%record = ", OutputList(i)%record
                write(Test%outputUnit,"(*(g0))")
            end if
            ! LCOV_EXCL_STOP

        end do

    end function test_warn_2

!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

    function test_abort_1() result(assertion)

        use JaggedArray_mod, only: CharVec_type
        use Constants_mod, only: IK
        use String_mod, only: num2str

        implicit none

        integer(IK) :: fileUnit, i, iostat
        logical :: assertion, assertionCurrent
        integer(IK), parameter :: NLINE = 6_IK
        type(CharVec_type), allocatable :: OutputList_ref(:)
        type(CharVec_type), allocatable :: OutputList(:)
        type(Err_type) :: Err

        assertion = .true.
        mv_isTestingMode = .true.

        if (allocated(OutputList)) deallocate(OutputList); allocate(OutputList(NLINE))
        if (allocated(OutputList_ref)) deallocate(OutputList_ref); allocate(OutputList_ref(NLINE))

        OutputList_ref(1)%record = ""
        OutputList_ref(2)%record = "        ParaMonte - FATAL: What does a fish know about the water in which it swims all its life?    Albert Einstein"
        OutputList_ref(3)%record = "        ParaMonte - FATAL: Everything should be made as simple as possible, but not simpler.    Albert Einstein"
        OutputList_ref(4)%record = "        ParaMonte - FATAL: The absence of evidence is not evidence for absence.    Carl Sagan"
        OutputList_ref(5)%record = "        ParaMonte - FATAL: If I have seen further, it is by standing on the shoulders of giants.    Isaac Newton"
        OutputList_ref(6)%record = "        ParaMonte - FATAL: I don't pretend to understand the universe - it's much bigger than I am.    Thomas Carlyle"

        open(newunit = fileUnit, status = "scratch")
        !open(newunit = fileUnit, file = Test%outDir//"/Test_Err_mod@test_abort_1."//num2str(Test%Image%id)//".out", status = "replace")

        Err%msg = mc_msg
        call abort  ( Err = Err &
                    , prefix  = mc_prefix &
                    , newline  = "\n" &
                    , outputUnit = fileUnit &
                    , returnEnabled = .true. &
                    )

        rewind(fileUnit)

        do i = 1, NLINE

            if(allocated(OutputList(i)%record)) deallocate(OutputList(i)%record)
            allocate(character(132) :: OutputList(i)%record)

            read(fileUnit,"(A132)", iostat = iostat) OutputList(i)%record
            assertion = iostat == 0_IK
            if (.not. assertion) return ! LCOV_EXCL_LINE

            OutputList(i)%record = trim(OutputList(i)%record)

            assertionCurrent = OutputList(i)%record == OutputList_ref(i)%record
            assertion = assertion .and. assertionCurrent

            if (Test%isVerboseMode .and. .not. assertionCurrent) then
            ! LCOV_EXCL_START
                write(Test%outputUnit,"(*(g0))")
                write(Test%outputUnit,"(*(g0))") "OutputList_ref(",num2str(i),")%record = ", OutputList_ref(i)%record
                write(Test%outputUnit,"(*(g0))") "OutputList    (",num2str(i),")%record = ", OutputList(i)%record
                write(Test%outputUnit,"(*(g0))")
            end if
            ! LCOV_EXCL_STOP

        end do

    end function test_abort_1

!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

    !> \brief
    !> Test the effects of an input non-null error code `Err%stat`.
    !> Test the effects of missing arguments `prefix`, `returnEnabled`, and `newline`.
    function test_abort_2() result(assertion)

        use JaggedArray_mod, only: CharVec_type
        use Constants_mod, only: IK, NLC
        use String_mod, only: num2str, replaceStr

        implicit none

        integer(IK) :: fileUnit, i, iostat
        logical :: assertion, assertionCurrent
        integer(IK), parameter :: NLINE = 7_IK
        type(CharVec_type), allocatable :: OutputList_ref(:)
        type(CharVec_type), allocatable :: OutputList(:)
        type(Err_type) :: Err

        assertion = .true.
        mv_isTestingMode = .true.

        if (allocated(OutputList)) deallocate(OutputList); allocate(OutputList(NLINE))
        if (allocated(OutputList_ref)) deallocate(OutputList_ref); allocate(OutputList_ref(NLINE))

        OutputList_ref(1)%record = ""
        OutputList_ref(2)%record = " - FATAL: What does a fish know about the water in which it swims all its life?    Albert Einstein"
        OutputList_ref(3)%record = " - FATAL: Everything should be made as simple as possible, but not simpler.    Albert Einstein"
        OutputList_ref(4)%record = " - FATAL: The absence of evidence is not evidence for absence.    Carl Sagan"
        OutputList_ref(5)%record = " - FATAL: If I have seen further, it is by standing on the shoulders of giants.    Isaac Newton"
        OutputList_ref(6)%record = " - FATAL: I don't pretend to understand the universe - it's much bigger than I am.    Thomas Carlyle"
        OutputList_ref(7)%record = " - FATAL: Error Code: 123."

        open(newunit = fileUnit, status = "scratch")
        !open(newunit = fileUnit, file = Test%outDir//"/Test_Err_mod@test_abort_2."//num2str(Test%Image%id)//".out", status = "replace")

        Err%msg = replaceStr(mc_msg, "\n", NLC)
        Err%stat = 123_IK
        call abort  ( Err = Err &
                    , outputUnit = fileUnit &
                    )

        rewind(fileUnit)

        do i = 1, NLINE

            if(allocated(OutputList(i)%record)) deallocate(OutputList(i)%record)
            allocate(character(132) :: OutputList(i)%record)

            read(fileUnit,"(A132)", iostat = iostat) OutputList(i)%record
            assertion = iostat == 0_IK
            if (.not. assertion) return ! LCOV_EXCL_LINE

            OutputList(i)%record = trim(OutputList(i)%record)

            assertionCurrent = OutputList(i)%record == OutputList_ref(i)%record
            assertion = assertion .and. assertionCurrent

            if (Test%isVerboseMode .and. .not. assertionCurrent) then
            ! LCOV_EXCL_START
                write(Test%outputUnit,"(*(g0))")
                write(Test%outputUnit,"(*(g0))") "OutputList_ref(",num2str(i),")%record = '", OutputList_ref(i)%record, "'"
                write(Test%outputUnit,"(*(g0))") "OutputList    (",num2str(i),")%record = '", OutputList(i)%record, "'"
                write(Test%outputUnit,"(*(g0))")
            end if
            ! LCOV_EXCL_STOP

        end do

    end function test_abort_2

!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

end module Test_Err_mod ! LCOV_EXCL_LINE

max_stars_repo_name: cdslaborg/paramonte

max_issues_repo_name: cdslaborg/paramonte

max_forks_repo_name: cdslaborg/paramonte


text:
Quessenberrys Drug Store used to be downtown. It has Departed Businesses passed into Davis Town History history. It was located on 2nd Street, in the middle of the block between E and F Streets. The Avid Reader Bookstore now occupies the site. Quessenberrys fell victim to the corporatization of pharmacies, as did the Star Pharmacy (also on 2nd, at the northwest corner of 2nd and D). Originally owned and operated by Clay Quessenberry, the pharmacy continued in business after Quessenberrys death in the early seventies (1971?), until sometime in the mideighties when it finally closed. Jerry Sampo was a longtime pharmacist at Quessenberrys, and Quessenberrys daughter continued to work there until it closed. Woodlands Corner Drugstore on Main Street is an example of the few remaining independent drugstores left.

Years?

I have pictures of the inside of Quesenberrys. My grandmother Elspet McMurtry worked there for years. They used to have a Soda Fountain in the back of the store that served Ice Cream and sandwiches. What I remember most about Quesenberrys was the cheap candy selections. The Varsity Theater used to have kids film festivals where we saw, Pippi Longstocking, Sinbad and other movies. Before the movie we would all run into Quesenberrys and buy 1025 cent candy, Sprees in the foil packages, Taffy, Jolly Rodger Sticks, Charleston Chews, Wax Bottles, Gold Rush Gum, Necco Waffers, Sugar Daddys, Pixie Sticks, Bottle Caps, etc. Nana always waited on us kids and spoiled us rotten.  I remember Jerry Sampo well, he would always tease me and ask if I was married yet, keep in mind that I was 78 at the time.

20050410 15:40:42 nbsp I believe there is only one s ...as i Quesenberry but I could be wrong. Also it sat in the building that now houses The Avid Reader and some floral shop. So that would be 2nd street between E and F streets. Users/JimSchwab

20050410 23:52:59 nbsp I miss Quessenberrys! They had a great candy selection, and I used to grab a box or two of candy to take with me to a movie at the Varsity, back when it still showed firstrun movies. It was a large, clean, welllit drugstore with generally friendly employees.  Users/CentralDavisite

20050727 02:09:51 nbsp This name looks REALLY familiar...I think I saw an old pic of it hanging at RiteAid? Damnit I know I saw like two or three pics of old downtown Davis, and them specifically pointing out a pharmacy...confirmation anyone? Users/AndreHarris

20050930 17:33:22 nbsp Yes, there is an old picture of Quessenberrys Drug Store in RiteAid.  Its right behind the checkout counters. Users/AllisonEriksen

20051001 02:52:38 nbsp I think its funny how Corporate establishments try to honor the thing they (or their ilk) distroyed...  Look at the Alhambra Theater in Sac and the little tribute to it in the Safeway built atop its site.  And theres the little Quessenberrys photo at Rite Aid.  I wonder if that exists elsewhere in the area? Users/JaimeRaba

  Responding to a 6 year old past here (yes I have some free time), and its off topic a bit, but I want to inform those that dont know, and set the record straight:  While the premise of big coporate store crushes local mom and pop is accurate in the case of Quessenberrys, the comparison to the Alhambra is unfair.  It is a misconception that Safeway was responsible for razing the Alhambra Theatre in 1973.  Safeway did purchase the land and ended up destroying the existing property, but the fact is the fault was not with Safeway, but by the people of Sacramento.  Safeway Stores, upon hearing the tremendous public outcry of its potential destruction, offered the building and property back to the City of Sacramento for exactly what they paid for it. A special bond measure election was held to raise money to buy the property, and Sacramentans, likely not interested in additional taxes at that time, voted against it. With no acceptance by the City or any private party to buy the Alhambra, Safeway proceeded with their development. Users/OldDavis73

20081006 09:46:44 nbsp I use to work for Jerry Sampo at Quessenberry Drug Store in the late 70s. It was a local Rexall drug store with several counters/departments: 1) The Pharmacy counter/Gift Wrap; 2) The Cosmetics Counter and 3)The Cigarettes, Candy, Film and Watches Main Checkout Counters. The clerks wore blue smocks and we worked very long hours since the store was open 7 days per week.

Back then, we use to deliver prescriptions to our  customers in the Quessenberry Opal station wagon and later upgraded to a blue Ford Pinto. This service was free. We use to offer credit to our customers and free gift wrap.

When the kids would flock in to attend a movie at the Varsity Theater, we always sent a clerk to supervise the candy selection process since we didnt have in store video cameras back then.

For me, the job was challenging when we didnt have a male working and a woman appeared in the cosmetics counter. We would usually flip a coin to see who would help her. We use to unpack and stock the inventory and even wash the windows and vacuum. There were only a few male clerks that liked to gift wrap, I was not one of them. The main film counter was the domain of Velda Stanley who worked there for many years. I thought some of the kids were afraid of her which I think helped for store security. She was a very nice woman with many stories and personal advice.

Jerry was a great guy and for many of us, he was our mentor for retail and small business ownership in America.  Users/Martinog

20110804 15:22:12 nbsp Loved loading up on those Lemonheads and Cherry Chans before going to the matinees at the Varsity. Users/OldDavis73

ext: f

max_stars_repo_name: voflo/Search

max_issues_repo_name: voflo/Search

max_forks_repo_name: voflo/Search


text:
      SUBROUTINE PLTMRG
C
C     MODULE PLTMRG WRITES GINO DATA BLOCKS WHICH ARE USED AS INPUT TO
C     THE PLOT MODULE FOR PLOTTING A SUBSTRUCTURE.
C
C     APRIL 1974
C
      LOGICAL IDENT
      INTEGER BUF      ,SYSBUF   ,Z(3)     ,CASESS   ,PCDB    ,
     1        PLTP     ,GPS      ,ELS      ,BGP      ,CASEP   ,
     2        EQEX     ,SCR1     ,SRD      ,PLTS     ,FILE    ,
     3        EQSS     ,SUBR(2)  ,CASECC(2),BUF1     ,ELID    ,
     4        BUF2     ,BUF3     ,BUF4     ,BUF5     ,RC      ,
     5        BAR      ,QUAD4    ,TRIA3    ,OFFSET
      REAL    RZ
      COMMON /BLANK /   NAME(2)  ,NGPTOT   ,LSIL     ,NPSET   ,
     1                  NM(2)    ,BUF(7)
      COMMON /SYSTEM/   SYSBUF
      COMMON /NAMES /   RD       ,RDREW    ,WRT      ,WRTREW  ,
     1                  REW      ,NOREW
      COMMON /ZZZZZZ/   RZ(1)
      EQUIVALENCE       (Z(1),RZ(1))
      DATA    PLTS  ,   EQSS     ,SUBR               ,CASECC          /
     1        4HPLTS,   4HEQSS   ,4HPLTM   ,4HRG     ,4HCASE   ,4HCC  /
      DATA    CASESS,   PCDB     ,PLTP     ,GPS      ,ELS      /
     1        101   ,   102      ,201      ,202      ,203      /,
     2        BGP   ,   CASEP    ,EQEX     ,SCR1     ,SRD      /
     3        204   ,   205      ,206      ,301      ,1        /,
     4        BAR   ,   QUAD4    ,TRIA3                        /
     5        2HBR  ,   2HQ4     ,2HT3                         /
C
C     INITIALIZE
C
      NCORE = KORSZ(Z)
      BUF1  = NCORE- SYSBUF + 1
      BUF2  = BUF1 - SYSBUF
      BUF3  = BUF2 - SYSBUF
      BUF4  = BUF3 - SYSBUF
      BUF5  = BUF4 - SYSBUF
      NCORE = BUF5 - 1
      NGPTOT= 0
      LSIL  = 0
      NPSET =-1
      IF (NCORE .LE. 0) GO TO 9008
      CALL SOFOPN (Z(BUF3),Z(BUF4),Z(BUF5))
C
C     STRIP SUBSTRUCTURE RECORDS FROM CASESS AND WRITE CASEP (CASECC)
C
      FILE = CASESS
      CALL OPEN (*9001,CASESS,Z(BUF1),RDREW)
      FILE = CASEP
      CALL OPEN  (*9001,CASEP,Z(BUF2),WRTREW)
      CALL FNAME (CASEP,BUF)
      CALL WRITE (CASEP,BUF,2,1)
      FILE = CASESS
   10 CALL READ (*9002,*9003,CASESS,Z,2,1,NWDS)
      IF (Z(1).NE.CASECC(1) .OR. Z(2).NE.CASECC(2)) GO TO 10
   20 CALL READ (*40,*30,CASESS,Z,NCORE,1,NWDS)
      GO TO 9008
   30 CALL WRITE (CASEP,Z,NWDS,1)
      GO TO 20
   40 CALL CLSTAB (CASEP,REW)
      CALL CLOSE  (CASESS,REW)
C
C     BASIC GRID POINT DATA
C
      NM(1) = NAME(1)
      NM(2) = NAME(2)
      ITEM  = PLTS
      CALL SFETCH (NAME,PLTS,SRD,RC)
      IF (RC .NE. 1) GO TO 6100
C
C     READ SUBSTRUCTURE NAMES AND TRANSFORMATION DATA INTO OPEN CORE.
C
      CALL SUREAD (Z,3,NWDS,RC)
      IF (RC .NE. 1) GO TO 6106
      NSS = Z(3)
      IF (14*NSS .GT. NCORE) GO TO 9008
      CALL SUREAD (Z,14*NSS,NWDS,RC)
      IF (RC .NE. 1) GO TO 6106
      ICORE = 14*NSS + 1
C
C     READ THE BASIC GRID POINT DATA FROM THE PLTS ITEM OF EACH BASIC
C     SUBSTRUCTURE COMPRISING THE PSEUDOSTRUCTURE TO BE PLOTTED.
C     TRANSFORM THE COORDINATES TO THE BASIC COORDINATE SYSTEM OF THE
C     PSEUDOSTRUCTURE AND WRITE THEM ON BGP (BGPDT).
C
      FILE = BGP
      CALL OPEN (*9001,BGP,Z(BUF1),WRTREW)
      CALL FNAME (BGP,BUF)
      CALL WRITE (BGP,BUF,2,1)
      J = 1
  120 NM(1) = Z(J  )
      NM(2) = Z(J+1)
      NGP = 0
      CALL SFETCH (NM,PLTS,SRD,RC)
      IF (RC .EQ. 1) GO TO 130
      CALL SMSG (RC-2,PLTS,NM)
      GO TO 170
  130 I = 1
      CALL SJUMP (I)
      IDENT = .FALSE.
      DO 140 I = 1,3
      IF (Z(J+I+1) .NE. 0) GO TO 150
      IF (Z(J+I+5) .NE. 0) GO TO 150
      IF (Z(J+I+9) .NE. 0) GO TO 150
      IF (ABS(RZ(J+4*I+1)-1.0) .GT. 1.0E-4) GO TO 150
  140 CONTINUE
      IDENT = .TRUE.
  150 CALL SUREAD (BUF,4,NWDS,RC)
      IF (RC .EQ. 2) GO TO 170
      NGP = NGP + 1
      IF (IDENT .OR. BUF(1).LT.0) GO TO 160
      BUF(5) = Z(J+2)
      BUF(6) = Z(J+3)
      BUF(7) = Z(J+4)
      CALL GMMATS (Z(J+5),3,3,-2,BUF(2),3,1,0,BUF(5))
      CALL WRITE (BGP,BUF,1,0)
      CALL WRITE (BGP,BUF(5),3,0)
      GO TO 150
  160 CALL WRITE (BGP,BUF,4,0)
      GO TO 150
  170 NGPTOT = NGPTOT+NGP
      Z(J+2) = NGP
      J = J + 14
      IF (J .LT. ICORE) GO TO 120
      CALL WRITE (BGP,0,0,1)
      CALL CLOSE (BGP,REW)
      BUF(1) = BGP
      BUF(2) = NGPTOT
      DO 180 I = 3,7
  180 BUF(I) = 0
      CALL WRTTRL (BUF)
C
C     ALLOCATE 5 WORDS PER COMPONENT BASIC SUBSTRUCTURE AT THE TOP OF
C     OPEN CORE.  THIS ARRAY IS HEREINAFTER REFERRED TO AS *SDATA*
C
C     SAVE THE BASIC SUBSTRUCTURE NAMES AND THE NUMBER OF STRUCTURAL
C     GRID POINTS IN EACH IN SDATA.  DO NOT SAVE SUBSTRUCTURES FOR
C     WHICH NO PLTS ITEM WAS FOUND.
C
      J = 1
      DO 190 I = 1,NSS
      IF (Z(14*I-11) .EQ. 0) GO TO 190
      Z(J  ) = Z(14*I-13)
      Z(J+1) = Z(14*I-12)
      Z(J+2) = Z(14*I-11)
      J = J + 5
  190 CONTINUE
      IF (J .LE. 1) GO TO 9200
      NSS = J/5
      ISX = NSS*5
      ICORE = J
      LCORE = NCORE - J + 1
C
C     COMPUTE EQEX (EQEXIN)
C
C
C     READ THE EQEXIN DATA FROM THE PLTS ITEM OF EACH BASIC SUBSTRUCTURE
C     USE THREE WORDS IN OPEN CORE FOR EACH GRID POINT   (1) EXTERNAL
C     ID, (2) INTERNAL ID, (3) SUBSTRUCTURE SEQUENCE NUMBER IN SDATA.
C     INCREMENT THE INTERNAL IDS BY THE NUMBER OF GRID POINTS ON THE
C     PRECEDING SUBSTRUCTURES.
C
      K   = ICORE
      NGP = 0
      DO 210 I = 1,NSS
      NM(1) = Z(5*I-4)
      NM(2) = Z(5*I-3)
      CALL SFETCH (NM,PLTS,SRD,RC)
      N = 2
      CALL SJUMP (N)
      RC = 3
      IF (N .LT. 0) GO TO 6106
      N = Z(5*I-2)
      DO 200 J = 1,N
      CALL SUREAD (Z(K),2,NWDS,RC)
      IF (RC .NE. 1) GO TO 6106
      Z(K+1) = Z(K+1) + NGP
      Z(K+2) = I
      K = K + 3
      IF (K+2 .GT. NCORE) GO TO 9008
  200 CONTINUE
      NGP = NGP + N
  210 CONTINUE
C
C     SORT ON EXTERNAL IDS AND WRITE RECORD 1 OF EQEX.
C
      CALL SORT (0,0,3,1,Z(ICORE),3*NGP)
      FILE = EQEX
      CALL OPEN (*9001,EQEX,Z(BUF1),WRTREW)
      CALL FNAME (EQEX,BUF)
      CALL WRITE (EQEX,BUF,2,1)
      DO 220 I = 1,NGP
  220 CALL WRITE (EQEX,Z(ICORE+3*I-3),2,0)
      CALL WRITE (EQEX,0,0,1)
C
C     SAVE THE TABLE IN OPEN CORE ON SCR1 TO USE IN COMPUTING RECORD 2
C     OF EQEX
C
      FILE = SCR1
      CALL OPEN  (*9001,SCR1,Z(BUF2),WRTREW)
      CALL WRITE (SCR1,Z(ICORE),3*NGP,1)
      CALL CLOSE (SCR1,REW)
      CALL OPEN  (*9001,SCR1,Z(BUF2),RDREW)
C
C     READ GROUP 0 OF THE EQSS ITEM OF THE SUBSTRUCTURE TO BE PLOTTED
C     INTO OPEN CORE AT ICORE.  READ THE EXTERNAL AND INTERNAL IDS FOR
C     EACH CONTRIBUTING BASIC SUBSTRUCTURE INTO OPEN CORE FOLLOWING
C     GROUP 0.  SAVE THE CORE POINTERS FOR EACH GROUP IN SDATA.
C
      NM(1) = NAME(1)
      NM(2) = NAME(2)
      ITEM  = EQSS
      CALL SFETCH (NAME,EQSS,SRD,RC)
      IF (RC .NE. 1) GO TO 6100
      CALL SUREAD (Z(ICORE),LCORE,NWDS,RC)
      IF (RC .NE. 2) GO TO 9008
      K   = ICORE + NWDS
      N   = Z(ICORE+2)
      ISS = 1
      DO 250 I = 1,N
      IF (ISS .GT. ISX) GO TO 240
      IF (Z(ICORE+2*I+2).NE.Z(ISS) .OR. Z(ICORE+2*I+3).NE.Z(ISS+1))
     1    GO TO 240
      Z(ISS+3) = K
  230 IF (K+2 .GT. NCORE) GO TO 9008
      CALL SUREAD (Z(K),3,NWDS,RC)
      K = K + 2
      IF (RC .EQ. 1) GO TO 230
      Z(ISS+4) = (K-Z(ISS+3))/2
      ISS = ISS + 5
      GO TO 250
  240 J = 1
      CALL SJUMP (J)
  250 CONTINUE
C
C     READ SIL NUMBERS INTO OPEN CORE.
C
      KSIL = K - 1
      N = Z(ICORE+3)
      IF (KSIL+N+1 .GT. NCORE) GO TO 9008
      DO 260 I = 1,N
      CALL SUREAD (Z(KSIL+I),2,NWDS,RC)
      IF (RC .NE. 1) GO TO 6106
  260 CONTINUE
      LSIL = Z(KSIL+N)
C
C     READ THE TABLE OF EXTERNAL ID (GP), INTERNAL ID (IP), AND SUB-
C     STRUCTURE NUMBER (SSN) FROM SCR1 ONE ENTRY AT A TIME.  LOCATE
C     THE GP IN THE EQSS DATA INDICATED BY SSN AND LOOK UP THE SIL
C     NUMBER.  WRITE GP AND SIL ON EQEX.  IF GP NOT FOUND, THEN SIL=-1.
C
  270 CALL READ (*9002,*290,SCR1,BUF,3,0,N)
      I  = BUF(3)
      J  = Z(5*I-1)
      I5 = 5*I
      CALL BISLOC (*280,BUF(1),Z(J),2,Z(I5),K)
      I = Z(J+K) + KSIL
      BUF(2) = 10*Z(I) + 1
      CALL WRITE (EQEX,BUF,2,0)
      GO TO 270
  280 BUF(2) = -1
      CALL WRITE (EQEX,BUF,2,0)
      GO TO 270
  290 CALL WRITE (EQEX,0,0,1)
      CALL CLOSE (EQEX,REW)
      CALL CLOSE (SCR1,REW)
      BUF(1) = EQEX
      BUF(2) = NGPTOT
      DO 300 I = 3,7
  300 BUF(I) = 0
      CALL WRTTRL (BUF)
C
C     INTERPRET PLOT SETS AND GENERATE PLTP (PLTPAR)
C
C
C     AT PRESENT, ONLY ONE PLOT SET (DEFINED IN PHASE 1) IS ALLOWED.
C
C     PHASE 2 PLOT SET DEFINITIONS ARE IGNORED.
C
C     COPY PCDB TO PLTP
C
      FILE = PCDB
      CALL OPEN (*9001,PCDB,Z(BUF1),RDREW)
      CALL FWDREC (*9002,PCDB)
      FILE = PLTP
      CALL OPEN  (*9001,PLTP,Z(BUF2),WRTREW)
      CALL FNAME (PLTP,BUF)
      CALL WRITE (PLTP,BUF,2,1)
  310 CALL READ  (*330,*320,PCDB,Z(ICORE),LCORE,1,NWDS)
      GO TO 9008
  320 CALL WRITE (PLTP,Z(ICORE),NWDS,1)
      GO TO 310
  330 CALL CLOSE (PCDB,REW)
      CALL CLOSE (PLTP,REW)
      BUF(1) = PCDB
      CALL RDTRL (BUF)
      BUF(1) = PLTP
      CALL WRTTRL (BUF)
      DO 340 I = 1,NSS
      Z(5*I-1) = 0
      Z(5*I  ) = 1
  340 CONTINUE
      NPSET = 1
C
C     GPSETS
C
C
C     LOCATE THE GPSETS DATA OF THE PLTS ITEM OF EACH BASIC SUBSTRUCTURE
C     AND READ THE NUMBER OF GRID POINTS IN THE ELEMENT SET.  STORE THIS
C     AS THE FOURTH ENTRY IN SDATA
C
      N = 3
      NGPSET = 0
      ITEM   = PLTS
      DO 1010 I = 1,NSS
      NM(1) = Z(5*I-4)
      NM(2) = Z(5*I-3)
      CALL SFETCH (NM,PLTS,SRD,RC)
      CALL SJUMP (N)
      RC = 3
      IF (N .LT. 0) GO TO 6106
      CALL SUREAD (Z(5*I-1),1,NWDS,RC)
      IF (RC .NE. 1) GO TO 6106
      NGPSET = NGPSET + Z(5*I-1)
 1010 CONTINUE
C
C     WRITE RECORDS 0 AND 1 OF GPS AND FIRST WORD OF RECORD 2.
C
      FILE = GPS
      CALL OPEN  (*9001,GPS,Z(BUF1),WRTREW)
      CALL FNAME (GPS,BUF)
      CALL WRITE (GPS,BUF,2,1)
      CALL WRITE (GPS,1,1,1)
      CALL WRITE (GPS,NGPSET,1,0)
C
C     READ GPSETS DATA FROM THE PLTS ITEM OF EACH BASIC SUBSTRUCTURE.
C     INCREMENT THE ABSOLUTE VALUE OF THE POINTERS IN IT BY THE NUMBER
C     OF GRID POINTS IN THE ELEMENT SETS OF THE PRECEDING BASIC
C     SUBSTRUCTURES.  WRITE THE RESULT ON GPS (GPSETS).
C
      N = 3
      NGPSET = 0
      DO 1050 I = 1,NSS
      CALL SFETCH (Z(5*I-4),PLTS,SRD,RC)
      CALL SJUMP (N)
      CALL SUREAD (Z(ICORE),LCORE,NWDS,RC)
      IF (RC .NE. 2) GO TO 9008
      NWDS = NWDS - 1
      DO 1040 J = 1,NWDS
      IF (Z(ICORE+J)) 1020,1040,1030
 1020 Z(ICORE+J) = Z(ICORE+J) - NGPSET
      GO TO 1040
 1030 Z(ICORE+J) = Z(ICORE+J) + NGPSET
 1040 CONTINUE
      CALL WRITE (GPS,Z(ICORE+1),NWDS,0)
      NGPSET = NGPSET + Z(5*I-1)
 1050 CONTINUE
      CALL CLSTAB (GPS,REW)
C
C     ELSETS
C
C
C     READ THE ELSETS DATA FROM THE PLTS ITEM OF EACH BASIC SUBSTRUCTURE
C     INCREMENT ALL NON-ZERO GRID POINT CONNECTION INDICES BY THE NUMBER
C     OF STRUCTURAL GRID POINTS OF THE PRECEDING SUBSTRUCTURES.  WRITE
C     THE RESULT ON ELS (ELSETS).
C
C     NOTE   THE ELEMENT TYPES WILL BE SCRAMBLED.  LIKE ELEMENT TYPES
C            FROM THE CONTRIBUTING BASIC SUBSTRUCTURES WILL NOT BE
C            GROUPED TOGETHER.
C
C     NOTE   THE BAR HAS ADDITIONALLY 6 OFFSET DATA VALUES. QUAD4 AND
C            TRIA3 HAS 1 OFFSET DATA EACH
C
      FILE = ELS
      CALL OPEN  (*9001,ELS,Z(BUF1),WRTREW)
      CALL FNAME (ELS,BUF)
      CALL WRITE (ELS,BUF,2,1)
      NGP = 0
C
C     LOOP OVER BASIC SUBSTRUCTURES
C
      DO 2050 I = 1,NSS
      NM(1) = Z(5*I-4)
      NM(2) = Z(5*I-3)
      CALL SFETCH (NM,PLTS,SRD,RC)
      N  = 4
      CALL SJUMP (N)
      RC = 3
      IF (N .LT. 0) GO TO 6106
C
C     LOOP OVER ELEMENT TYPES
C
 2010 CALL SUREAD (BUF,2,N,RC)
      IF (RC .EQ. 2) GO TO 2040
      IF (RC .NE. 1) GO TO 6106
      CALL WRITE (ELS,BUF,2,0)
      NGPEL  = BUF(2)
      OFFSET = 0
      IF (BUF(1) .EQ. BAR) OFFSET = 6
      IF (BUF(1).EQ.QUAD4 .OR. BUF(1).EQ.TRIA3) OFFSET = 1
C
C     LOOP OVER ELEMENTS
C
 2020 CALL SUREAD (ELID,1,N,RC)
      IF (RC .NE. 1) GO TO 6106
      CALL WRITE (ELS,ELID,1,0)
      IF (ELID .LE. 0) GO TO 2010
      CALL SUREAD (INDX,1,N,RC)
      CALL WRITE (ELS,INDX,1,0)
      CALL SUREAD (Z(ICORE),NGPEL+OFFSET,N,RC)
      IF (RC .NE. 1) GO TO 6106
C
C     LOOP OVER CONNECTIONS
C
      K = ICORE
      DO 2030 J = 1,NGPEL
      IF (Z(K) .NE. 0) Z(K) = Z(K) + NGP
 2030 K = K + 1
      CALL WRITE (ELS,Z(ICORE),NGPEL+OFFSET,0)
      GO TO 2020
 2040 NGP = NGP + Z(5*I-2)
 2050 CONTINUE
C
      CALL WRITE  (ELS,0,0,1)
      CALL CLSTAB (ELS,REW)
C
C     NORMAL MODULE COMPLETION
C
      CALL SOFCLS
      RETURN
C
C     ABNORMAL MODULE COMPLETION
C
 6100 IF (RC .EQ. 2) RC = 3
      CALL SMSG (RC-2,ITEM,NM)
      GO TO 9200
 6106 CALL SMSG (RC+4,ITEM,NM)
      GO TO 9200
 9001 N = 1
      GO TO 9100
 9002 N = 2
      GO TO 9100
 9003 N = 3
      GO TO 9100
 9008 N = 8
 9100 CALL MESAGE (N,FILE,SUBR)
      CALL CLOSE  (FILE,REW)
 9200 CALL SOFCLS
      NPSET = -1
      RETURN
      END


text:
The Effulgence of Biorhythmic Iceburgs in Lake Spafford is a project inspired by Users/KaiTing Kai. Recalling the numerous occasions when Lake Spafford got cold enough to float icebergs, we begin our wait for that to occur again.

Iceberg lettuce floating in Lake Spafford does not count as an iceberg. And obviously, any proper iceberg comes with penguins. While ducks appear very similar to penguins to all but the most distinguished biologists, the consensus is that they are different species.

 Day 1  April 13th 2007

The wait begins.

Research will have to be conducted to determine when the last time Lake Spafford froze. Was it 1986? We will have to be ready to calculate Kais biorhythms so that the iceberg can be shaped appropriately. Three layers of ice with the proper curve frozen together and refloated as an iceberg should do. The last time the ice was almost 3/4 of an inch thick, which should work. Early morning light should be best for the photograph.

 Day 2680  August 18th 2014

Still no sightings of icebergs.

The best freeze I remember was 90/91, but I never saw Spafford then.  86 was flooding. Users/EdHenn

Image(iceberg.jpg, thumbnail, 200, Iceberg with lone penguin.)Artist rendition of what we should be looking for... Users/MattJurach

20070704 15:02:42 nbsp I will ask my parents if they can recall something of this nature Users/StevenDaubert

20080816 15:46:05 nbsp Perhaps we should look for large, sinking, unsinkable ships.  Icebergs are attracted to them. Users/IDoNotExist


! DART software - Copyright UCAR. This open source software is provided
! by UCAR, "as is", without charge, subject to all terms of use at
! http://www.image.ucar.edu/DAReS/DART/DART_download

module arestart_pnetcdf_mod

use pnetcdf_utilities_mod, only : pnet_check
use types_mod,        only : r8
use time_manager_mod, only : time_type, set_time, get_time
use mpi_utilities_mod,     only : task_count, my_task_id, datasize

use pnetcdf
use mpi

implicit none
private

public :: aread_state_restart_parallel, &
          aread_state_restart_giant, &
          awrite_state_restart_parallel, &
          awrite_state_restart_giant

contains

!----------------------------------------------------------------------
!> reads a netcdf restart file in parallel. No complete state.
subroutine aread_state_restart_parallel(stateId, timeId, nblocks, model_time, model_state, funit, target_time)

implicit none

integer,         intent(in)               :: nblocks !! number of blocks - my_num_vars
type(time_type), intent(out)              :: model_time
real(r8),        intent(out)              :: model_state(:) !! now distributed
integer,         intent(in)               :: funit !! pnetcdf file identifier
type(time_type), optional, intent(out)    :: target_time

character(len = 16) :: open_format
integer :: ios, int1, int2

! Parallel netcdf variables
integer(KIND=MPI_OFFSET_KIND) :: start(1) !! state is one dimensional
integer(KIND=MPI_OFFSET_KIND) :: count(1)
integer(KIND=MPI_OFFSET_KIND) :: stride(1)
integer(KIND=MPI_OFFSET_KIND) :: bufcount !! my num vars
integer                       :: stateId !! Id of state variable
integer                       :: timeId !! Id of time variable
integer                       :: ret !! return code
integer                       :: time(2) !! for reading from netcdf file

ios = 0

!! Figure out whether the file is opened FORMATTED or UNFORMATTED
!inquire(funit, FORM=open_format) !HK the file is open already? Yes

start(1) = my_task_id() + 1
count(1) = nblocks
stride(1) = task_count()
bufcount = nblocks

! Strided read of the state the values from the netCDF variable

if ( datasize == MPI_REAL4 ) then ! trying to catch single precision

   ret = nfmpi_get_vars_all(funit, stateId, start, count, stride, model_state, bufcount, MPI_REAL4)
   call pnet_check(ret, 'aread_state_restart', 'reading state')

else ! double precision

   ret = nfmpi_get_vars_all(funit, stateId, start, count, stride, model_state, bufcount, MPI_REAL8)
   call pnet_check(ret, 'aread_state_restart', 'reading state')

endif

start(1) = 1
count(1) = 2
stride(1) = 1

! Read time from the netCDF variable

!>@todo does this need to be a collective call?
ret = nfmpi_get_vars_int_all(funit, timeId, start, count, stride, time)

call pnet_check(ret, 'aread_state_restart', 'reading time')
model_time = set_time(time(1), time(2)) ! seconds, days

end subroutine aread_state_restart_parallel

!----------------------------------------------------------------------
!> giant restart files
subroutine aread_state_restart_giant(state_length, stateId, timeId, nblocksVars, nblocksCopies, model_time, model_state, transpose, funit, target_time)

use mpi
use pnetcdf

integer(KIND=MPI_OFFSET_KIND),  intent(in) :: state_length !! just to make the overloading work?
integer,                        intent(in) :: stateId !! Id for state_vector
integer,                        intent(in) :: timeId !! Id for time
integer(KIND=MPI_OFFSET_KIND),  intent(in) :: nblocksVars, nblocksCopies !! num vars
type(time_type),             intent(inout) :: model_time(:)
real(r8),                    intent(inout) :: model_state(:, :) !! see inout in ensemble manager call
logical,                        intent(in) :: transpose
integer,                        intent(in) :: funit !! restart file
type(time_type), optional,      intent(in) :: target_time

integer :: time(2), seconds, days

! pnetcdf variables
integer                       :: ret !! return code for pnetcdf calls
integer(KIND=MPI_OFFSET_KIND) :: start(1) !! time is one dimensional
integer(KIND=MPI_OFFSET_KIND) :: count(1)
integer(KIND=MPI_OFFSET_KIND) :: stride(1)
integer(KIND=MPI_OFFSET_KIND) :: state_start(2) !! state is two dimensional
integer(KIND=MPI_OFFSET_KIND) :: state_count(2)
integer(KIND=MPI_OFFSET_KIND) :: state_stride(2)
integer :: time_length

time_length = 2

! read the state vector
! the transpose depends on whether your giant restart file is (copies, vars) or (vars, copies)

if (transpose) then

   state_start = (/ my_task_id() + 1, 1 /)
   state_count = (/ nblocksVars,  nblocksCopies  /)
   state_stride = (/ task_count(), 1 /)

else

   state_start = (/ 1, my_task_id() + 1 /)
   state_count = (/ nblocksCopies, nblocksVars /)
   state_stride = (/ 1, task_count() /)

endif

if ( datasize == MPI_REAL4 ) then ! single precision

   ret = nfmpi_get_vars_all(funit, stateId, state_start, state_count, state_stride, model_state, nblocksCopies*nblocksVars, MPI_REAL4)
   call pnet_check(ret, 'aread_state_restart', 'reading state')

else ! double precision

   ret = nfmpi_get_vars_all(funit, stateId, state_start, state_count, state_stride, model_state, nblocksCopies*nblocksVars, MPI_REAL8)
   call pnet_check(ret, 'aread_state_restart', 'reading state')

endif

! time - does this need to be a collective call? Are the times ever different
start(1) = 1
count(1) = 2
stride(1) = 1

ret = nfmpi_get_vars_int_all(funit, timeId, start, count, stride, time)
call pnet_check(ret, 'aread_state_restart', 'reading time')
model_time(1:nblocksCopies) = set_time(time(1), time(2)) ! seconds, days - one time?

end subroutine aread_state_restart_giant

!----------------------------------------------------------------------
!> parallel write of restarts using pnetcdf
subroutine awrite_state_restart_parallel(timeId, stateId, nblocks, model_time, model_state, state_length, funit, target_time)
!----------------------------------------------------------------------
!
!HK what does this comment mean?
! Write a restart file given a model extended state and a unit number
! opened to the restart file. (Need to reconsider what is passed to
! identify file or if file can even be opened within this routine).

use mpi_utilities_mod,     only : task_count, my_task_id, datasize
use pnetcdf_utilities_mod, only :pnet_check
use mpi
use pnetcdf

integer,                        intent(in) :: stateId !! Id for state_vector
integer,                        intent(in) :: timeId !! Id for time
integer(KIND=MPI_OFFSET_KIND),  intent(in) :: nblocks !! num vars
type(time_type),                intent(in) :: model_time
real(r8),                    intent(inout) :: model_state(:) !! see inout in ensemble manager call
integer(KIND=MPI_OFFSET_KIND),  intent(in) :: state_length !! num vars
integer,                        intent(in) :: funit !! restart file
type(time_type), optional,      intent(in) :: target_time

integer :: i, io, rc
character(len = 16) :: open_format
character(len=128) :: filename
logical :: is_named

integer :: time(2), seconds, days

! pnetcdf variables
integer                       :: ret !! return code for pnetcdf calls
integer(KIND=MPI_OFFSET_KIND) :: start(1) !! state and time are one dimensional
integer(KIND=MPI_OFFSET_KIND) :: count(1)
integer(KIND=MPI_OFFSET_KIND) :: stride(1)
integer :: time_length

time_length = 2

! Write the state vector

! state
start(1) = my_task_id() + 1
count(1) = nblocks ! my_num_vars
stride(1) = task_count()

if ( datasize == MPI_REAL4 ) then ! trying to catch single precision

   ret = nfmpi_put_vars_all(funit, stateId, start, count, stride, model_state, nblocks, MPI_REAL4)
   call pnet_check(ret, 'awrite_state_restart', 'writing state')

else ! double precision

   ret = nfmpi_put_vars_all(funit, stateId, start, count, stride, model_state, nblocks, MPI_REAL8)
   call pnet_check(ret, 'awrite_state_restart', 'writing state')

endif

! time - does this need to be a collective call? Are the times ever different
start(1) = 1
count(1) = 2
stride(1) = 1

call get_time(model_time, seconds, days)
time = (/seconds, days/)
ret = nfmpi_put_vars_int_all(funit, timeId, start, count, stride, time)
call pnet_check(ret, 'awrite_state_restart', 'writing time')

end subroutine awrite_state_restart_parallel

!----------------------------------------------------------------------
!> for giant restart file
subroutine awrite_state_restart_giant(timeId, stateId, nblocksVars, nblocksCopies, model_time, model_state, transpose, funit, target_time)
!----------------------------------------------------------------------
!
!HK what does this comment mean?
! Write a restart file given a model extended state and a unit number
! opened to the restart file. (Need to reconsider what is passed to
! identify file or if file can even be opened within this routine).

integer,                        intent(in) :: stateId !! Id for state_vector
integer,                        intent(in) :: timeId !! Id for time
integer(KIND=MPI_OFFSET_KIND),  intent(in) :: nblocksVars, nblocksCopies !! num vars
type(time_type),                intent(in) :: model_time !! one time?
real(r8),                    intent(inout) :: model_state(:, :) !! see inout in ensemble manager call
logical,                        intent(in) :: transpose !! pnetcdf stride and count depends on (copies, vars), (vars, copies)
integer,                        intent(in) :: funit !! restart file
type(time_type), optional,      intent(in) :: target_time

integer :: i, io, rc
character(len = 16) :: open_format
character(len=128) :: filename
logical :: is_named

integer :: time(2), seconds, days

! pnetcdf variables
integer                       :: ret !! return code for pnetcdf calls
integer(KIND=MPI_OFFSET_KIND) :: start(1) ! state and time are one dimensional
integer(KIND=MPI_OFFSET_KIND) :: count(1)
integer(KIND=MPI_OFFSET_KIND) :: stride(1)
integer(KIND=MPI_OFFSET_KIND) :: state_start(2) ! state and time are one dimensional
integer(KIND=MPI_OFFSET_KIND) :: state_count(2)
integer(KIND=MPI_OFFSET_KIND) :: state_stride(2)

! time - does this need to be a collective call? Are the times ever different
start(1) = 1
count(1) = 2
stride(1) = 1

call get_time(model_time, seconds, days)
time = (/seconds, days/)
ret = nfmpi_put_vars_int_all(funit, timeId, start, count, stride, time)
call pnet_check(ret, 'awrite_state_restart', 'writing time')

! Write the state vector
! the transpose depends on whether your giant restart file is (copies, vars) or (vars, copies)

if (transpose) then

   state_start = (/ my_task_id() + 1, 1 /)
   state_count = (/ nblocksVars,  nblocksCopies  /)
   state_stride = (/ task_count(), 1 /)

else

   state_start = (/ 1, my_task_id() + 1 /)
   state_count = (/ nblocksCopies, nblocksVars /) ! my_num_vars
   state_stride = (/ 1, task_count() /)

endif

if ( datasize == MPI_REAL4 ) then ! trying to catch single precision

   ret = nfmpi_put_vars_all(funit, stateId, state_start, state_count, state_stride, model_state, nblocksCopies*nblocksVars, MPI_REAL4)
   call pnet_check(ret, 'awrite_state_restart', 'writing state')

else ! double precision

   ret = nfmpi_put_vars_all(funit, stateId, state_start, state_count, state_stride, model_state, nblocksCopies*nblocksVars, MPI_REAL8)
   call pnet_check(ret, 'awrite_state_restart', 'writing state')

endif

end subroutine awrite_state_restart_giant

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

end module arestart_pnetcdf_mod


text:
C Copyright(C) 1999-2020 National Technology & Engineering Solutions
C of Sandia, LLC (NTESS).  Under the terms of Contract DE-NA0003525 with
C NTESS, the U.S. Government retains certain rights in this software.
C
C See packages/seacas/LICENSE for details
      subroutine putss(ndbout, numess, idess, neess, ndess, ixeess,
     *  ixdess, lteess, ltsess, facess, *)

      integer idess(*), neess(*), ndess(*)
      integer ixeess(*), ixdess(*)
      integer lteess(*), ltsess(*)
      real facess(*)

      if (numess .gt. 0) then

        call expcss(ndbout, idess, neess, ndess, ixeess, ixdess,
     &    lteess, ltsess, facess, ierr)
        if (ierr .gt. 0) return 1
      end if
      return
      end

max_stars_repo_name: jschueller/seacas

max_issues_repo_name: jschueller/seacas

max_forks_repo_name: jschueller/seacas


text:
!!  Copyright (C)  Stichting Deltares, 2012-2016.
!!
!!  This program is free software: you can redistribute it and/or modify
!!  it under the terms of the GNU General Public License version 3,
!!  as published by the Free Software Foundation.
!!
!!  This program is distributed in the hope that it will be useful,
!!  but WITHOUT ANY WARRANTY; without even the implied warranty of
!!  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
!!  GNU General Public License for more details.
!!
!!  You should have received a copy of the GNU General Public License
!!  along with this program. If not, see <http://www.gnu.org/licenses/>.
!!
!!  contact: delft3d.support@deltares.nl
!!  Stichting Deltares
!!  P.O. Box 177
!!  2600 MH Delft, The Netherlands
!!
!!  All indications and logos of, and references to registered trademarks
!!  of Stichting Deltares remain the property of Stichting Deltares. All
!!  rights reserved.

      SUBROUTINE DLWQO2 ( NOTOT , NOSEG , NOPA  , NOSFUN, ITIME ,
     +                    MONAME, SYNAME, DUNAME, IDUMP , NODUMP,
     +                    CONC  , CONS  , PARAM , FUNC  , SEGFUN,
     +                    VOLUME, NOCONS, NOFUN , IDT   , NOUTP ,
     +                    LCHAR , LUN   , IOUTPS, IOPOIN, RIOBUF,
     +                    OUSNM , OUUNI , OUDSC , SYSNM , SYUNI , SYDSC ,
     +                    OUNAM , NX    , NY    , LGRID , CGRID ,
     +                    NOSYS , BOUND , IP    , AMASS , AMASS2,
     +                    ASMASS, NOFLUX, FLXINT, ISFLAG, IAFLAG,
     +                    IBFLAG, IMSTRT, IMSTOP, IMSTEP, IDSTRT,
     +                    IDSTOP, IDSTEP, IHSTRT, IHSTOP, IHSTEP,
     +                    IMFLAG, IDFLAG, IHFLAG, NOLOC , PROLOC,
     +                    NODEF , DEFAUL, ITSTRT, ITSTOP, NDMPAR,
     +                    DANAM , NDMPQ , NDMPS , IQDMP , ISDMP ,
     +                    IPDMP , DMPQ  , DMPS  , FLXDMP, NTDMPQ,
     +                    NAMBUF, NORAAI, NTRAAQ, IORAAI, NQRAAI,
     +                    IQRAAI, TRRAAI, RANAM , STOCHI, NOGRID,
     +                    NOVAR , VARARR, VARIDX, VARTDA, VARDAG,
     +                    ARRKND, ARRPOI, ARRDM1, ARRDM2, VGRSET,
     +                    GRDNOS, GRDSEG, A     , NOBND , NOBTYP,
     +                    BNDTYP, INWTYP, CONAME, NOQ   , IPOINT,
     +                    INTOPT, PANAME, FUNAME, SFNAME, DMPBAL,
     +                    NOWST , NOWTYP, WSTTYP, IWASTE, INXTYP,
     +                    WSTDMP, iknmrk, OWNERS, MYPART, ISEGCOL)
!
!
!     Deltares      SECTOR WATERRESOURCES AND ENVIRONMENT
!
!     CREATED             : january 1993 Jan van Beek
!
!
!     FUNCTION            : Driver output system
!
!     LOGICAL UNITS       : -
!
!     SUBROUTINES CALLED  : BALDMP, fills balance for dump area's
!                           FIOUTV, fills output buffer, single cel grids
!                           FIOSUB, fills output buffer, sub-grids
!                           OUTMON, performs a monitor output step
!                           OUTDMP, performs a grid dump output step
!                           OUTHIS, performs a history output step
!                           OUTHNF, performs a history NEFIS step
!                           OUTMAP, performs a map output step
!                           OUTMNF, performs a map NEFIS step
!                           OUTBAL, performs a balance output step
!                           RAATRA, fills transport for raaien
!                           STEPYN, evaluates timers
!
!     PARAMETERS          :
!
!     NAME    KIND     LENGTH     FUNCT.  DESCRIPTION
!     ----    -----    ------     ------- -----------
!     NOTOT   INTEGER       1     INPUT   Total number of substances
!     NOSEG   INTEGER       1     INPUT   Nr. of computational elements
!     NOPA    INTEGER       1     INPUT   Number of parameters
!     NOSFUN  INTEGER       1     INPUT   Number of segment functions
!     ITIME   INTEGER       1     INPUT   Time in system clock units
!     MONAME  CHAR*40       4     INPUT   Model and run names
!     SYNAME  CHAR*20    NOTOT    INPUT   names of substances
!     DUNAME  CHAR*20    NODUMP   INPUT   names of dump locations
!     IDUMP   INTEGER    NODUMP   INPUT   dump segment numbers
!     NODUMP  INTEGER       1     INPUT   number of dump locations
!     CONC    REAL   NOTOT,NOSEG  INPUT   Model concentrations
!     CONS    REAL          *     IN/OUT  Model constants
!     PARAM   REAL    NOPA,NOSEG  IN/OUT  Model parameters
!     FUNC    REAL          *     IN/OUT  Model functions at ITIME
!     SEGFUN  REAL   NOSEG,NOSFUN IN/OUT  Segment functions at ITIME
!     VOLUME  REAL      NOSEG     INPUT   Segment volumes
!     NOCONS  INTEGER       1     INPUT   Number of constants used
!     NOFUN   INTEGER       1     INPUT   Number of functions ( user )
!     IDT     INTEGER       1     INPUT   Simulation timestep
!     NOUTP   INTEGER       1     INPUT   Number of output files
!     LCHAR   CHAR*(*)      *     INPUT   File names
!     LUN     INTEGER       *     INPUT   Uint numbers
!     IOUTPS  INTEGER 7*NOUTP    IN/OUT   Output structure
!                                            index 1 = start time
!                                            index 2 = stop time
!                                            index 3 = time step
!                                            index 4 = number of vars
!                                            index 5 = kind of output
!                                            index 6 = grid of output
!                                            index 7 = initialize flag
!     IOPOIN  INTEGER       *     INPUT   Pointer to DELWAQ array's
!     RIOBUF  REAL          *     LOCAL   Output buffer
!     OUNAM   CHAR*20       *     INPUT   name of output variable
!     NX      INTEGER       1     INPUT   Width of output grid
!     NY      INTEGER       1     INPUT   Depth of output grid
!     LGRID   INTEGER     NX*NY   INPUT   grid-layout
!     CGRID   CHAR*20       *     LOCAL   Char buffer for dmp output
!     NOSYS   INTEGER       1     INPUT   Number of active substances
!     BOUND   REAL          *     INPUT   Bounary conditions
!     IP      INTEGER       *     IN/OUT  Paging structure
!     AMASS   REAL       NOTOT,*  INPUT   Mass array
!     AMASS2  REAL       NOTOT,*  IN/OUT  Cummulative balance on whole
!     ASMASS  REAL       NOTOT,*  IN/OUT  Cummulative balance per segment
!     NOFLUX  INTEGER       1     INPUT   Number of fluxes
!     FLXINT  REAL  NOFLUX*NDMPAR IN/OUT  Integrated fluxes at dump segments
!     ISFLAG  INTEGER       1     INPUT   if 1 then dd-hh:mm'ss"
!     IAFLAG  INTEGER       1     OUTPUT  if 1 then accumulate mass bal
!     IBFLAG  INTEGER       1     INPUT   Flag = 1 then balances
!     IMSTRT  INTEGER       1     INPUT   Monitoring start time ( scu )
!     IMSTOP  INTEGER       1     INPUT   Monitoring stop time ( scu )
!     IMSTEP  INTEGER       1     INPUT   Monitoring time step ( scu )
!     IDSTRT  INTEGER       1     INPUT   Dump start time ( scu )
!     IDSTOP  INTEGER       1     INPUT   Dump stop time ( scu )
!     IDSTEP  INTEGER       1     INPUT   Dump time step ( scu )
!     IHSTRT  INTEGER       1     INPUT   History start time ( scu )
!     IHSTOP  INTEGER       1     INPUT   History stop time ( scu )
!     IHSTEP  INTEGER       1     INPUT   History time step ( scu )
!     IMFLAG  LOGICAL       1     OUTPUT  If .T. then monitor step
!     IDFLAG  LOGICAL       1     OUTPUT  If .T. then dump step
!     IHFLAG  LOGICAL       1     OUTPUT  If .T. then history step
!     NOLOC   INTEGER       1     INPUT   Number of variables in PROLOC
!     PARAM   REAL   NOLOC,NOSEG  INPUT   Parameters local in PROCES system
!     NODEF   INTEGER       1     INPUT   Number of used defaults
!     DEFAUL  REAL          *     INPUT   Default proces parameters
!     ITSTRT  INTEGER     1       INPUT   start time
!     ITSTOP  INTEGER     1       INPUT   stop time
!     NDMPAR  INTEGER     1       INPUT   Number of dump areas
!     DANAM   CHAR*20  NDMPAR     INPUT   Dump area names
!     NDMPQ   INTEGER     1       INPUT   Number of dumped exchanges
!     NDMPS   INTEGER     1       INPUT   Number of dumped segments
!     IQDMP   INTEGER       *     INPUT   Exchange to dumped exchange pointer
!     ISDMP   INTEGER       *     INPUT   Segment to dumped segment pointer
!     IPDMP   INTEGER       *     INPUT   pointer structure dump area's
!     DMPQ    REAL  NOTOT*NDMPS*? INPUT   mass balance dumped segments
!     DMPS    REAL  NOSYS*NDMPQ*? INPUT   mass balance dumped exchange
!     FLXDMP  REAL  NOFLUX*NDMPS  INPUT   Integrated fluxes
!     NAMBUF  CHAR*20       *     INPUT   Buffer for names
!     NORAAI  INTEGER       1     INPUT   Number of raaien
!     NTRAAQ  INTEGER       1     INPUT   Total number of exch. in raaien
!     IORAAI  INTEGER       *     INPUT   Output option for raai
!     NQRAAI  INTEGER       *     INPUT   Number of exchanges in raai
!     IQRAAI  INTEGER       *     INPUT   Exchanges in raai
!     TRRAAI  REAL NOTOT*NDMPAR*6 IN/OUT  Cummulative transport over raai
!     RANAM   CHAR*20       *     INPUT   Raaien names
!     STOCHI  REAL   NOTOT*NOFLUX INPUT   Proces stochiometry
!     INTOPT  INTEGER     1       INPUT   Integration and balance suboptions
!     OWNERS  INTEGER   NOSEG     INPUT   ownership of segments
!     MYPART  INTEGER     1       INPUT   number of current part/subdomain
!     ==================================================================
!
      use timers
      use m_couplib
      use output
!
      INTEGER       NOTOT , NOSEG , NOPA  , NOSFUN, ITIME ,
     +              NODUMP, NOCONS, NOFUN , IDT   , NOUTP ,
     +              NX    , NY    , NOSYS , NOFLUX, ISFLAG,
     +              IAFLAG, IBFLAG, IMSTRT, IMSTOP, IMSTEP,
     +              IDSTRT, IDSTOP, IDSTEP, IHSTRT, IHSTOP,
     +              IHSTEP, NOLOC , NODEF , ITSTRT, ITSTOP,
     +              NDMPAR, NDMPQ , NDMPS , NTDMPQ, NORAAI,
     +              NTRAAQ, NOGRID, NOVAR , NOBND , NOBTYP,
     +              NOQ   , MYPART
      INTEGER       IDUMP(*)      , LUN(*)        ,
     +              IOUTPS(7,*)   , IOPOIN(*)     ,
     +              LGRID(*)      , IP(*)         ,
     +              IQDMP(*)      , ISDMP(*)      ,
     +              IPDMP(*)      , IORAAI(*)     ,
     +              NQRAAI(*)     , IQRAAI(*)     ,
     +              VARARR(NOVAR) , VARIDX(NOVAR) ,
     +              VARTDA(NOVAR) , VARDAG(NOVAR) ,
     +              ARRKND(*)     , ARRPOI(*)     ,
     +              ARRDM1(*)     , ARRDM2(*)     ,
     +              VGRSET(NOVAR,*),GRDNOS(NOGRID),
     +              GRDSEG(NOSEG,NOGRID)          ,
     +              INWTYP(*)     , IPOINT( 4,NOQ),
     +              OWNERS(NOSEG)
      integer(4), intent(in   ) :: iknmrk(noseg)      ! Feature array. Bit zero set means active.
      REAL          conc ( notot, noseg ),
     &                              CONS(*)       ,
     &              param( nopa , noseg ),
     &                              FUNC(*)       ,
     &              segfun(noseg, nosfun),
     &                              VOLUME(*)     ,
     +              RIOBUF(*)     , BOUND(*)      ,
     +              amass( notot, noseg ),
     &                              AMASS2(NOTOT,5),
     +              ASMASS(*)     , FLXINT(*)     ,
     +              PROLOC(*)     , DEFAUL(*)     ,
     +              DMPQ(*)       , DMPS(*)       ,
     +              FLXDMP(*)     , TRRAAI(NOSYS,*),
     +              STOCHI(NOTOT,NOFLUX), A(*)
      CHARACTER*20  SYNAME(*)     , DUNAME(*)     ,
     +              OUNAM(*)      , CGRID(*)      ,
     +              DANAM(*)      , NAMBUF(*)     ,
     +              RANAM(*)      , BNDTYP(*)     ,
     +              CONAME(*)     , PANAME(*)     ,
     +              FUNAME(*)     , SFNAME(*)
      CHARACTER*100 OUSNM(*)      , SYSNM(*)
      CHARACTER*40  OUUNI(*)      , SYUNI(*)
      CHARACTER*60  OUDSC(*)      , SYDSC(*)

      CHARACTER*40  MONAME(4)
      CHARACTER*(*) LCHAR (*)
      LOGICAL       IMFLAG, IDFLAG, IHFLAG
      integer                    :: dmpbal(ndmpar)        ! indicates if dump area is included in the balance
      integer                    :: nowst                 ! number of wasteloads
      integer                    :: nowtyp                ! number of wasteload types
      character(len=20)          :: wsttyp(nowtyp)        ! wasteload types names
      integer                    :: iwaste(nowst)         ! segment numbers of the wasteloads
      integer                    :: inxtyp(nowst)         ! wasteload type number (index in wsttyp)
      real                       :: wstdmp(notot,nowst,2) ! accumulated wasteloads 1/2 in and out
      integer, intent(in   )     :: isegcol(*)            ! pointer from segment to top of column
!
!     Local declarations
!
      PARAMETER   ( IGSEG = 1, IGMON = 2, IGGRD = 3, IGSUB= 4 )
      PARAMETER   ( LUOFF = 18 )
      PARAMETER   ( LUOFF2= 36 )
      INTEGER       K1    , IOSTRT, IOSTOP, IOSTEP, NRVAR ,
     +              ISRTOU, IGRDOU, INIOUT, LUNOUT, IOUT
      CHARACTER*255 LCHOUT
      CHARACTER*20  NAME
      LOGICAL       LOFLAG, LMFIRS, LDFIRS, LHFIRS, LDUMMY
      LOGICAL       LGET  , LREAD
      REAL, ALLOCATABLE :: SURF(:)

      INTEGER, SAVE ::       MNCREC = 0
      INTEGER, SAVE ::       timeid, bndtimeid
!      INTEGER, SAVE ::       idepth
      INTEGER, ALLOCATABLE, SAVE ::  MNCWQID1(:,:), MNCWQID2(:,:)
      LOGICAL       FIRST  /.TRUE./

      integer(4) ithandl /0/
      if ( timon ) call timstrt ( "dlwqo2", ithandl )

      IF (FIRST) THEN
         ALLOCATE(MNCWQID1(NOTOT,2) , MNCWQID2(NOVAR,2))
         FIRST = .FALSE.

         CALL ZOEKNS( 'LocalDepth', NOVAR, OUNAM, l0, IDEPTH )
      ENDIF
!
!     Evaluate standard DELWAQ output timers
!
      CALL STEPYN (ITIME , IDT   , IMSTRT, IMSTOP, IMSTEP,
     +             IMFLAG, LMFIRS)
      CALL STEPYN (ITIME , IDT   , IDSTRT, IDSTOP, IDSTEP,
     +             IDFLAG, LDFIRS)
      CALL STEPYN (ITIME , IDT   , IHSTRT, IHSTOP, IHSTEP,
     +             IHFLAG, LHFIRS)
!
!     Fill mass in AMASS2 array by summing AMASS over all segments
!
      IF ( IMFLAG ) THEN
         call collect_data(mypart, amass , notot,'noseg',1,ierr)
         call combine_1d_rdata(amass2, notot*5, CP_SUM, ierr)
         IAFLAG = 1
         if (mypart.eq.1) then
            DO 20 I2 = 1,NOTOT
               AMASS2(I2,1) = 0.0
               DO 10 I1 = 1,NOSEG
                  AMASS2(I2,1) = AMASS2(I2,1) + AMASS(I2,I1)
   10          CONTINUE
   20       CONTINUE
         endif
      ENDIF
!
!     Fill mass in ASMASS array using DMPQ and DMPS
!
      IF ( IMFLAG .OR. ( IHFLAG .AND. NORAAI .GT. 0) ) THEN
         IF ( IBFLAG .EQ. 1 ) THEN
            call collect_data(mypart, flxdmp, noflux,'ndmps',1, ierr)
            call collect_data(mypart, dmps  , notot ,'ndmps',3, ierr)
            call collect_data(mypart, dmpq  , nosys ,'ndmpq',2, ierr)
            if (mypart.eq.1) then
               CALL BALDMP (NOTOT , NOSYS , NOFLUX, NDMPAR, NDMPQ ,
     +                      NDMPS , NTDMPQ, IQDMP , ISDMP , IPDMP ,
     +                      DMPQ  , AMASS , DMPS  , FLXDMP, ASMASS,
     +                      FLXINT)
            endif
         ENDIF

         IF ( NORAAI .GT. 0 ) THEN
            IF ( LHFIRS ) THEN
               CALL ZERO   (TRRAAI, NORAAI*NOSYS  )
            ELSE
               call collect_data(mypart, dmpq  , nosys , 'ndmps',2,ierr)
               if (mypart.eq.1) then
                  CALL RAATRA (NOSYS , NDMPQ , NORAAI, NTRAAQ, IORAAI,
     +                         NQRAAI, IQRAAI, IQDMP , DMPQ  , TRRAAI)
               endif
            ENDIF
         ENDIF
!
      ENDIF
!
!     Initialize K1, pointer in IOPOIN and OUNAM
!
      lread = .true.
      K1 = 1
!
!     Loop over the output files
!
      DO 200 IOUT = 1 , NOUTP
!
!        Map output structure to single variables part 1
!
         IOSTRT = IOUTPS(1,IOUT)
         IOSTOP = IOUTPS(2,IOUT)
         IOSTEP = IOUTPS(3,IOUT)
         NRVAR  = IOUTPS(4,IOUT)
!
!        Output required ?
!
         CALL STEPYN (ITIME , IDT   , IOSTRT, IOSTOP, IOSTEP,
     +                LOFLAG, LDUMMY)
!
         IF ( .NOT. LOFLAG ) GOTO 100
!
!        Collect data on master-process
!
         if (lread) then
            call collect_data(mypart, conc  , notot ,'noseg',1, ierr)
            call collect_data(mypart, volume, 1     ,'noseg',1, ierr)
            call collect_data(mypart, proloc, noloc ,'noseg',1, ierr)
            if (ibflag.gt.0)
     +         call accumulate_data(flxint, noflux,'ndmpar',1, 'my_dmpar', ierr)
            lread = .false.
         endif

         if (mypart.eq.1) then
!
!        Map output structure to single variables part 2
!
            ISRTOU = IOUTPS(5,IOUT)
            IGRDOU = IOUTPS(6,IOUT)
            INIOUT = IOUTPS(7,IOUT)
            IF ( IOUT .LE. 4 ) THEN
               IFI = IOUT + LUOFF
            ELSEIF ( IOUT .LE. 7 ) THEN
               IFI = IOUT + LUOFF2 - 4
            ELSE
               IFI = IOUT + LUOFF2 - 2
            ENDIF
            LUNOUT = LUN(IFI)
            LCHOUT = LCHAR(IFI)
!
!        No balance output if they are not active
!
            IF ( ( ISRTOU .EQ. IBAL .OR. ISRTOU .EQ. IBA2 .OR.
     +             ISRTOU .EQ. IBA2) .AND. IBFLAG .NE. 1 ) GOTO 100
!
!        Set all local variables used active on base grid
!
            CALL ACTLOC (IOPOIN, NRVAR , NOCONS, NOPA  , NOFUN ,
     +                   NOSFUN, NOTOT , NOSEG , NOLOC , NOGRID,
     +                   NOVAR , VARARR, VARIDX, VARTDA, VARDAG,
     +                   ARRKND, ARRPOI, ARRDM1, ARRDM2, VGRSET,
     +                   GRDNOS, GRDSEG, A     )
!
!        Fill output buffer
!
            IF ( ISRTOU .EQ. IBA2 ) THEN
!
               CALL FLXBAL (NOTOT , NOFLUX, NDMPAR, NRVAR , STOCHI,
     +                      FLXINT, ASMASS, RIOBUF)
!
            ELSEIF ( ISRTOU .EQ. IBA3 ) THEN
!     jos doet het zelf
            ELSEIF ( IGRDOU .EQ. IGSUB ) THEN
               IF (ISRTOU .EQ. IMO3 .OR.
     +             ISRTOU .EQ. IHI3 .OR.
     +             ISRTOU .EQ. IHN3     ) THEN
                  NCOUT = NOTOT
               ELSE
                  NCOUT = 0
               ENDIF
               NRVAR2 = NRVAR/2
!
!           For the dump area's
!
               CALL FIOSUB (RIOBUF, IOPOIN(K1), NRVAR2, NOCONS, NOPA  ,
     +                      NOFUN , NOSFUN    , NOTOT , CONC  , SEGFUN,
     +                      FUNC  , PARAM     , CONS  , IDT   , ITIME ,
     +                      VOLUME, NOSEG     , NOSYS , NDMPAR, IPDMP ,
     +                      BOUND , NOLOC     , PROLOC, NODEF , DEFAUL,
     +                      NCOUT , NTDMPQ    , paname, sfname, funame,
     +                      danam )
!
!           For the raaien
!
               IF ((ISRTOU .EQ. IHI3 .OR.
     +              ISRTOU .EQ. IHN3     ) .AND.
     +              NORAAI .GT. 0               ) THEN
                  NRVAR3 = NOTOT + NRVAR2
                  IP1 = (NCOUT+NRVAR2)*NDMPAR + 1
                  CALL FIORAA (RIOBUF(IP1), NRVAR3, TRRAAI, NORAAI, NOSYS)
               ENDIF
!
            ELSE
               NRVAR2 = NRVAR
               CALL FIOUTV ( RIOBUF, IOPOIN(K1), NRVAR , NOCONS, NOPA  ,
     +                       NOFUN , NOSFUN    , NOTOT , CONC  , SEGFUN,
     +                       FUNC  , PARAM     , CONS  , IDT   , ITIME ,
     +                       VOLUME, NOSEG     , NOSYS , NODUMP, IDUMP ,
     +                       NX    , NY        , LGRID , IGRDOU, BOUND ,
     +                       NOLOC , PROLOC    , NODEF , DEFAUL)
            ENDIF
!
!        Fill character buffer with substance names and output names
!
            IF ( ISRTOU .EQ. IMNF .OR.
     +           ISRTOU .EQ. IHNF .OR.
     +           ISRTOU .EQ. IMO3 .OR.
     +           ISRTOU .EQ. IHI3 .OR.
     +           ISRTOU .EQ. IHN3     ) THEN
               DO 30 I = 1 , NOTOT
                  NAMBUF(I) = SYNAME(I)
   30          CONTINUE
               DO 40 I = 1 , NRVAR2
                  NAMBUF(NOTOT+I) = OUNAM(K1+I-1)
   40          CONTINUE
            ENDIF
!
!        Perform output
!
            IF ( ISRTOU .EQ. IMON ) THEN
!
               CALL OUTMON ( LUNOUT   , IDUMP , CONC  , AMASS2, ITIME ,
     +                       DUNAME   , SYNAME, MONAME, NODUMP, NOTOT ,
     +                       IP       , ISFLAG, ASMASS, IBFLAG, NRVAR ,
     +                       OUNAM(K1), RIOBUF, ITSTRT, ITSTOP, NDMPAR,
     +                       DANAM    )
!
            ELSEIF ( ISRTOU .EQ. IMO2 ) THEN
!
               CALL OUTMON ( LUNOUT   , IDUMP , CONC  , AMASS2, ITIME ,
     +                       DUNAME   , SYNAME, MONAME, NODUMP, 0     ,
     +                       IP       , ISFLAG, ASMASS, IBFLAG, NRVAR ,
     +                       OUNAM(K1), RIOBUF, ITSTRT, ITSTOP, NDMPAR,
     +                       DANAM    )
!
            ELSEIF ( ISRTOU .EQ. IMO3 ) THEN
!
               CALL OUTMO3 ( LUNOUT, AMASS2   , ITIME , SYNAME, MONAME,
     +                       NOTOT , IP       , ISFLAG, ASMASS, IBFLAG,
     +                       NRVAR2, OUNAM(K1), RIOBUF, ITSTRT, ITSTOP,
     +                       NDMPAR, DANAM    )
!
            ELSEIF ( ISRTOU .EQ. IMO4 ) THEN
!
               CALL OUTMO3 ( LUNOUT, AMASS2   , ITIME , SYNAME, MONAME,
     +                       0     , IP       , ISFLAG, ASMASS, IBFLAG,
     +                       NRVAR2, OUNAM(K1), RIOBUF, ITSTRT, ITSTOP,
     +                       NDMPAR, DANAM    )
!
            ELSEIF ( ISRTOU .EQ. IDMP ) THEN
!
               CALL OUTDMP (LUNOUT, LCHOUT, ITIME , MONAME, NX       ,
     +                      NY    , LGRID , CGRID , NOTOT , NOSYS    ,
     +                      SYNAME, CONC  , BOUND , NRVAR , OUNAM(K1),
     +                      RIOBUF, IP(5) , ISFLAG, INIOUT)
!
            ELSEIF ( ISRTOU .EQ. IDM2 ) THEN
!
               CALL OUTDMP (LUNOUT, LCHOUT, ITIME , MONAME, NX       ,
     +                      NY    , LGRID , CGRID , 0     , 0        ,
     +                      SYNAME, CONC  , BOUND , NRVAR , OUNAM(K1),
     +                      RIOBUF, IP(5) , ISFLAG, INIOUT)
!
            ELSEIF ( ISRTOU .EQ. IHIS ) THEN
!
               CALL OUTHIS (LUNOUT, LCHOUT   , ITIME , MONAME, NODUMP,
     +                      IDUMP , DUNAME   , NOTOT , SYNAME, CONC  ,
     +                      NRVAR , OUNAM(K1), RIOBUF, INIOUT)
!
            ELSEIF ( ISRTOU .EQ. IHNF ) THEN
!
               IOF = NRVAR*NODUMP + 1
               CALL OUTHNF (LUNOUT, LCHOUT     , ITIME , MONAME, NOSEG ,
     +                      NOTOT , CONC       , NAMBUF, NRVAR , RIOBUF,
     +                      IOSTRT, IOSTOP     , IOSTEP, NODUMP, IDUMP ,
     +                      DUNAME, RIOBUF(IOF), INIOUT)
!
            ELSEIF ( ISRTOU .EQ. IHI2 ) THEN
!
               CALL OUTHIS (LUNOUT, LCHOUT   , ITIME , MONAME, NODUMP,
     +                      IDUMP , DUNAME   , 0     , SYNAME, CONC  ,
     +                      NRVAR , OUNAM(K1), RIOBUF, INIOUT)
!
            ELSEIF ( ISRTOU .EQ. IHN2 ) THEN
!
               IOF = NRVAR*NODUMP + 1
               CALL OUTHNF (LUNOUT, LCHOUT     , ITIME    , MONAME, NOSEG ,
     +                      0     , CONC       , OUNAM(K1), NRVAR , RIOBUF,
     +                      IOSTRT, IOSTOP     , IOSTEP   , NODUMP, IDUMP ,
     +                      DUNAME, RIOBUF(IOF), INIOUT   )
!
            ELSEIF ( ISRTOU .EQ. IHI3 ) THEN
!
!           Let op RANAM achter DANAM
!
               NRVAR3 = NOTOT + NRVAR2
               NSEGOU = NDMPAR + NORAAI
               CALL OUTHIS (LUNOUT, LCHOUT   , ITIME , MONAME, NSEGOU,
     +                      IDUMP , DANAM    , 0     , SYNAME, CONC  ,
     +                      NRVAR3, NAMBUF   , RIOBUF, INIOUT)
!
            ELSEIF ( ISRTOU .EQ. IHN3 ) THEN
!
!           Let op RANAM achter DANAM
!
               NRVAR3 = NOTOT + NRVAR2
               NSEGOU = NDMPAR + NORAAI
               IOF = NRVAR3*NSEGOU + 1
               CALL OUTHNF (LUNOUT, LCHOUT     , ITIME    , MONAME, NOSEG ,
     +                      0     , CONC       , NAMBUF   , NRVAR3, RIOBUF,
     +                      IOSTRT, IOSTOP     , IOSTEP   , NSEGOU, IDUMP ,
     +                      DANAM , RIOBUF(IOF), INIOUT   )
!
            ELSEIF ( ISRTOU .EQ. IHI4 ) THEN
!
               CALL OUTHIS (LUNOUT, LCHOUT   , ITIME , MONAME, NDMPAR,
     +                      IDUMP , DANAM    , 0     , SYNAME, CONC  ,
     +                      NRVAR2, OUNAM(K1), RIOBUF, INIOUT)
!
            ELSEIF ( ISRTOU .EQ. IHN4 ) THEN
!
               IOF = NRVAR2*NDMPAR + 1
               CALL OUTHNF (LUNOUT, LCHOUT     , ITIME    , MONAME, NOSEG ,
     +                      0     , CONC       , OUNAM(K1), NRVAR2, RIOBUF,
     +                      IOSTRT, IOSTOP     , IOSTEP   , NDMPAR, IDUMP ,
     +                      DANAM , RIOBUF(IOF), INIOUT   )
!
            ELSEIF ( ISRTOU .EQ. IMAP ) THEN
!
               CALL OUTMAP (LUNOUT   , LCHOUT, ITIME , MONAME, NOSEG ,
     +                      NOTOT    , CONC  , SYNAME, NRVAR , RIOBUF,
     +                      OUNAM(K1), IKNMRK, INIOUT)
!
            ELSEIF ( ISRTOU .EQ. IMNF ) THEN
!
               IOF = NRVAR*NOSEG + 1
               CALL OUTMNF (LUNOUT   , LCHOUT, ITIME , MONAME, NOSEG      ,
     +                      NOTOT    , CONC  , SYNAME, NRVAR , RIOBUF     ,
     +                      OUNAM(K1), IOSTRT, IOSTOP, IOSTEP, RIOBUF(IOF),
     +                      INIOUT   )
!
            ELSEIF ( ISRTOU .EQ. IMNC ) THEN
!
               MNCREC = MNCREC + 1
               CALL OUTMNC (LUN(49)  , LCHAR(49), LCHAR(46), timeid, bndtimeid, MNCREC ,
     +                      ITIME    , MONAME   , NOSEG    , NOTOT  ,
     +                      CONC     , SYNAME   , SYSNM, SYUNI, SYDSC, MNCWQID1 , NRVAR  ,
     +                      RIOBUF   , OUNAM(K1), OUSNM(K1), OUUNI(K1), OUDSC(K1), MNCWQID2 ,
     +                      VOLUME   , IKNMRK   , LUN(19))
!
            ELSEIF ( ISRTOU .EQ. IMA2 ) THEN
!
               CALL OUTMAP (LUNOUT   , LCHOUT, ITIME , MONAME, NOSEG ,
     +                      0        , CONC  , SYNAME, NRVAR , RIOBUF,
     +                      OUNAM(K1), iknmrk, INIOUT)
!
            ELSEIF ( ISRTOU .EQ. IMN2 ) THEN
!
               IOF = NRVAR*NOSEG + 1
               CALL OUTMNF (LUNOUT   , LCHOUT, ITIME , MONAME, NOSEG      ,
     +                      0        , CONC  , SYNAME, NRVAR , RIOBUF     ,
     +                      OUNAM(K1), IOSTRT, IOSTOP, IOSTEP, RIOBUF(IOF),
     +                      INIOUT   )
!
            ELSEIF ( ISRTOU .EQ. IMNC2 ) THEN
!
               MNCREC = MNCREC + 1
               CALL OUTMNC (LUN(49)  , LCHAR(49), LCHAR(46), timeid, bndtimeid, MNCREC ,
     +                      ITIME    , MONAME   , NOSEG    , 0      ,
     +                      CONC     , SYNAME   , SYSNM, SYUNI, SYDSC, MNCWQID1 , NRVAR  ,
     +                      RIOBUF   , OUNAM(K1), OUSNM(K1), OUUNI(K1), OUDSC(K1), MNCWQID2 ,
     +                      IDEPTH   , IKNMRK   , LUN(19))
!
            ELSEIF ( ISRTOU .EQ. IBAL ) THEN
!
               CALL OUTBAL (LUNOUT, LCHOUT, ITIME , MONAME, NOTOT ,
     +                      NOFLUX, SYNAME, NDMPAR, DANAM , ASMASS,
     +                      FLXINT, NRVAR2, RIOBUF, INIOUT)
!
            ELSEIF ( ISRTOU .EQ. IBA2 ) THEN
!
               CALL OUTHIS (LUNOUT, LCHOUT   , ITIME , MONAME, NDMPAR,
     +                      IDUMP , DANAM    , 0     , SYNAME, CONC  ,
     +                      NRVAR , OUNAM(K1), RIOBUF, INIOUT)
!
            ELSEIF ( ISRTOU .EQ. IBA3 ) THEN
!
               ALLOCATE(SURF(NOSEG))
               NAME = 'SURF'
               LGET = .TRUE.
               CALL VALUES ( NAME   , NOSEG  , SURF   , NOCONS , NOPA   ,
     +                       NOFUN  , NOSFUN , CONS   , CONAME , PARAM  ,
     +                       PANAME , FUNC   , FUNAME , SEGFUN , SFNAME ,
     +                       LGET   , IERR   )

               CALL SOBBAL ( NOTOT , ITIME , NOSYS , NOFLUX   , NDMPAR,
     J                       NDMPQ , NTDMPQ, ITSTOP, IMSTRT   , IMSTOP,
     J                       IQDMP , IPDMP , ASMASS, FLXINT   , STOCHI,
     J                       SYNAME, DANAM , MONAME, DMPQ     , NOBND ,
     J                       NOBTYP, BNDTYP, INWTYP, NOCONS   , CONAME,
     J                       CONS  , NOQ   , IPOINT, OUNAM(K1), INTOPT,
     J                       VOLUME, SURF  , NOSEG , LUNOUT   , LCHOUT,
     J                       INIOUT, DMPBAL, NOWST , NOWTYP   , WSTTYP,
     J                       IWASTE, INXTYP, WSTDMP, ISEGCOL  )
               DEALLOCATE (SURF)
!
            ENDIF
!
            IOUTPS(7,IOUT) = INIOUT
!
         endif !(mypart.eq.1)
!
  100    CONTINUE
!
!        Update K1, pointer in IOPOIN and OUNAM
!
         K1 = K1 + NRVAR
!
  200 CONTINUE

      if ( timon ) call timstop ( ithandl )
      RETURN
      END

max_stars_repo_name: liujiamingustc/phd

max_issues_repo_name: liujiamingustc/phd

max_forks_repo_name: liujiamingustc/phd


text:
A small play area on the Rose Creek Parkway in South Davis.

Also see Parks for info on other local parks


text:
	SUBROUTINE SNHINP  ( snfile, area,   line,  marker, border,
     +			     title,  xaxis, yaxis, levels,
     +			     vcoord, dattim, clear, device, panel,
     +			     text, iret )
C************************************************************************
C* SNHINP								*
C*									*
C* This subroutine gets the input parameters for SNHODO.		*
C*									*
C* SNHINP  ( SNFILE, AREA,   LINE,   MARKER, BORDER, TITLE,  		*
C*           XAXIS, YAXIS, LEVELS, VCOORD, DATTIM, CLEAR,  DEVICE, 	*
C*           PANEL, TEXT, IRET )						*
C**									*
C* Log:									*
C* G. Huffman/USRA	 8/89	Adapted from SNPINP			*
C* S. Schotz/GSC	 7/90	Add xaxis,yaxis instead of xyaxis	*
C************************************************************************
	CHARACTER*(*)	snfile, area,   line,   marker, border, title,
     +			levels, vcoord, dattim, device,
     +			panel,  text, xaxis, yaxis
	LOGICAL		clear
C------------------------------------------------------------------------
	CALL IP_STR  ( 'SNFILE',  snfile, ier1 )
	CALL IP_STR  ( 'AREA',    area,   ier2 )
	CALL IP_STR  ( 'LINE',    line,   ier3 )
	CALL IP_STR  ( 'MARKER',  marker, ier4 )
	CALL IP_STR  ( 'BORDER',  border, ier5 )
	CALL IP_STR  ( 'TITLE',   title,  ier6 )
	CALL IP_STR  ( 'XAXIS',   xaxis,  ier8 )
        CALL IP_STR  ( 'YAXIS',   yaxis,  ier16 )
	CALL IP_STR  ( 'LEVELS',  levels, ier9 )
	CALL IP_STR  ( 'VCOORD',  vcoord, ier10 )
	CALL IP_STR  ( 'DATTIM',  dattim, ier11 )
	CALL IP_LOG  ( 'CLEAR',   clear,  ier12 )
	CALL IP_STR  ( 'DEVICE',  device, ier13 )
	CALL IP_STR  ( 'PANEL',   panel,  ier14 )
	CALL IP_STR  ( 'TEXT',    text,   ier15 )
	iret = ier1 + ier2 + ier3 + ier4 + ier5 + ier6 + ier8 +
     +	       ier9 + ier10 + ier11 + ier12 + ier13 + ier14 + ier15 +
     +         ier16
	IF  ( iret .ne. 0 )  iret = -2
C*
	RETURN
	END

max_stars_repo_name: oxelson/gempak

max_issues_repo_name: oxelson/gempak

max_forks_repo_name: oxelson/gempak


text:
	SUBROUTINE DSICMN  ( iret )
C************************************************************************
C* DSICMN								*
C*									*
C* This subroutine sets image common information in the device driver	*
C*									*
C* DSICMN  ( IRET )							*
C*									*
C*									*
C* Output parameters:							*
C*	IRET		INTEGER		Return code			*
C**									*
C* Log:									*
C* J. Cowie/COMET	 2/95						*
C************************************************************************
	INCLUDE		'ERROR.PRM'
	INCLUDE 	'FUNCCODE.PRM'
	INCLUDE 	'IMGDEF.CMN'
C*
	INTEGER		isend (2)
C------------------------------------------------------------------------
C
C*	Load input parameters into buffer and write them to the mailbox.
C
	isend (1) = 2 + NIMCMN
	isend (2) = CSICMN
C
	CALL GPUT ( isend, 2, iret )
        IF  ( iret .ne. NORMAL )  RETURN
C
        CALL GPUT  ( imftyp, NIMCMN, iret )
        IF  ( iret .ne. NORMAL )  RETURN
C
C*	Get the return code.
C
	CALL GGET ( iret, 1, ier )
	IF ( ier .ne. NORMAL ) iret = ier
C
	RETURN
	END


text:
module ekat_array_io_mod
  interface
     function array_io_file_exists(filename) result(exists) bind(c)
       use iso_c_binding
       character(kind=c_char), intent(in) :: filename(*)
       logical(kind=c_bool) :: exists
     end function array_io_file_exists

     function array_io_write_double(filename, a, n) result(ok) bind(c)
       use iso_c_binding
       character(kind=c_char), intent(in) :: filename(*)
       type(c_ptr), intent(in) :: a
       integer(kind=c_int), intent(in), value :: n
       logical(kind=c_bool) :: ok
     end function array_io_write_double
     function array_io_read_double(filename, a, n) result(ok) bind(c)
       use iso_c_binding
       character(kind=c_char), intent(in) :: filename(*)
       type(c_ptr) :: a
       integer(kind=c_int), intent(in), value :: n
       logical(kind=c_bool) :: ok
     end function array_io_read_double

     function array_io_write_float(filename, a, n) result(ok) bind(c)
       use iso_c_binding
       character(kind=c_char), intent(in) :: filename(*)
       type(c_ptr), intent(in) :: a
       integer(kind=c_int), intent(in), value :: n
       logical(kind=c_bool) :: ok
     end function array_io_write_float
     function array_io_read_float(filename, a, n) result(ok) bind(c)
       use iso_c_binding
       character(kind=c_char), intent(in) :: filename(*)
       type(c_ptr) :: a
       integer(kind=c_int), intent(in), value :: n
       logical(kind=c_bool) :: ok
     end function array_io_read_float
  end interface
end module ekat_array_io_mod

max_stars_repo_name: xyuan/EKAT

max_issues_repo_name: xyuan/EKAT

max_forks_repo_name: xyuan/EKAT


        !COMPILER-GENERATED INTERFACE MODULE: Fri Mar  6 15:34:44 2020
        ! This source file is for reference only and may not completely
        ! represent the generated interface used by the compiler.
        MODULE DTODAT__genmod
          INTERFACE
            SUBROUTINE DTODAT(ID,DATCH)
              INTEGER(KIND=4) :: ID(6)
              CHARACTER(LEN=18) :: DATCH
            END SUBROUTINE DTODAT
          END INTERFACE
        END MODULE DTODAT__genmod


text:
C
C $Id: ngputg.f,v 1.6 2008-07-27 00:17:18 haley Exp $
C
C                Copyright (C)  2000
C        University Corporation for Atmospheric Research
C                All Rights Reserved
C
C The use of this Software is governed by a License Agreement.
C
      SUBROUTINE NGPUTG(IFNT,PCHAR,X,Y,SIZE,ICOLOR)
C
C  Draw the glyph associated with the ASCII character CHAR from
C  font number IFNT.
C
      CHARACTER*1 PCHAR,TCHAR
C
C  Disable the function code flag since it is never used and since
C  we want to allow for plotting all printable ASCII characters.
C  Save and restore the current flag as well as the font and
C  character color.
C
      CALL PCGETC('FC',TCHAR)
      CALL PCGETI('FN',IFNTO)
      CALL PCGETI('CC',ICLRO)
C
      CALL PCSETC('FC',CHAR(30))
      CALL PCSETI('FN',IFNT)
      CALL PCSETI('CC',ICOLOR)
      CALL PLCHHQ(X,Y,PCHAR,6.*SIZE/7.,0.,0.)
C
      CALL PCSETC('FC',TCHAR)
      CALL PCSETI('FN',IFNTO)
      CALL PCSETI('CC',ICLRO)
C
      RETURN
      END

max_stars_repo_name: tenomoto/ncl

max_issues_repo_name: tenomoto/ncl

max_forks_repo_name: tenomoto/ncl